base_fth = [[ : HEX 16 BASE ! ; : DEC 10 BASE ! ; : OCT 8 BASE ! ; : BIN 2 BASE ! ; : C! SWAP 255 AND SWAP ! ; : C@ @ 255 AND ; : C, HERE @ C! 1 HERE +! ; : LITERAL IMMEDIATE COMP' LIT , , ; : CHAR BL WORD 1+ C@ ; : '"' [ CHAR " ] LITERAL ; : '[' [ CHAR [ ] LITERAL ; : ']' [ CHAR ] ] LITERAL ; : '(' [ CHAR ( ] LITERAL ; : ')' [ CHAR ) ] LITERAL ; : ':' [ CHAR : ] LITERAL ; : ';' [ CHAR ; ] LITERAL ; : '0' [ CHAR 0 ] LITERAL ; : 'A' [ CHAR A ] LITERAL ; : '-' [ CHAR - ] LITERAL ; : '.' [ CHAR . ] LITERAL ; : CR 10 EMIT ; : SPACE 32 EMIT ; : ' BL WORD FIND >CFA ; : [COMPILE] IMMEDIATE ' , ; : ['] IMMEDIATE ' [COMPILE] LITERAL ; : LIT, ['] LIT , , ; : / /MOD SWAP DROP ; : MOD /MOD DROP ; : U/ UM/MOD SWAP DROP ; : UMOD UM/MOD DROP ; : NOT 0= ; : RECURSE IMMEDIATE LATEST @ >CFA , ; : IF IMMEDIATE ['] 0BRANCH , HERE @ 0 , ; : THEN IMMEDIATE DUP HERE @ SWAP - SWAP ! ; : ELSE IMMEDIATE ['] BRANCH , HERE @ 0 , SWAP DUP HERE @ SWAP - SWAP ! ; : ?HIDDEN 1+ C@ F_HIDDEN AND ; : ?IMMEDIATE 1+ C@ F_IMMED AND ; : EXECUTE-COMPILING STATE @ IF EXECUTE EXIT THEN ] EXECUTE [ ; : POSTPONE IMMEDIATE BL WORD FIND DUP ?IMMEDIATE SWAP >CFA LIT, IF ['] EXECUTE-COMPILING ELSE ['] , THEN , ; : BEGIN IMMEDIATE HERE @ ; : UNTIL IMMEDIATE POSTPONE 0BRANCH HERE @ - , ; : AGAIN IMMEDIATE POSTPONE BRANCH HERE @ - , ; : WHILE IMMEDIATE POSTPONE 0BRANCH HERE @ 0 , ; : REPEAT IMMEDIATE POSTPONE BRANCH SWAP HERE @ - , DUP HERE @ SWAP - SWAP ! ; : UNLESS IMMEDIATE POSTPONE NOT POSTPONE IF ; : ( IMMEDIATE 1 BEGIN KEY DUP '(' = IF DROP 1+ ELSE ')' = IF 1- THEN THEN DUP 0= UNTIL DROP ; : NIP ( x y -- y ) SWAP DROP ; : TUCK ( x y -- y x y ) SWAP OVER ; : PICK ( xn ... x1 x0 n -- xn ... x1 x0 xn ) 1+ 1 CELLS * DSP@ + @ ; ( Print many of a character ) : MANY ( n c -- ) SWAP BEGIN DUP 0> WHILE OVER EMIT 1- REPEAT 2DROP ; : SPACES ( n -- ) BL MANY ; : ZEROS ( n -- ) '0' MANY ; : U. ( u -- ) BASE @ UM/MOD ( base rem quot ) ?DUP IF RECURSE THEN DUP 10 < IF '0' ELSE 10 - 'A' THEN + EMIT ; ( Get number of chars in an unsigend number ) : UWIDTH ( u -- width ) BASE @ U/ ( rem quot) ?DUP IF ( if quot <> 0 ) RECURSE 1+ ELSE 1 THEN ; ( Get number of chars in an unsigend number ) : SWIDTH ( u -- width ) DUP 0< IF NEGATE THEN BASE @ / ( rem quot) ?DUP IF ( if quot <> 0 ) RECURSE 1+ ELSE 1 THEN ; ( Left pad number ) : U.R ( u width -- ) SWAP DUP UWIDTH ROT SWAP - SPACES U. ; ( Zero pad number ) : U.0R ( u width -- ) SWAP DUP UWIDTH ROT SWAP - ZEROS U. ; ( Print left padded signed number ) : .R SWAP DUP 0< IF NEGATE 1 SWAP ROT 1- ELSE 0 SWAP ROT THEN SWAP DUP SWIDTH ROT SWAP - SPACES SWAP IF '-' EMIT THEN U. ; ( Print zero padded signed number ) : .0R SWAP DUP 0< IF NEGATE 1 SWAP ROT 1- ELSE 0 SWAP ROT THEN SWAP DUP SWIDTH ROT SWAP - ZEROS SWAP IF '-' EMIT THEN U. ; : . 0 .R SPACE ; : U. U. SPACE ; : .S ( Print the stack ) DSP@ S0 @ BEGIN 2DUP < WHILE 1- DUP @ . SPACE REPEAT 2DROP CR ; ( Print number at address ) : ? ( addr -- ) @ . ; : WITHIN -ROT OVER <= IF > IF TRUE ELSE FALSE THEN ELSE 2DROP FALSE THEN ; ( Returns depth of stack ) : DEPTH ( -- n ) S0 @ DSP@ - 1- ; : S" IMMEDIATE STATE @ IF POSTPONE LITSTRING HERE @ 0 , BEGIN KEY DUP '"' <> WHILE C, REPEAT DROP DUP HERE @ SWAP - 1- SWAP ! ELSE HERE @ BEGIN KEY DUP '"' <> WHILE OVER C! 1+ REPEAT DROP HERE @ - HERE @ SWAP THEN ; : ." IMMEDIATE STATE @ IF POSTPONE S" POSTPONE TELL ELSE BEGIN KEY DUP '"' = IF DROP EXIT THEN EMIT AGAIN THEN ; : DOES> STATE @ IF POSTPONE (DOES>) ELSE HERE @ ( HERE ) LATEST @ >CFA ( HERE CFA ) DUP [ ' DODOES @ ] LITERAL SWAP ! ( Write CW of DODOES to CFA ) 1+ ! ( Write HERE to >DOES ) LATEST @ HIDDEN ] THEN ; IMMEDIATE : VARIABLE CREATE 0 , ; : CONSTANT CREATE , DOES> @ ; : VALUE ( n -- ) CREATE , DOES> ( -- n ) @ ; : TO ( n "name" -- ) ' >BODY ! ; : +TO ( n "name" -- ) ' >BODY +! ; 0 VALUE I : SETI [ ' I >BODY ] LITERAL ! ; : DO IMMEDIATE ( C: -- HERE ) ( LIMIT I -- ) SETI R> ( r: -- LIMIT ) HERE @ ( C: -- HERE ) ; : (LOOP) I 1+ DUP SETI R@ > 0BRANCH ; : (UNLOOP) >R DROP ; : LOOP IMMEDIATE POSTPONE (LOOP) HERE @ - , POSTPONE (UNLOOP) ; : ID. 1+ ( Skip link pointer ) DUP C@ ( entry flags ) F_LENMASK AND ( entry len) BEGIN DUP 0> ( entry len len>0? ) WHILE SWAP 1+ ( len entry+1 ) DUP C@ EMIT SWAP 1- ( entry+1 len-1 ) REPEAT 2DROP ( entry len -- ) ; : WORDS LATEST @ BEGIN ?DUP WHILE DUP ?HIDDEN IF ." (H)" THEN DUP ?IMMEDIATE IF ." (I)" THEN DUP ID. SPACE @ REPEAT CR ; : HIDE BL WORD FIND HIDDEN ; : FORGET BL WORD FIND DUP @ LATEST ! HERE ! ; : DUMP ( addr len -- ) ( Save BASE ) BASE @ -ROT BEGIN ?DUP WHILE HEX OVER 8 U.0R 4 SPACES ( Print hex ) 2DUP 1- 15 AND 1+ BEGIN ?DUP WHILE SWAP DUP 5 PICK DEC 10 = IF @ 0 DEC ELSE C@ 2 HEX THEN .0R SPACE 1+ SWAP 1- REPEAT DROP 3 SPACES ( Print ascii ) 2DUP 1- 15 AND 1+ BEGIN ?DUP WHILE SWAP DUP C@ DUP 32 128 WITHIN IF 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 POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP ; : ENDOF IMMEDIATE POSTPONE ELSE ; : ENDCASE IMMEDIATE POSTPONE DROP ( Compile THEN's for each ELSE ) BEGIN ?DUP WHILE POSTPONE THEN REPEAT ; : CFA> LATEST @ BEGIN ?DUP WHILE 2DUP SWAP < IF NIP EXIT THEN @ REPEAT DROP 0 ; : SEE BL WORD FIND HERE @ LATEST @ BEGIN 2 PICK OVER <> WHILE NIP DUP @ REPEAT DROP SWAP ':' EMIT SPACE DUP ID. CR DUP ?IMMEDIATE IF ." IMMEDIATE " THEN >DFA BEGIN 2DUP > WHILE DUP @ CASE ['] LIT OF CELL+ DUP @ . CR ENDOF ['] LITSTRING OF [ CHAR S ] LITERAL EMIT '"' EMIT SPACE CELL+ COUNT 2DUP TELL '"' EMIT CR + CELL- ENDOF ['] 0BRANCH OF ." 0BRANCH(" CELL+ DUP @ 0 .R ." ) " CR ENDOF ['] BRANCH OF ." BRANCH(" CELL+ DUP @ 0 .R ." ) " CR ENDOF ['] ' OF [ CHAR ' ] LITERAL EMIT SPACE CELL+ @ CFA> ID. CR ENDOF ['] EXIT OF 2DUP CELL+ <> IF ." EXIT " CR THEN ENDOF DUP CFA> ID. CR ENDCASE CELL+ REPEAT ';' EMIT CR 2DROP ; : :NONAME HERE @ LATEST @ , LATEST ! 0 , HERE @ [ ' DOCOL @ ] LITERAL , 0 , ] ; ( Colors ) DEC : ESC[ 27 EMIT '[' EMIT ; 0 CONSTANT RESET 1 CONSTANT BRIGHT 2 CONSTANT DIM 4 CONSTANT UNSERSCORE 5 CONSTANT BLINK 7 CONSTANT REVERSE 8 CONSTANT HIDDEN : FG> 30 + ; : BG> 40 + ; 0 CONSTANT ESC[ 0 .R ';' EMIT 0 .R ." m" ; : ESC[ 0 .R ';' EMIT ." ;m" ; ]]