view examples_forth/extend09.4 @ 161:91447c3ccd58

fix
author Shinji KONO Tue, 12 Feb 2019 09:16:24 +0900 2088fd998865
line wrap: on
line source
```
\ 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.

: \G POSTPONE \ ; IMMEDIATE
\G comment till end of line for inclusion in glossary.

\ PART 1: MISCELLANEOUS WORDS.

\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= ;

\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 ;

\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 +! ;

\G This variable holds the number of threads a word list will have.

: WORDLIST ( --- wid)
\G Make a new wordlist and give its address.

: 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 + ! ;

WORDLIST
CONSTANT ROOT-WORDLIST ( --- wid )
\G Minimal wordlist for ONLY

: 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

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
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

```