Mercurial > hg > Members > kono > os9 > sbc09
diff examples_forth/extend09.4 @ 57:2088fd998865
sbc09 directry clean up
author | Shinji KONO <kono@ie.u-ryukyu.ac.jp> |
---|---|
date | Mon, 23 Jul 2018 16:07:12 +0900 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples_forth/extend09.4 Mon Jul 23 16:07:12 2018 +0900 @@ -0,0 +1,264 @@ +\ Extensions to sod Forth kernel to make a complete Forth system. +\ created 1994 by L.C. Benschop. +\ copyleft (c) 1994-2014 by the sbc09 team, see AUTHORS for more details. +\ license: GNU General Public License version 2, see LICENSE for more details. + +: \G POSTPONE \ ; IMMEDIATE +\G comment till end of line for inclusion in glossary. + +\ PART 1: MISCELLANEOUS WORDS. + +: COMPARE ( addr1 u1 addr2 u2 --- diff ) +\G Compare two strings. diff is negative if addr1 u1 is smaller, 0 if it +\G is equal and positive if it is greater than addr2 u2. + ROT 2DUP - >R + MIN DUP IF + >R + BEGIN + OVER C@ OVER C@ - IF + SWAP C@ SWAP C@ - R> DROP R> DROP EXIT + THEN + 1+ SWAP 1+ SWAP + R> 1- DUP >R 0= + UNTIL R> + THEN DROP + DROP DROP R> NEGATE +; + +: ERASE 0 FILL ; + +: <= ( n1 n2 --- f) +\G f is true if and only if n1 is less than or equal to n2. + > 0= ; + +: 0<= ( n1 --- f) +\G f is true if and only if n1 is less than zero. + 0 <= ; + +: >= + < 0= ; + +: 0<> + 0= 0= ; + +: BOUNDS ( addr1 n --- addr2 addr1) +\G Convert address and length to two bounds addresses for DO LOOP + OVER + SWAP ; + +: WITHIN ( u1 u2 u3 --- f) +\G f is true if u1 is greater or equal to u2 and less than u3 + 2 PICK U> ROT ROT U< 0= AND ; + +: -TRAILING ( c-addr1 u1 --- c-addr2 u2) +\G Adjust the length of the string such that trailing spaces are excluded. + BEGIN + 2DUP + 1- C@ BL = + WHILE + 1- + REPEAT +; + +: NIP ( x1 x2 --- x2) +\G Discard the second item on the stack. + SWAP DROP ; + +\ PART 2: SEARCH ORDER WORDLIST + +: GET-ORDER ( --- w1 w2 ... wn n ) +\G Return all wordlists in the search order, followed by the count. + #ORDER @ 0 ?DO CONTEXT I CELLS + @ LOOP #ORDER @ ; + +: SET-ORDER ( w1 w2 ... wn n --- ) +\G Set the search order to the n wordlists given on the stack. + #ORDER ! 0 #ORDER @ 1- DO CONTEXT I CELLS + ! -1 +LOOP ; + +: ALSO ( --- ) +\G Duplicate the last wordlist in the search order. + CONTEXT #ORDER @ CELLS + DUP CELL- @ SWAP ! 1 #ORDER +! ; + +: PREVIOUS ( --- ) +\G Remove the last wordlist from search order. + -1 #ORDER +! ; + +VARIABLE #THREADS ( --- a-addr) +\G This variable holds the number of threads a word list will have. + +: WORDLIST ( --- wid) +\G Make a new wordlist and give its address. + HERE #THREADS @ , #THREADS @ CELLS ALLOT HERE #THREADS @ CELLS - + #THREADS @ CELLS ERASE ; + +: DEFINITIONS ( --- ) +\G Set the definitions wordlist to the last wordlist in the search order. +CONTEXT #ORDER @ 1- CELLS + @ CURRENT ! ; + +: FORTH ( --- ) +\G REplace the last wordlist in the search order with FORTH-WORDLIST + FORTH-WORDLIST CONTEXT #ORDER @ 1- CELLS + ! ; + +1 #THREADS ! +WORDLIST +CONSTANT ROOT-WORDLIST ( --- wid ) +\G Minimal wordlist for ONLY + +4 #THREADS ! + +: ONLY ( --- ) +\G Set the search order to the minimal wordlist. + 1 #ORDER ! ROOT-WORDLIST CONTEXT ! ; + +: VOCABULARY ( --- ) +\G Make a definition that will replace the last word in the search order +\G by its wordlist. + WORDLIST CREATE , \ Make a new wordlist and store it in def. + DOES> >R \ Replace last item in the search order. + GET-ORDER SWAP DROP R> @ SWAP SET-ORDER ; + + +\ PART 3: SOME UTILITIES, DUMP .S WORDS + +: DL ( addr1 --- addr2 ) +\G hex/ascii dump in one line of 16 bytes at addr1 addr2 is addr1+16 + BASE @ >R 16 BASE ! CR + DUP 0 <# # # # # #> TYPE ." : " + 16 0 DO + DUP I + C@ 0 <# # # #> TYPE SPACE + LOOP + 16 0 DO + DUP I + C@ DUP 127 AND 31 < IF DROP ." ." ELSE EMIT THEN + LOOP + 16 + R> BASE ! ; + + +: DUMP ( addr len --- ) +\G Show a hex/ascii dump of the memory block of len bytes at addr + 15 + 4 RSHIFT 0 DO + DL + LOOP DROP ; + +: .S ( --- ) +\G Show the contents of the stack. + DEPTH IF + 0 DEPTH 2 - DO I PICK . -1 +LOOP + ELSE ." Empty " THEN ; + + +: ID. ( nfa --- ) +\G Show the name of the word with name field address nfa. + COUNT 31 AND TYPE SPACE ; + +: WORDS ( --- ) +\G Show all words in the last wordlist of the search order. + CONTEXT #ORDER @ 1- CELLS + @ + DUP @ >R \ number of threads to return stack. + CELL+ R@ 0 DO DUP I CELLS + @ SWAP LOOP DROP \ All thread pointers to stack. + BEGIN + 0 0 + R@ 0 DO + I 2 + PICK OVER U> IF + DROP DROP I I 1 + PICK + THEN + LOOP \ Find the thread pointer with the highest address. + WHILE + DUP 1+ PICK DUP ID. \ Print the name. + CELL- @ \ Link to previous. + SWAP 2 + CELLS SP@ + ! \ Update the right thread pointer. + REPEAT + DROP R> 0 DO DROP LOOP \ Drop the thread pointers. +; + + +ROOT-WORDLIST CURRENT ! +: FORTH FORTH ; +: ALSO ALSO ; +: ONLY ONLY ; +: PREVIOUS PREVIOUS ; +: DEFINITIONS DEFINITIONS ; +: WORDS WORDS ; +DEFINITIONS +\ Fill the ROOT wordlist. + +\ PART 4: ERROR MESSAGES + +: MESS" ( n "cccq" --- ) +\G Create an error message for throw code n. + ALIGN , ERRORS @ , HERE 2 CELLS - ERRORS ! 34 WORD C@ 1+ ALLOT ; + +-3 MESS" Stack overflow" +-4 MESS" Stack underflow" +-10 MESS" Divide overflow" +-13 MESS" Undefined word" +-22 MESS" Incomplete control structure" +-28 MESS" BREAK key pressed" +-37 MESS" File I/O error" +-38 MESS" File does not exist" + +: 2CONSTANT ( d --- ) +\G Create a new definition that has the following runtime behavior. +\G Runtime: ( --- d) push the constant double number on the stack. + CREATE HERE 2! 2 CELLS ALLOT DOES> 2@ ; + +: D.R ( d n --- ) +\G Print double number d right-justified in a field of width n. + >R SWAP OVER DABS <# #S ROT SIGN #> R> OVER - 0 MAX SPACES TYPE ; + +: U.R ( u n --- ) +\G Print unsigned number u right-justified in a field of width n. + >R 0 R> D.R ; + +: .R ( n1 n2 --- ) +\G Print number n1 right-justified in a field of width n2. + >R S>D R> D.R ; + +: AT-XY ( x y --- ) +\G Put screen cursor at location (x,y) (0,0) is upper left corner. + 27 EMIT [CHAR] [ EMIT SWAP 1+ SWAP 0 .R [CHAR] ; EMIT + 1+ 0 .R [CHAR] H EMIT ; + +: PAGE +\G Clear the screen. + 27 EMIT ." [2J" 0 0 AT-XY ; + +: VALUE ( n --- ) + CREATE , DOES> @ ; + +: TO + ' >BODY STATE @ IF + POSTPONE LITERAL POSTPONE ! + ELSE + ! + THEN +; IMMEDIATE + +: D- ( d1 d2 --- d3) + DNEGATE D+ ; + +: D0= + OR 0= ; + +: D= + D- D0= ; + +: BLANK + 32 FILL ; + +: AGAIN + POSTPONE 0 POSTPONE UNTIL ; IMMEDIATE + +: CASE + CSP @ SP@ CSP ! ; IMMEDIATE +: OF + POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP ; IMMEDIATE +: ENDOF + POSTPONE ELSE ; IMMEDIATE +: ENDCASE + POSTPONE DROP BEGIN SP@ CSP @ - WHILE POSTPONE THEN REPEAT + CSP ! ; IMMEDIATE + + +: MS ( n --- ) +\G Delay for n milliseconds. + 5 + 20 / $2B @ + BEGIN DUP $2B @ = UNTIL DROP ; + +CAPS ON +