jonesforth.f

\ Annotation has been removed from this file to expedite processing.
\ See the files in the /annexia/ for a full Literate Code tutorial, it's great!

: '\n' 10 ;
: BL 32 ;
: ':' [ CHAR : ] LITERAL ;
: ';' [ CHAR ; ] LITERAL ;
: '(' [ CHAR ( ] LITERAL ;
: ')' [ CHAR ) ] LITERAL ;
: '"' [ CHAR " ] LITERAL ;
: 'A' [ CHAR A ] LITERAL ;
: '0' [ CHAR 0 ] LITERAL ;
: '-' [ CHAR - ] LITERAL ;
: '+' [ CHAR + ] LITERAL ;
: '.' [ CHAR . ] LITERAL ;
: ( IMMEDIATE 1 BEGIN KEY DUP '(' = IF DROP 1+ ELSE ')' = IF 1- THEN THEN DUP 0= UNTIL DROP ;
: SPACES ( n -- ) BEGIN DUP 0> WHILE SPACE 1- REPEAT DROP ;
: WITHIN -ROT OVER <= IF > IF TRUE ELSE FALSE THEN ELSE 2DROP FALSE THEN ;
: ALIGNED ( c-addr -- a-addr ) 3 + 3 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 - 4- 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
;

: CFA> LATEST @ BEGIN ?DUP WHILE 2DUP SWAP < IF NIP EXIT THEN @ REPEAT DROP 0 ;
: ID. 4+ COUNT F_LENMASK AND BEGIN DUP 0> WHILE SWAP COUNT EMIT SWAP 1- REPEAT 2DROP ;

: ['] IMMEDIATE ' LIT , ;
: EXCEPTION-MARKER RDROP 0 ;
: CATCH ( xt -- exn? ) DSP@ 4+ >R ' EXCEPTION-MARKER 4+ >R EXECUTE ;
: THROW ( n -- ) ?DUP IF
	RSP@ BEGIN DUP R0 4-
        < WHILE DUP @ ' EXCEPTION-MARKER 4+
		= IF 4+ RSP! DUP DUP DUP R> 4- SWAP OVER ! DSP! EXIT THEN
	4+ REPEAT DROP
	CASE
		0 1- OF ." ABORTED" CR ENDOF
		." UNCAUGHT THROW " DUP . CR
	ENDCASE QUIT THEN
;
: ABORT ( -- ) 0 1- THROW ;
: PRINT-STACK-TRACE
	RSP@ BEGIN DUP R0 4-
        < WHILE DUP @ CASE
		' EXCEPTION-MARKER 4+ OF ." CATCH ( DSP=" 4+ DUP @ U. ." ) " ENDOF
		DUP CFA> ?DUP IF 2DUP ID. [ CHAR + ] LITERAL EMIT SWAP >DFA 4+ - . THEN
	ENDCASE 4+ REPEAT DROP CR
;

: DICT WORD 2DUP FIND DUP IF -ROT 2DROP THEN ;
: DICT-CHECKED DICT DUP NOT IF ." Unknown word " -ROT TELL CR ABORT THEN ;
: VALUE ( n -- ) WORD CREATE DOCOL , ' LIT , , ' EXIT , ;
: TO IMMEDIATE ( n -- )
        DICT >DFA 4+
	STATE @ IF ' LIT , , ' ! , ELSE ! THEN
;
: +TO IMMEDIATE
        DICT-CHECKED >DFA 4+
	STATE @ IF ' LIT , , ' +! , ELSE +! THEN
;
: ?HIDDEN 4+ C@ F_HIDDEN AND ;
: ?IMMEDIATE 4+ C@ F_IMMED AND ;
: WORDS LATEST @ BEGIN ?DUP WHILE DUP ?HIDDEN NOT IF DUP ID. SPACE THEN @ REPEAT CR ;
: FORGET DICT-CHECKED DUP @ LATEST ! HERE ! ;

: (;CODE) R> LATEST @ >CFA ! ;
: ;CODE IMMEDIATE ' (;CODE) , ;
: (CODE) HERE @ LATEST @ >CFA ! ;
: CODE : (CODE) ;
: (END-CODE-INT) LATEST @ HIDDEN [COMPILE] [ ;
: (END-CODE) IMMEDIATE (END-CODE-INT) ;
: END-CODE IMMEDIATE [COMPILE] $NEXT (END-CODE-INT) ;
HIDE (END-CODE-INT)
HIDE (CODE)

: DOES> IMMEDIATE ' (;CODE) , [COMPILE] $DODOES ;

: PRINT-PRETTY-DFA-OFFSET
DUP
CFA> ?DUP IF
   DUP ID. '+' EMIT >DFA - 4/
THEN
U.
;
: PRINT-PRETTY-CODEWORD
>CFA @ PRINT-PRETTY-DFA-OFFSET
;
: PUSH-SEE-NATIVE-BASE BASE @  -ROT HEX ;
: POP-SEE-NATIVE-BASE ROT BASE ! ;
: SEE-NATIVE-DUMP-CELLS BEGIN 2DUP > WHILE DUP @ U. 4 + REPEAT ;
: SEE-NATIVE
PUSH-SEE-NATIVE-BASE
." CODE " DUP ID. SPACE
." ( CODEWORD " DUP PRINT-PRETTY-CODEWORD ')' EMIT SPACE
>DFA SEE-NATIVE-DUMP-CELLS
POP-SEE-NATIVE-BASE
2DROP
." (END-CODE)" CR
;
: ?NATIVE DUP >CFA @ DOCOL = NOT ;
: SEE
	DICT-CHECKED HERE @ LATEST @
	BEGIN 2 PICK OVER <> WHILE NIP DUP @ REPEAT
	DROP SWAP
        ?NATIVE IF SEE-NATIVE EXIT THEN
        ':' EMIT SPACE DUP ID. SPACE
	DUP ?IMMEDIATE IF ." IMMEDIATE " THEN
	>DFA BEGIN 2DUP
        > WHILE DUP @ CASE
		' LIT OF 4 + DUP @ . ENDOF
		' LITSTRING OF [ CHAR S ] LITERAL EMIT '"' EMIT SPACE
			4 + DUP @ SWAP 4 + SWAP 2DUP TELL '"' EMIT SPACE + ALIGNED 4 -
		ENDOF
		' 0BRANCH OF ." 0BRANCH ( " 4 + DUP @ . ." ) " ENDOF
		' BRANCH OF ." BRANCH ( " 4 + DUP @ . ." ) " ENDOF
		' ' OF [ CHAR ' ] LITERAL EMIT SPACE 4 + DUP @ CFA> ID. SPACE ENDOF
                ' (;CODE) OF ." ;CODE " 4 +
		PUSH-SEE-NATIVE-BASE
		'(' EMIT SPACE DUP PRINT-PRETTY-DFA-OFFSET ')' EMIT SPACE
                SEE-NATIVE-DUMP-CELLS
		POP-SEE-NATIVE-BASE
                ." (END-CODE)"
                ENDOF
		' EXIT OF 2DUP 4 + <> IF ." EXIT " THEN ENDOF
		DUP CFA> ID. SPACE
	ENDCASE 4 + REPEAT
	= IF ';' EMIT THEN CR
;
HIDE ?NATIVE
HIDE SEE-NATIVE
HIDE SEE-NATIVE-DUMP-CELLS
HIDE POP-SEE-NATIVE-BASE
HIDE PUSH-SEE-NATIVE-BASE
HIDE PRINT-PRETTY-CODEWORD
HIDE PRINT-PRETTY-DFA-OFFSET

: :NONAME 0 0 CREATE HERE @ DOCOL , ] ;

: BINARY ( -- ) 2 BASE ! ;
: OCTAL ( -- ) 8 BASE ! ;
: 2# BASE @ 2 BASE ! WORD NUMBER DROP SWAP BASE ! ;
: 8# BASE @ 8 BASE ! WORD NUMBER DROP SWAP BASE ! ;
: # ( b -- n ) BASE @ SWAP BASE ! WORD NUMBER DROP SWAP BASE ! ;
: UNUSED ( -- n ) PAD HERE @ - 4/ ;
: WELCOME
	S" TEST-MODE" FIND NOT IF
		." JONESFORTH VERSION " VERSION . CR
		UNUSED . ." CELLS REMAINING" CR
		." OK " CR
	THEN
;
WELCOME
HIDE WELCOME