859 lines
12 KiB
Forth
859 lines
12 KiB
Forth
\ Part 2 of the JonesForth tutorial.
|
|
\ This one is added word-by-word as they are succesfully executed
|
|
|
|
\ Define / and MOD in terms of /MOD
|
|
: / /MOD SWAP DROP ;
|
|
: MOD /MOD DROP ;
|
|
|
|
\ Some char constant
|
|
: '\n' 10 ;
|
|
: BL 32 ; \ BL (blank) is standard FORTH word for space.
|
|
|
|
: CR '\n' EMIT ;
|
|
: SPACE BL EMIT ;
|
|
|
|
: NEGATE 0 SWAP - ;
|
|
|
|
: TRUE 1 ;
|
|
: FALSE 0 ;
|
|
: NOT 0= ;
|
|
|
|
\ LITERAL takes whatever on the stack and compiles LIT <foo>
|
|
: LITERAL IMMEDIATE
|
|
' LIT ,
|
|
,
|
|
;
|
|
|
|
: ':'
|
|
[
|
|
CHAR :
|
|
]
|
|
LITERAL
|
|
;
|
|
|
|
: ';' [ CHAR ; ] LITERAL ;
|
|
: '(' [ CHAR ( ] LITERAL ;
|
|
: ')' [ CHAR ) ] LITERAL ;
|
|
: '"' [ CHAR " ] LITERAL ;
|
|
: 'A' [ CHAR A ] LITERAL ;
|
|
: '0' [ CHAR 0 ] LITERAL ;
|
|
: '-' [ CHAR - ] LITERAL ;
|
|
: '.' [ CHAR . ] LITERAL ;
|
|
|
|
: [COMPILE] IMMEDIATE
|
|
WORD
|
|
FIND
|
|
>CFA
|
|
,
|
|
;
|
|
|
|
: RECURSE IMMEDIATE
|
|
LATEST @
|
|
>CFA
|
|
,
|
|
;
|
|
|
|
\ Conditionals Statements
|
|
|
|
: IF IMMEDIATE
|
|
' 0BRANCH ,
|
|
HERE @
|
|
0 ,
|
|
;
|
|
|
|
: THEN IMMEDIATE
|
|
DUP
|
|
HERE @ SWAP -
|
|
SWAP !
|
|
;
|
|
|
|
: ELSE IMMEDIATE
|
|
' BRANCH ,
|
|
HERE @
|
|
0 ,
|
|
SWAP
|
|
DUP
|
|
HERE @ SWAP -
|
|
SWAP !
|
|
;
|
|
|
|
: UNLESS IMMEDIATE
|
|
' NOT ,
|
|
[COMPILE] IF
|
|
;
|
|
|
|
\ Loop Construct
|
|
|
|
: BEGIN IMMEDIATE
|
|
HERE @
|
|
;
|
|
|
|
: UNTIL IMMEDIATE
|
|
' 0BRANCH ,
|
|
HERE @ -
|
|
,
|
|
;
|
|
|
|
: AGAIN IMMEDIATE
|
|
' BRANCH ,
|
|
HERE @ -
|
|
,
|
|
;
|
|
|
|
: WHILE IMMEDIATE
|
|
' 0BRANCH ,
|
|
HERE @
|
|
0 ,
|
|
;
|
|
|
|
: REPEAT IMMEDIATE
|
|
' BRANCH ,
|
|
SWAP
|
|
HERE @ - ,
|
|
DUP
|
|
HERE @ SWAP -
|
|
SWAP !
|
|
;
|
|
|
|
\ Comments
|
|
: ( IMMEDIATE
|
|
1
|
|
BEGIN
|
|
KEY
|
|
DUP '(' = IF
|
|
DROP
|
|
1+
|
|
ELSE
|
|
')' = IF
|
|
1-
|
|
THEN
|
|
THEN
|
|
DUP 0= UNTIL
|
|
DROP
|
|
;
|
|
|
|
( Now we can nest ( ... ) as much as we want )
|
|
|
|
\ Stack Manipulation
|
|
: NIP ( x y -- y ) SWAP DROP ;
|
|
: TUCK ( x y -- y x y ) SWAP OVER ;
|
|
: PICK ( x_u ... x_1 x_0 u -- x_u ... x_1 x_0 x_u )
|
|
1+
|
|
8 * ( multiply by the word size )
|
|
DSP@ +
|
|
@
|
|
;
|
|
|
|
\ Writes N spaces to stdout
|
|
: SPACES ( n -- )
|
|
BEGIN
|
|
DUP 0>
|
|
WHILE
|
|
SPACE
|
|
1-
|
|
REPEAT
|
|
DROP
|
|
;
|
|
|
|
\ EXTRA: Writes N zeroes to stdout
|
|
: ZEROES ( n -- )
|
|
BEGIN
|
|
DUP 0>
|
|
WHILE
|
|
'0' EMIT
|
|
1-
|
|
REPEAT
|
|
DROP
|
|
;
|
|
|
|
\ Standard word for manipulating BASE.
|
|
: DECIMAL ( -- ) 10 BASE ! ;
|
|
: HEX ( -- ) 16 BASE ! ;
|
|
|
|
( Printing Numbers )
|
|
|
|
: U. ( u -- )
|
|
BASE @ /MOD
|
|
?DUP IF ( if quotient <> 0 then )
|
|
RECURSE ( print the quotient )
|
|
THEN
|
|
|
|
( print the remainder )
|
|
DUP 10 < IF
|
|
'0'
|
|
ELSE
|
|
10 -
|
|
'A'
|
|
THEN
|
|
+
|
|
EMIT
|
|
;
|
|
|
|
( Printing the content of the stack )
|
|
: .S ( -- )
|
|
DSP@
|
|
BEGIN
|
|
DUP S0 @ <
|
|
WHILE
|
|
DUP @ U.
|
|
SPACE
|
|
8+
|
|
REPEAT
|
|
DROP
|
|
;
|
|
|
|
( Returns the width of an unsigned number (in characters) in the current base )
|
|
: UWIDTH
|
|
BASE @ /
|
|
?DUP IF
|
|
RECURSE 1+
|
|
ELSE
|
|
1
|
|
THEN
|
|
;
|
|
|
|
: U.R ( u width -- )
|
|
SWAP
|
|
DUP
|
|
UWIDTH
|
|
ROT
|
|
SWAP -
|
|
SPACES
|
|
U.
|
|
;
|
|
|
|
\ EXTRA, print zeroes padded unsigned number
|
|
: ZU.R ( u width -- )
|
|
SWAP
|
|
DUP
|
|
UWIDTH
|
|
ROT
|
|
SWAP -
|
|
ZEROES
|
|
U.
|
|
;
|
|
|
|
: .R ( n width -- )
|
|
SWAP ( width n )
|
|
DUP 0< IF
|
|
NEGATE ( width u )
|
|
1 ( save flag to remember that it was negative | width u 1 )
|
|
SWAP ( width 1 u )
|
|
ROT ( 1 u width )
|
|
1- ( 1 u width-1 )
|
|
ELSE
|
|
0 ( width u 0 )
|
|
SWAP ( width 0 u )
|
|
ROT ( 0 u width )
|
|
THEN
|
|
SWAP ( flag width u )
|
|
DUP ( flag width u u )
|
|
UWIDTH ( flag width u uwidth )
|
|
ROT ( flag u uwidth width )
|
|
SWAP - ( flag u width-uwidth )
|
|
|
|
SPACES ( flag u )
|
|
SWAP ( u flag )
|
|
|
|
IF
|
|
'-' EMIT
|
|
THEN
|
|
U.
|
|
;
|
|
|
|
( Finally )
|
|
: . 0 .R SPACE ;
|
|
|
|
( The real U. )
|
|
: U. U. SPACE ;
|
|
|
|
: ? ( addr -- ) @ . ;
|
|
|
|
: WITHIN ( c a b - f )
|
|
-ROT ( b c a )
|
|
OVER ( b c a c )
|
|
<= IF
|
|
> IF ( b c )
|
|
TRUE
|
|
ELSE
|
|
FALSE
|
|
THEN
|
|
ELSE
|
|
2DROP
|
|
FALSE
|
|
THEN
|
|
;
|
|
|
|
: DEPTH ( -- n )
|
|
S0 @ DSP@ -
|
|
8-
|
|
;
|
|
|
|
: ALIGNED ( addr -- addr )
|
|
7 + 7 INVERT AND
|
|
;
|
|
|
|
: ALIGN HERE @ ALIGNED HERE ! ;
|
|
|
|
: C,
|
|
HERE @ C!
|
|
1 HERE +!
|
|
;
|
|
|
|
: S" IMMEDIATE ( -- addr len )
|
|
STATE @ IF
|
|
' LITSTRING ,
|
|
HERE @
|
|
0 ,
|
|
BEGIN
|
|
KEY
|
|
DUP '"' <>
|
|
WHILE
|
|
C,
|
|
REPEAT
|
|
DROP
|
|
DUP
|
|
HERE @ SWAP -
|
|
8-
|
|
SWAP !
|
|
ALIGN
|
|
ELSE
|
|
HERE @
|
|
BEGIN
|
|
KEY
|
|
DUP '"' <>
|
|
WHILE
|
|
OVER C!
|
|
1+
|
|
REPEAT
|
|
DROP
|
|
HERE @ -
|
|
HERE @
|
|
SWAP
|
|
THEN
|
|
;
|
|
|
|
: ." IMMEDIATE
|
|
STATE @ IF
|
|
[COMPILE] S"
|
|
' TELL ,
|
|
ELSE
|
|
BEGIN
|
|
KEY
|
|
DUP '"' = IF
|
|
DROP
|
|
EXIT
|
|
THEN
|
|
EMIT
|
|
AGAIN
|
|
THEN
|
|
;
|
|
|
|
( Constant and Variables )
|
|
|
|
: CONSTANT
|
|
WORD
|
|
CREATE
|
|
DOCOL ,
|
|
' LIT ,
|
|
,
|
|
' EXIT ,
|
|
;
|
|
|
|
: ALLOT ( n -- addr )
|
|
HERE @ SWAP
|
|
HERE +!
|
|
;
|
|
|
|
: CELLS ( n -- n ) 8 * ;
|
|
|
|
: VARIABLE
|
|
1 CELLS ALLOT
|
|
WORD CREATE
|
|
DOCOL ,
|
|
' LIT ,
|
|
,
|
|
' EXIT ,
|
|
;
|
|
|
|
: VALUE ( n -- )
|
|
WORD CREATE
|
|
DOCOL ,
|
|
' LIT ,
|
|
,
|
|
' EXIT ,
|
|
;
|
|
|
|
: TO IMMEDIATE ( n -- )
|
|
WORD
|
|
FIND
|
|
>DFA
|
|
8+
|
|
STATE @ IF
|
|
' LIT ,
|
|
,
|
|
' ! ,
|
|
ELSE
|
|
!
|
|
THEN
|
|
;
|
|
|
|
: +TO IMMEDIATE
|
|
WORD
|
|
FIND
|
|
>DFA
|
|
8+
|
|
STATE @ IF
|
|
' LIT ,
|
|
,
|
|
' +! ,
|
|
ELSE
|
|
+!
|
|
THEN
|
|
;
|
|
|
|
: ID. ( addr -- )
|
|
8+
|
|
DUP C@
|
|
F_LENMASK AND
|
|
BEGIN
|
|
DUP 0>
|
|
WHILE
|
|
SWAP 1+
|
|
DUP C@
|
|
EMIT
|
|
SWAP 1-
|
|
REPEAT
|
|
2DROP ( len addr -- )
|
|
;
|
|
|
|
: ?HIDDEN
|
|
8+
|
|
C@
|
|
F_HIDDEN AND
|
|
;
|
|
|
|
: ?IMMEDIATE
|
|
8+
|
|
C@
|
|
F_IMMED AND
|
|
;
|
|
|
|
: WORDS
|
|
LATEST @
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
DUP ?HIDDEN NOT IF
|
|
DUP ID.
|
|
SPACE
|
|
THEN
|
|
@
|
|
REPEAT
|
|
CR
|
|
;
|
|
|
|
: FORGET
|
|
WORD FIND
|
|
DUP @ LATEST !
|
|
HERE !
|
|
;
|
|
|
|
: DUMP ( addr len -- )
|
|
BASE @ -ROT
|
|
HEX
|
|
|
|
BEGIN
|
|
?DUP ( while len > 0 )
|
|
WHILE
|
|
OVER 8 ZU.R ( print the address )
|
|
SPACE
|
|
( print up to 16 words on this line )
|
|
2DUP ( addr len addr len )
|
|
1- 15 AND 1+ ( addr len addr linelen )
|
|
BEGIN
|
|
?DUP ( while linelen > 0 )
|
|
WHILE
|
|
SWAP ( addr len linelen addr )
|
|
DUP C@ ( addr len linelen addr byte )
|
|
2 ZU.R SPACE ( print the byte )
|
|
1+ SWAP 1- ( addr len linelen addr -- addr len addr+1 linelen-1 )
|
|
REPEAT
|
|
DROP ( addr len )
|
|
|
|
( print the ASCII equivalents )
|
|
2DUP 1- 15 AND 1+ ( addr len addr linelen )
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
SWAP ( addr len linelen addr )
|
|
DUP C@ ( addr len linelen addr byte )
|
|
DUP 32 128 WITHIN IF ( 32 <= c < 128? )
|
|
EMIT
|
|
ELSE
|
|
DROP '.' EMIT
|
|
THEN
|
|
1+ SWAP 1-
|
|
REPEAT
|
|
DROP
|
|
CR
|
|
DUP 1- 15 AND 1+
|
|
TUCK
|
|
-
|
|
>R + R>
|
|
REPEAT
|
|
DROP
|
|
BASE !
|
|
;
|
|
|
|
: CASE IMMEDIATE
|
|
0
|
|
;
|
|
|
|
: OF IMMEDIATE
|
|
' OVER ,
|
|
' = ,
|
|
[COMPILE] IF
|
|
' DROP ,
|
|
;
|
|
|
|
: ENDOF IMMEDIATE
|
|
[COMPILE] ELSE
|
|
;
|
|
|
|
: ENDCASE IMMEDIATE
|
|
' DROP ,
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
[COMPILE] THEN
|
|
REPEAT
|
|
;
|
|
|
|
: CFA>
|
|
LATEST @
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
2DUP SWAP
|
|
< IF
|
|
NIP
|
|
EXIT
|
|
THEN
|
|
@
|
|
REPEAT
|
|
DROP
|
|
0
|
|
;
|
|
|
|
: SEE
|
|
WORD FIND
|
|
HERE @
|
|
LATEST @
|
|
|
|
BEGIN
|
|
2 PICK
|
|
OVER
|
|
<>
|
|
WHILE
|
|
NIP
|
|
DUP @
|
|
REPEAT
|
|
|
|
DROP
|
|
SWAP
|
|
|
|
':' EMIT SPACE DUP ID. SPACE
|
|
DUP ?IMMEDIATE IF ." IMMEDIATE " THEN
|
|
|
|
>DFA
|
|
|
|
BEGIN ( end start )
|
|
2DUP >
|
|
WHILE
|
|
DUP @ ( end start codeword )
|
|
CASE
|
|
' LIT OF ( is it LIT ? )
|
|
8 + DUP @ ( get next word )
|
|
. ( and print it )
|
|
ENDOF
|
|
' LITSTRING OF
|
|
[ CHAR S ] LITERAL EMIT '"' EMIT SPACE ( print S"<space> )
|
|
8 + DUP @ ( get the length )
|
|
SWAP 8 + SWAP ( end start+8 length )
|
|
2DUP TELL ( print the string )
|
|
'"' EMIT SPACE
|
|
+ ALIGNED ( end start+8+len, aligned )
|
|
8 - ( because we're about to add 8 below )
|
|
ENDOF
|
|
' 0BRANCH OF
|
|
." 0BRANCH ( "
|
|
8 + DUP @
|
|
.
|
|
." ) "
|
|
ENDOF
|
|
' BRANCH OF
|
|
." BRANCH ( "
|
|
8 + DUP @
|
|
.
|
|
." ) "
|
|
ENDOF
|
|
' ' OF
|
|
[ CHAR ' ] LITERAL EMIT SPACE
|
|
8 + DUP @
|
|
CFA>
|
|
ID. SPACE
|
|
ENDOF
|
|
' EXIT OF
|
|
2DUP
|
|
8 +
|
|
<> IF
|
|
." EXIT "
|
|
THEN
|
|
ENDOF
|
|
DUP
|
|
CFA>
|
|
ID. SPACE
|
|
ENDCASE
|
|
8 +
|
|
REPEAT
|
|
';' EMIT CR
|
|
2DROP
|
|
;
|
|
|
|
: :NONAME
|
|
0 0 CREATE
|
|
HERE @
|
|
DOCOL ,
|
|
]
|
|
;
|
|
|
|
: ['] IMMEDIATE
|
|
' LIT ,
|
|
;
|
|
|
|
|
|
( Exception )
|
|
: EXCEPTION-MARKER
|
|
RDROP
|
|
0
|
|
;
|
|
|
|
: CATCH
|
|
DSP@ 8+ >R
|
|
' EXCEPTION-MARKER 8+
|
|
>R
|
|
EXECUTE
|
|
;
|
|
|
|
: THROW
|
|
?DUP IF
|
|
RSP@
|
|
BEGIN
|
|
DUP R0 8- <
|
|
WHILE
|
|
DUP @
|
|
' EXCEPTION-MARKER 8+ = IF
|
|
8+
|
|
RSP!
|
|
DUP DUP DUP
|
|
R>
|
|
8-
|
|
SWAP OVER
|
|
!
|
|
DSP! EXIT
|
|
THEN
|
|
8+
|
|
REPEAT
|
|
DROP
|
|
CASE
|
|
0 1- OF ( ABORT )
|
|
." ABORTED" CR
|
|
ENDOF
|
|
." UNCAUGHT THROW "
|
|
DUP . CR
|
|
ENDCASE
|
|
QUIT
|
|
THEN
|
|
;
|
|
|
|
: ABORT
|
|
0 1- THROW
|
|
;
|
|
|
|
: PRINT-STACK-TACE
|
|
RSP@
|
|
BEGIN
|
|
DUP R0 8- <
|
|
WHILE
|
|
DUP @
|
|
CASE
|
|
' EXCEPTION-MARKER 8+ OF
|
|
." CATCH ( DSP="
|
|
8+ DUP @ U.
|
|
." ) "
|
|
ENDOF
|
|
DUP
|
|
CFA>
|
|
?DUP IF
|
|
2DUP
|
|
ID.
|
|
[ CHAR + ] LITERAL EMIT
|
|
SWAP >DFA 8+ - .
|
|
THEN
|
|
ENDCASE
|
|
8+
|
|
REPEAT
|
|
DROP
|
|
CR
|
|
;
|
|
|
|
( C String )
|
|
|
|
: Z" IMMEDIATE
|
|
STATE @ IF
|
|
' LITSTRING ,
|
|
HERE @
|
|
0 ,
|
|
BEGIN
|
|
KEY
|
|
DUP '"' <>
|
|
WHILE
|
|
HERE @ C!
|
|
1 HERE +!
|
|
REPEAT
|
|
0 HERE @ C!
|
|
1 HERE +!
|
|
DROP
|
|
DUP
|
|
HERE @ SWAP -
|
|
8-
|
|
SWAP !
|
|
ALIGN
|
|
' DROP ,
|
|
ELSE
|
|
HERE @
|
|
BEGIN
|
|
KEY
|
|
DUP '"' <>
|
|
WHILE
|
|
OVER C!
|
|
1+
|
|
REPEAT
|
|
DROP
|
|
0 SWAP C!
|
|
HERE @
|
|
THEN
|
|
;
|
|
|
|
: STRLEN
|
|
DUP
|
|
BEGIN
|
|
DUP C@ 0<>
|
|
WHILE
|
|
1+
|
|
REPEAT
|
|
SWAP -
|
|
;
|
|
|
|
: CSTRING
|
|
SWAP OVER
|
|
HERE @ SWAP
|
|
CMOVE
|
|
HERE @ +
|
|
0 SWAP C!
|
|
HERE @
|
|
;
|
|
|
|
( The Environment )
|
|
|
|
: ARGC S0 @ @ ;
|
|
|
|
: ARGV ( n -- str u )
|
|
1+ CELLS S0 @ +
|
|
@
|
|
DUP STRLEN
|
|
;
|
|
|
|
: ENVIRON
|
|
ARGC
|
|
2 +
|
|
CELLS
|
|
S0 @ +
|
|
;
|
|
|
|
: BYE 0 SYS_EXIT SYSCALL1 ;
|
|
|
|
: GET-BRK ( -- brkpoint ) 0 SYS_BRK SYSCALL1 ;
|
|
|
|
: UNUSED ( -- n ) GET-BRK HERE @ - 8 / ;
|
|
|
|
: BRK ( brkpoint -- ) SYS_BRK SYSCALL1 ;
|
|
|
|
: MORECORE ( cells -- ) CELLS GET-BRK + BRK ;
|
|
|
|
: R/O ( -- fam ) O_RDONLY ;
|
|
: R/W ( -- fam ) O_RDWR ;
|
|
|
|
: OPEN-FILE ( addr u fam -- fd 0 (if successful) | c-addr u fam -- fd errno (if there was an error) )
|
|
-ROT
|
|
CSTRING
|
|
SYS_OPEN SYSCALL2
|
|
DUP
|
|
DUP 0< IF
|
|
NEGATE
|
|
ELSE
|
|
DROP 0
|
|
THEN
|
|
;
|
|
|
|
: CREATE-FILE ( similar to OPEN-FILE )
|
|
O_CREAT OR
|
|
O_TRUNC OR
|
|
-ROT
|
|
CSTRING
|
|
420 -ROT
|
|
SYS_OPEN SYSCALL3
|
|
DUP
|
|
DUP 0< IF
|
|
NEGATE
|
|
ELSE
|
|
DROP 0
|
|
THEN
|
|
;
|
|
|
|
: CLOSE-FILE
|
|
SYS_CLOSE SYSCALL1
|
|
NEGATE
|
|
;
|
|
|
|
: READ-FILE
|
|
>R SWAP R>
|
|
SYS_READ SYSCALL3
|
|
DUP
|
|
DUP 0< IF
|
|
NEGATE
|
|
ELSE
|
|
DROP 0
|
|
THEN
|
|
;
|
|
|
|
: PERROR
|
|
TELL
|
|
':' EMIT SPACE
|
|
." ERRNO="
|
|
. CR
|
|
;
|
|
|
|
( TODO: translate jonesforth x86 assembler into x64 )
|
|
|
|
: WELCOME
|
|
S" TEST-MODE" FIND NOT IF
|
|
." Jombloforth version " VERSION . CR
|
|
UNUSED . ." cells remaining" CR
|
|
." ok " CR
|
|
THEN
|
|
;
|
|
|
|
WELCOME
|
|
HIDE WELCOME |