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
+