From: Tim Vaughan Date: Sun, 29 May 2016 00:36:11 +0000 (+1200) Subject: Divided up library code. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=9da6dc7c0252fdc18aca602928feab518737cc8f;p=forth.jl.git Divided up library code. --- diff --git a/src/forth.jl b/src/forth.jl index 01c8c0d..c8cd131 100644 --- a/src/forth.jl +++ b/src/forth.jl @@ -785,22 +785,7 @@ TYPE_CFA = defPrimWord("TYPE", () -> begin return NEXT end) -# Outer interpreter - -COMMA_CFA = defPrimWord(",", () -> begin - mem[mem[H]] = popPS() - mem[H] += 1 - - return NEXT -end) - -BTICK_CFA = defWord("[']", - [FROMR_CFA, DUP_CFA, INCR_CFA, TOR_CFA, FETCH_CFA, EXIT_CFA]) - -EXECUTE_CFA = defPrimWord("EXECUTE", () -> begin - reg.W = popPS() - return mem[reg.W] -end) +# Interpreter/Compiler-specific I/O TIB_CFA = defConst("TIB", TIB) NUMTIB, NUMTIB_CFA = defNewVar("#TIB", 0) @@ -844,106 +829,19 @@ WORD_CFA = defPrimWord("WORD", () -> begin return NEXT end) -PARSE_CFA = defPrimWord("PARSE", () -> begin - delim = popPS() - - # Chew up initial occurrences of delim - addr = mem[H] - - # Start reading input stream - count = 0 - while (mem[TOIN] begin - println("\nBye!") - return 0 -end) +# Compilation STATE, STATE_CFA = defNewVar("STATE", 0) -INTERPRET_CFA = defWord("INTERPRET", - [LIT_CFA, 32, WORD_CFA, # Read next space-delimited word - - DUP_CFA, FETCH_CFA, ZE_CFA, ZBRANCH_CFA, 3, - DROP_CFA, EXIT_CFA, # Exit if TIB is exhausted - - STATE_CFA, FETCH_CFA, ZBRANCH_CFA, 24, - # Compiling - FIND_CFA, QDUP_CFA, ZBRANCH_CFA, 13, - - # Found word. - LIT_CFA, -1, EQ_CFA, INVERT_CFA, ZBRANCH_CFA, 4, - - # Immediate: Execute! - EXECUTE_CFA, BRANCH_CFA, -26, - - # Not immediate: Compile! - COMMA_CFA, BRANCH_CFA, -29, - - # No word found, parse number - NUMBER_CFA, BTICK_CFA, LIT_CFA, COMMA_CFA, COMMA_CFA, BRANCH_CFA, -36, - - # Interpreting - FIND_CFA, QDUP_CFA, ZBRANCH_CFA, 5, - - # Found word. Execute! - DROP_CFA, EXECUTE_CFA, BRANCH_CFA, -44, - - # No word found, parse number and leave on stack - NUMBER_CFA, BRANCH_CFA, -47, - EXIT_CFA]) - -PROMPT_CFA = defPrimWord("PROMPT", () -> begin - if (mem[STATE] == 0 && currentSource() == STDIN) - println(" ok") - end - - return NEXT -end) - -QUIT_CFA = defWord("QUIT", - [LIT_CFA, 0, STATE_CFA, STORE_CFA, - LIT_CFA, 0, NUMTIB_CFA, STORE_CFA, - RSP0_CFA, RSPSTORE_CFA, - QUERY_CFA, - INTERPRET_CFA, PROMPT_CFA, - BRANCH_CFA,-4]) - -ABORT_CFA = defWord("ABORT", - [PSP0_CFA, PSPSTORE_CFA, QUIT_CFA]) - -INCLUDE_CFA = defPrimWord("INCLUDE", () -> begin - pushPS(32) - callPrim(mem[WORD_CFA]) - wordAddr = popPS()+1 - wordLen = mem[wordAddr-1] - word = getString(wordAddr, wordLen) - - push!(sources, open(word, "r")) - - # Clear input buffer - mem[NUMTIB] = 0 +COMMA_CFA = defPrimWord(",", () -> begin + mem[mem[H]] = popPS() + mem[H] += 1 return NEXT end) -# Compilation +BTICK_CFA = defWord("[']", + [FROMR_CFA, DUP_CFA, INCR_CFA, TOR_CFA, FETCH_CFA, EXIT_CFA]) HERE_CFA = defWord("HERE", [H_CFA, FETCH_CFA, EXIT_CFA]) @@ -1027,6 +925,86 @@ IMMEDIATE_CFA = defPrimWord("IMMEDIATE", () -> begin return NEXT end, flags=F_IMMED) +# Outer Interpreter + +EXECUTE_CFA = defPrimWord("EXECUTE", () -> begin + reg.W = popPS() + return mem[reg.W] +end) + +INTERPRET_CFA = defWord("INTERPRET", + [LIT_CFA, 32, WORD_CFA, # Read next space-delimited word + + DUP_CFA, FETCH_CFA, ZE_CFA, ZBRANCH_CFA, 3, + DROP_CFA, EXIT_CFA, # Exit if TIB is exhausted + + STATE_CFA, FETCH_CFA, ZBRANCH_CFA, 24, + # Compiling + FIND_CFA, QDUP_CFA, ZBRANCH_CFA, 13, + + # Found word. + LIT_CFA, -1, EQ_CFA, INVERT_CFA, ZBRANCH_CFA, 4, + + # Immediate: Execute! + EXECUTE_CFA, BRANCH_CFA, -26, + + # Not immediate: Compile! + COMMA_CFA, BRANCH_CFA, -29, + + # No word found, parse number + NUMBER_CFA, BTICK_CFA, LIT_CFA, COMMA_CFA, COMMA_CFA, BRANCH_CFA, -36, + + # Interpreting + FIND_CFA, QDUP_CFA, ZBRANCH_CFA, 5, + + # Found word. Execute! + DROP_CFA, EXECUTE_CFA, BRANCH_CFA, -44, + + # No word found, parse number and leave on stack + NUMBER_CFA, BRANCH_CFA, -47, + EXIT_CFA]) + +PROMPT_CFA = defPrimWord("PROMPT", () -> begin + if (mem[STATE] == 0 && currentSource() == STDIN) + println(" ok") + end + + return NEXT +end) + +QUIT_CFA = defWord("QUIT", + [LIT_CFA, 0, STATE_CFA, STORE_CFA, + LIT_CFA, 0, NUMTIB_CFA, STORE_CFA, + RSP0_CFA, RSPSTORE_CFA, + QUERY_CFA, + INTERPRET_CFA, PROMPT_CFA, + BRANCH_CFA,-4]) + +ABORT_CFA = defWord("ABORT", + [PSP0_CFA, PSPSTORE_CFA, QUIT_CFA]) + +BYE_CFA = defPrimWord("BYE", () -> begin + println("\nBye!") + return 0 +end) + +# File I/O + +INCLUDE_CFA = defPrimWord("INCLUDE", () -> begin + pushPS(32) + callPrim(mem[WORD_CFA]) + wordAddr = popPS()+1 + wordLen = mem[wordAddr-1] + word = getString(wordAddr, wordLen) + + push!(sources, open(word, "r")) + + # Clear input buffer + mem[NUMTIB] = 0 + + return NEXT +end) + #### VM loop #### diff --git a/src/lib.4th b/src/lib.4th index 8da2fb1..e6d5fa1 100644 --- a/src/lib.4th +++ b/src/lib.4th @@ -2,752 +2,13 @@ #TIB @ >IN ! ; \ We can now comment! -\ BASIC DEFINITIONS ---------------------------------------------------------------------- - -: / /MOD SWAP DROP ; -: MOD /MOD DROP ; -: */ -ROT * SWAP / ; - -: NEGATE 0 SWAP - ; - -: TRUE -1 ; -: FALSE 0 ; -: NOT 0= ; - -\ Translate a number of cells into memory units -\ (in our case 1 cell = 1 memory unit) -: CELLS ; - -\ Since the smallest unit of memory in our system is 64 bits and since strings -\ are stored as arrays of 64 bit integers, the character store/fetch words are -\ just aliases of the standard store/fetch words. -: C! ! ; -: C@ @ ; -: C, , ; - -: DEPTH PSP@ PSP0 - ; - -: '\n' 10 ; -: BL 32 ; - -: LITERAL IMMEDIATE ['] LIT , , ; - -: ' BL WORD FIND DROP ; - -: CHAR BL WORD 1+ @ ; -: [CHAR] IMMEDIATE - CHAR - ['] LIT , , -; - -: CR '\n' emit ; -: SPACE BL emit ; - -: [COMPILE] IMMEDIATE - BL WORD \ get the next word - FIND DROP \ find it in the dictionary - , \ and compile that -; - -: RECURSE IMMEDIATE - LATEST @ \ LATEST points to the word being compiled at the moment - >CFA \ get the codeword - , \ compile it -; - -\ CONTROL STRUCTURES ---------------------------------------------------------------------- - -: IF IMMEDIATE - ['] 0BRANCH , \ compile 0BRANCH - HERE \ save location of the offset on the stack - 0 , \ compile a dummy offset -; - -: THEN IMMEDIATE - DUP - HERE SWAP - \ calculate the offset from the address saved on the stack - SWAP ! \ store the offset in the back-filled location -; - -: ELSE IMMEDIATE - ['] BRANCH , \ definite branch to just over the false-part - HERE \ save location of the offset on the stack - 0 , \ compile a dummy offset - SWAP \ now back-fill the original (IF) offset - DUP \ same as for THEN word above - HERE SWAP - - SWAP ! -; - -: BEGIN IMMEDIATE - HERE \ save location on the stack -; - -: UNTIL IMMEDIATE - ['] 0BRANCH , \ compile 0BRANCH - HERE - \ calculate the offset from the address saved on the stack - , \ compile the offset here -; - -: AGAIN IMMEDIATE - ['] BRANCH , \ compile BRANCH - HERE - \ calculate the offset back - , \ compile the offset here -; - -: WHILE IMMEDIATE - ['] 0BRANCH , \ compile 0BRANCH - HERE \ save location of the offset2 on the stack - 0 , \ compile a dummy offset2 -; - -: REPEAT IMMEDIATE - ['] BRANCH , \ compile BRANCH - SWAP \ get the original offset (from BEGIN) - HERE - , \ and compile it after BRANCH - DUP - HERE SWAP - \ calculate the offset2 - SWAP ! \ and back-fill it in the original location -; - -: UNLESS IMMEDIATE - ['] NOT , \ compile NOT (to reverse the test) - [COMPILE] IF \ continue by calling the normal IF -; - -: DO IMMEDIATE - ['] LIT , -1 , [COMPILE] IF - ['] >R , ['] >R , - ['] LIT , HERE 0 , ['] >R , - HERE -; - -: ?DO IMMEDIATE - ['] 2DUP , ['] - , [COMPILE] IF - ['] >R , ['] >R , - ['] LIT , HERE 0 , ['] >R , - HERE -; - -: I RSP@ 3 - @ ; - -: J RSP@ 6 - @ ; - -: ?LEAVE IMMEDIATE - ['] 0BRANCH , 13 , - ['] R> , ['] RDROP , ['] RDROP , - ['] LIT , HERE 7 + , ['] DUP , ['] -ROT , ['] - , ['] SWAP , ['] ! , - ['] BRANCH , - 0 , -; - -: LEAVE IMMEDIATE - ['] LIT , -1 , - [COMPILE] ?LEAVE -; - -: +LOOP IMMEDIATE - - ['] DUP , \ Store copy of increment - - ['] R> , ['] SWAP , ['] R> , ['] SWAP , ['] R> , ['] SWAP , ['] + , ['] 2DUP , ['] - , - ['] SWAP , ['] >R , ['] SWAP , ['] >R , ['] SWAP , ['] >R , - - \ Condition differently depending on sign of increment - ['] SWAP , ['] 0>= , [COMPILE] IF - ['] 0<= , - [COMPILE] ELSE - ['] 0> , - [COMPILE] THEN - - \ Branch back to begining of loop kernel - ['] 0BRANCH , HERE - , - - \ Clean up - ['] RDROP , ['] RDROP , ['] RDROP , - - \ Record address of loop end for any LEAVEs to use - HERE SWAP ! - - [COMPILE] ELSE - ['] 2DROP , \ Clean up if loop was entirely skipped (?DO) - [COMPILE] THEN -; - -: LOOP IMMEDIATE - ['] LIT , 1 , - [COMPILE] +LOOP -; - - -\ CASE ------------------------------------------------------------------------ - -: CASE IMMEDIATE - 0 \ push 0 to mark the bottom of the stack -; - -: OF IMMEDIATE - ['] OVER , \ compile OVER - ['] = , \ compile = - [COMPILE] IF \ compile IF - ['] DROP , \ compile DROP -; - -: ENDOF IMMEDIATE - [COMPILE] ELSE \ ENDOF is the same as ELSE -; - -: ENDCASE IMMEDIATE - ['] DROP , \ compile DROP - - \ keep compiling THEN until we get to our zero marker - BEGIN - ?DUP - WHILE - [COMPILE] THEN - REPEAT -; - - -\ COMMENTS ---------------------------------------------------------------------- - -: ( IMMEDIATE - 1 \ allowed nested parens by keeping track of depth - BEGIN - >IN @ #TIB @ >= IF \ End of TIB? - QUERY \ Get next line - THEN - - TIB >IN @ + @ 1 >IN +! - DUP [CHAR] ( = IF \ open paren? - DROP \ drop the open paren - 1+ \ depth increases - ELSE - [CHAR] ) = IF \ close paren? - 1- \ depth decreases - THEN - THEN - DUP 0= UNTIL \ continue until we reach matching close paren, depth 0 - DROP \ drop the depth counter -; - -( Some more complicated stack examples, showing the stack notation. ) -: NIP ( x y -- y ) SWAP DROP ; -: TUCK ( x y -- y x y ) DUP -ROT ; -: PICK ( x_u ... x_1 x_0 u -- x_u ... x_1 x_0 x_u ) - 1+ ( add one because of 'u' on the stack ) - PSP@ SWAP - ( add to the stack pointer ) - @ ( and fetch ) -; -: ROLL ( x_u x_u-1... x_0 u -- x_u-1 ... x_0 x_u ) - 1+ DUP PICK SWAP ( x_u x_u-1 ... x_0 x_u u+1 ) - PSP@ 1- SWAP - PSP@ 2- SWAP - DO - i 1+ @ i ! - LOOP - SWAP DROP -; - -( With the looping constructs, we can now write SPACES, which writes n spaces to stdout. ) -: SPACES ( n -- ) - DUP 0> IF - 0 DO SPACE LOOP - ELSE - DROP - THEN -; - -( Standard words for manipulating BASE. ) -: DECIMAL ( -- ) 10 BASE ! ; -: HEX ( -- ) 16 BASE ! ; - -( Compute absolute value. ) -: ABS ( n -- |n| ) - dup 0< if - negate - then -; - -: MAX ( n m -- max ) - 2dup - 0< if - swap drop - else - drop - then -; - -: MIN ( n m -- max ) - 2dup - 0> if - swap drop - else - drop - then -; - -( PRINTING NUMBERS ---------------------------------------------------------------------- ) - -( This is the underlying recursive definition of U. ) -: U. ( u -- ) - BASE @ /MOD ( width rem quot ) - ?DUP IF ( if quotient <> 0 then ) - RECURSE ( print the quotient ) - THEN - - ( print the remainder ) - DUP 10 < IF - [CHAR] 0 ( decimal digits 0..9 ) - ELSE - 10 - ( hex and beyond digits A..Z ) - [CHAR] A - THEN - + - EMIT -; - -( This word returns the width (in characters) of an unsigned number in the current base ) -: UWIDTH ( u -- width ) - BASE @ / ( rem quot ) - ?DUP IF ( if quotient <> 0 then ) - RECURSE 1+ ( return 1+recursive call ) - ELSE - 1 ( return 1 ) - THEN -; - -: U.R ( u width -- ) - SWAP ( width u ) - DUP ( width u u ) - UWIDTH ( width u uwidth ) - ROT ( u uwidth width ) - SWAP - ( u width-uwidth ) - ( At this point if the requested width is narrower, we'll have a negative number on the stack. - Otherwise the number on the stack is the number of spaces to print. But SPACES won't print - a negative number of spaces anyway, so it's now safe to call SPACES ... ) - SPACES - ( ... and then call the underlying implementation of U. ) - U. -; - -: .R ( n width -- ) - SWAP ( width n ) - DUP 0< IF - NEGATE ( width u ) - 1 ( save a flag to remember that it was negative | width n 1 ) - -ROT ( 1 width u ) - SWAP ( 1 u width ) - 1- ( 1 u width-1 ) - ELSE - 0 ( width u 0 ) - -ROT ( 0 width u ) - SWAP ( 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 ( was it negative? print the - character ) - [CHAR] - EMIT - THEN - - U. -; - -: . 0 .R SPACE ; - -: .S ( -- ) - [CHAR] < EMIT DEPTH U. [CHAR] > EMIT SPACE - PSP0 1+ - BEGIN - DUP PSP@ 2 - <= - WHILE - DUP @ . - 1+ - REPEAT - DROP -; - -: U. U. SPACE ; - -( ? fetches the integer at an address and prints it. ) -: ? ( addr -- ) @ . ; - -( c a b WITHIN returns true if a <= c and c < b ) -: WITHIN - -ROT ( b c a ) - OVER ( b c a c ) - <= IF - > IF ( b c -- ) - TRUE - ELSE - FALSE - THEN - ELSE - 2DROP ( b c -- ) - FALSE - THEN -; - - -( STRINGS ---------------------------------------------------------------------- ) - - -( Block copy, however, is important and novel: ) -: CMOVE ( src dest length -- ) - - DUP 0<= IF - EXIT - THEN - - -ROT OVER - ( length src (dest-src) ) - -ROT DUP ROT + SWAP ( (dest-src) (src+length) src ) - - DO - I @ ( (dest-src) i@ ) - OVER I + ( (dest-src) i@ (dest-src+i) ) - ! ( (dest-src) ) - LOOP - - DROP -; - -( C, appends a byte to the current compiled word. ) -: C, - HERE C! - 1 H +! -; - -: S" IMMEDIATE ( -- addr len ) - STATE @ IF ( compiling? ) - ['] LITSTRING , ( compile LITSTRING ) - HERE ( save the address of the length word on the stack ) - 0 , ( dummy length - we don't know what it is yet ) - - BEGIN - >IN @ #TIB @ >= IF \ End of TIB? - QUERY \ Get next line - THEN - - TIB >IN @ + @ 1 >IN +! \ Get char from TIB - - DUP [CHAR] " <> - WHILE - C, ( copy character ) - REPEAT - DROP ( drop the double quote character at the end ) - DUP ( get the saved address of the length word ) - HERE SWAP - ( calculate the length ) - 1- ( subtract 1 (because we measured from the start of the length word) ) - SWAP ! ( and back-fill the length location ) - ELSE ( immediate mode ) - HERE ( get the start address of the temporary space ) - - BEGIN - >IN @ #TIB @ >= IF \ End of TIB? - QUERY \ Get next line - THEN - - TIB >IN @ + @ 1 >IN +! \ Get char from TIB - - DUP [CHAR] " <> - WHILE - OVER C! ( save next character ) - 1+ ( increment address ) - REPEAT - DROP ( drop the final " character ) - HERE - ( calculate the length ) - HERE ( push the start address ) - SWAP ( addr len ) - THEN -; - -: ." IMMEDIATE ( -- ) - [COMPILE] S" ( read the string, and compile LITSTRING, etc. ) - ['] TYPE , ( compile the final TYPE ) -; - -: .( - BEGIN - >IN @ #TIB @ >= IF \ End of TIB? - QUERY \ Get next line - THEN - - TIB >IN @ + @ 1 >IN +! \ Get char from TIB - - DUP [CHAR] ) = IF - DROP ( drop the double quote character ) - EXIT ( return from this function ) - THEN - EMIT - AGAIN -; - -( Converts address of counted string into address of - start of string and length of string. ) -: COUNT ( addr1 -- addr2 n ) - DUP 1+ SWAP @ ; - - -( CONSTANTS AND VARIABLES ------------------------------------------------------ ) - -: CONSTANT - CREATE , -DOES> @ -; - -: ALLOT ( n -- ) - H +! ( adds n to H, after this the old value of H is still on the stack ) -; - -: VARIABLE - CREATE - 1 CELLS ALLOT ( allocate 1 cell of memory, push the pointer to this memory ) -; - -: VALUE ( n -- ) - CREATE , -DOES> @ -; - -: TO IMMEDIATE ( n -- ) - BL WORD ( get the name of the value ) - FIND DROP ( look it up in the dictionary ) - >BODY ( get a pointer to the first data field (the 'LIT') ) - STATE @ IF ( compiling? ) - ['] LIT , ( compile LIT ) - , ( compile the address of the value ) - ['] ! , ( compile ! ) - ELSE ( immediate mode ) - ! ( update it straightaway ) - THEN -; - -( x +TO VAL adds x to VAL ) -: +TO IMMEDIATE - BL WORD ( get the name of the value ) - FIND DROP ( look it up in the dictionary ) - >BODY ( get a pointer to the first data field (the 'LIT') ) - STATE @ IF ( compiling? ) - ['] LIT , ( compile LIT ) - , ( compile the address of the value ) - ['] +! , ( compile +! ) - ELSE ( immediate mode ) - +! ( update it straightaway ) - THEN -; - -( Fill u ints, starting at a, with the value b ) -: FILL ( a u b -- ) - -ROT OVER + SWAP ?DO - DUP I ! - LOOP - DROP -; - -: ERASE ( a u -- ) - 0 FILL -; - -( PRINTING THE DICTIONARY ------------------------------------------------------ ) - -: .NAME - DUP @ ( get the flags/length byte ) - F_LENMASK AND ( mask out the flags - just want the length ) - - BEGIN - DUP 0> ( length > 0? ) - WHILE - SWAP 1+ ( addr len -- len addr+1 ) - DUP @ ( len addr -- len addr char | get the next character) - DUP 32 >= OVER 127 <= AND IF - EMIT ( len addr char -- len addr | and print it) - ELSE - BASE @ SWAP HEX - ." \x" 0 .R - BASE ! - THEN - SWAP 1- ( len addr -- addr len-1 | subtract one from length ) - REPEAT - 2DROP ( len addr -- ) -; - -: ?HIDDEN - 1+ ( skip over the link pointer ) - @ ( get the flags/length byte ) - F_HIDDEN AND ( mask the F_HIDDEN flag and return it (as a truth value) ) -; -: ?IMMEDIATE - 1+ ( skip over the link pointer ) - @ ( get the flags/length byte ) - F_IMMED AND ( mask the F_IMMED flag and return it (as a truth value) ) -; - -: WORDS - CR - LATEST @ ( start at LATEST dictionary entry ) - BEGIN - ?DUP ( while link pointer is not null ) - WHILE - DUP ?HIDDEN NOT IF ( ignore hidden words ) - DUP 1+ .NAME ( but if not hidden, print the word ) - SPACE - THEN - @ ( dereference the link pointer - go to previous word ) - REPEAT - CR -; - -( DUMP ------------------------------------------------------------------------ ) - -\ TODO! - - -( DECOMPILER ------------------------------------------------------------------ ) - -: >NAME - BEGIN - 1- DUP @ - NFA_MARK AND - NFA_MARK = UNTIL -; - -: >LFA >NAME 1- ; - -: SEE - BL WORD FIND ( find the dictionary entry to decompile ) - - CR - - 0= IF - ." Word '" COUNT TYPE ." ' not found in dictionary." - EXIT - THEN - - >LFA - - ( Now we search again, looking for the next word in the dictionary. This gives us - the length of the word that we will be decompiling. (Well, mostly it does). ) - HERE ( address of the end of the last compiled word ) - LATEST @ ( word last curr ) - BEGIN - 2 PICK ( word last curr word ) - OVER ( word last curr word curr ) - <> ( word last curr word<>curr? ) - WHILE ( word last curr ) - NIP ( word curr ) - DUP @ ( word curr prev (which becomes: word last curr) ) - REPEAT - - DROP ( at this point, the stack is: start-of-word end-of-word ) - SWAP ( end-of-word start-of-word ) - - DUP >CFA @ CASE - DOCOL OF - \ Colon definition - [CHAR] : EMIT SPACE DUP 1+ .NAME SPACE - DUP ?IMMEDIATE IF ." IMMEDIATE " THEN CR - ENDOF - DOVAR OF - \ Variable definition - ." Variable " DUP 1+ .NAME CR - 2DROP EXIT - ENDOF - DOCON OF - \ Constant definition - ." Constant " DUP 1+ .NAME CR - 2DROP EXIT - ENDOF - - \ Unknown codeword - ." Primitive or word with unrecognized codeword." CR - DROP 2DROP EXIT - ENDCASE - - 4 SPACES - - >CFA >BODY ( get the data address, ie. points after DOCOL | end-of-word start-of-data ) - - ( now we start decompiling until we hit the end of the word ) - BEGIN ( end start ) - 2DUP > - WHILE - DUP @ ( end start codeword ) - - CASE - ['] LIT OF ( is it LIT ? ) - 1+ DUP @ ( get next word which is the integer constant ) - . ( and print it ) - ENDOF - ['] LITSTRING OF ( is it LITSTRING ? ) - [CHAR] S EMIT [CHAR] " EMIT SPACE ( print S" ) - 1+ DUP @ ( get the length word ) - SWAP 1+ SWAP ( end start+1 length ) - 2DUP TYPE ( print the string ) - [CHAR] " EMIT SPACE ( finish the string with a final quote ) - + ( end start+1+len, aligned ) - 1- ( because we're about to add 4 below ) - ENDOF - ['] 0BRANCH OF ( is it 0BRANCH ? ) - ." 0BRANCH ( " - 1+ DUP @ ( print the offset ) - . - ." ) " - ENDOF - ['] BRANCH OF ( is it BRANCH ? ) - ." BRANCH ( " - 1+ DUP @ ( print the offset ) - . - ." ) " - ENDOF - ['] ['] OF ( is it ['] ? ) - ." ['] " - 1+ DUP @ ( get the next codeword ) - >NAME ( and force it to be printed as a dictionary entry ) - .NAME SPACE - ENDOF - ['] EXIT OF ( is it EXIT? ) - ( We expect the last word to be EXIT, and if it is then we don't print it - because EXIT is normally implied by ;. EXIT can also appear in the middle - of words, and then it needs to be printed. ) - 2DUP ( end start end start ) - 1+ ( end start end start+1 ) - <> IF ( end start | we're not at the end ) - ." EXIT " - THEN - ENDOF - ( default case: ) - DUP ( in the default case we always need to DUP before using ) - >NAME ( look up the codeword to get the dictionary entry ) - .NAME SPACE ( and print it ) - ENDCASE - - 1+ ( end start+1 ) - REPEAT - - [CHAR] ; EMIT CR - - 2DROP ( restore stack ) -; - - -( FORGET and HIDE ------------------------------------------------------------ ) - -: FORGET - BL WORD FIND >LFA ( find the word, gets the dictionary entry address ) - DUP @ LATEST ! ( set LATEST to point to the previous word ) - H ! ( and store H with the dictionary address ) -; - -: HIDE - BL WORD FIND DROP >NAME - DUP @ F_HIDDEN OR SWAP ! -; - -( MEMORY ------------------------------------------------------------------ ) - -: UNUSED ( -- cells ) - MEMSIZE HERE - ; +include lib_1_basic.4th +include lib_2_control.4th +include lib_3_comments.4th +include lib_4_printnum.4th +include lib_5_strings.4th +include lib_6_variables.4th +include lib_7_printwords.4th +include lib_8_decompiler.4th + +include lib_9_misc.4th diff --git a/src/lib_1_basic.4th b/src/lib_1_basic.4th new file mode 100644 index 0000000..1764723 --- /dev/null +++ b/src/lib_1_basic.4th @@ -0,0 +1,68 @@ +\ Basic definitions + +: / /MOD SWAP DROP ; +: MOD /MOD DROP ; +: */ -ROT * SWAP / ; + +: NEGATE \ ( x -- -x ) + 0 SWAP - ; + +: NIP \ ( x y -- y ) + SWAP DROP ; + +: TUCK \ ( x y -- y x y ) + DUP -ROT ; + +: PICK \ ( x_u ... x_1 x_0 u -- x_u ... x_1 x_0 x_u ) + 1+ PSP@ SWAP - @ ; + +: TRUE -1 ; +: FALSE 0 ; +: NOT 0= ; + +\ Standard words for manipulating BASE. +: DECIMAL 10 BASE ! ; +: HEX 16 BASE ! ; + + +\ Translate a number of cells into memory units +\ (in our case 1 cell = 1 memory unit) +: CELLS ; + +\ Since the smallest unit of memory in our system is 64 bits and since strings +\ are stored as arrays of 64 bit integers, the character store/fetch words are +\ just aliases of the standard store/fetch words. +: C! ! ; +: C@ @ ; +: C, , ; + +: DEPTH PSP@ PSP0 - ; + +: '\n' 10 ; +: BL 32 ; + +: LITERAL IMMEDIATE ['] LIT , , ; + +: ' BL WORD FIND DROP ; + +: CHAR BL WORD 1+ @ ; +: [CHAR] IMMEDIATE + CHAR + ['] LIT , , +; + +: CR '\n' emit ; +: SPACE BL emit ; + +: [COMPILE] IMMEDIATE + BL WORD \ get the next word + FIND DROP \ find it in the dictionary + , \ and compile that +; + +: RECURSE IMMEDIATE + LATEST @ \ LATEST points to the word being compiled at the moment + >CFA \ get the codeword + , \ compile it +; + diff --git a/src/lib_2_control.4th b/src/lib_2_control.4th new file mode 100644 index 0000000..464a9a4 --- /dev/null +++ b/src/lib_2_control.4th @@ -0,0 +1,152 @@ +\ Flow control + +: IF IMMEDIATE + ['] 0BRANCH , \ compile 0BRANCH + HERE \ save location of the offset on the stack + 0 , \ compile a dummy offset +; + +: THEN IMMEDIATE + DUP + HERE SWAP - \ calculate the offset from the address saved on the stack + SWAP ! \ store the offset in the back-filled location +; + +: ELSE IMMEDIATE + ['] BRANCH , \ definite branch to just over the false-part + HERE \ save location of the offset on the stack + 0 , \ compile a dummy offset + SWAP \ now back-fill the original (IF) offset + DUP \ same as for THEN word above + HERE SWAP - + SWAP ! +; + +: BEGIN IMMEDIATE + HERE \ save location on the stack +; + +: UNTIL IMMEDIATE + ['] 0BRANCH , \ compile 0BRANCH + HERE - \ calculate the offset from the address saved on the stack + , \ compile the offset here +; + +: AGAIN IMMEDIATE + ['] BRANCH , \ compile BRANCH + HERE - \ calculate the offset back + , \ compile the offset here +; + +: WHILE IMMEDIATE + ['] 0BRANCH , \ compile 0BRANCH + HERE \ save location of the offset2 on the stack + 0 , \ compile a dummy offset2 +; + +: REPEAT IMMEDIATE + ['] BRANCH , \ compile BRANCH + SWAP \ get the original offset (from BEGIN) + HERE - , \ and compile it after BRANCH + DUP + HERE SWAP - \ calculate the offset2 + SWAP ! \ and back-fill it in the original location +; + +: UNLESS IMMEDIATE + ['] NOT , \ compile NOT (to reverse the test) + [COMPILE] IF \ continue by calling the normal IF +; + +: DO IMMEDIATE + ['] LIT , -1 , [COMPILE] IF + ['] >R , ['] >R , + ['] LIT , HERE 0 , ['] >R , + HERE +; + +: ?DO IMMEDIATE + ['] 2DUP , ['] - , [COMPILE] IF + ['] >R , ['] >R , + ['] LIT , HERE 0 , ['] >R , + HERE +; + +: I RSP@ 3 - @ ; + +: J RSP@ 6 - @ ; + +: ?LEAVE IMMEDIATE + ['] 0BRANCH , 13 , + ['] R> , ['] RDROP , ['] RDROP , + ['] LIT , HERE 7 + , ['] DUP , ['] -ROT , ['] - , ['] SWAP , ['] ! , + ['] BRANCH , + 0 , +; + +: LEAVE IMMEDIATE + ['] LIT , -1 , + [COMPILE] ?LEAVE +; + +: +LOOP IMMEDIATE + + ['] DUP , \ Store copy of increment + + ['] R> , ['] SWAP , ['] R> , ['] SWAP , ['] R> , ['] SWAP , ['] + , ['] 2DUP , ['] - , + ['] SWAP , ['] >R , ['] SWAP , ['] >R , ['] SWAP , ['] >R , + + \ Condition differently depending on sign of increment + ['] SWAP , ['] 0>= , [COMPILE] IF + ['] 0<= , + [COMPILE] ELSE + ['] 0> , + [COMPILE] THEN + + \ Branch back to begining of loop kernel + ['] 0BRANCH , HERE - , + + \ Clean up + ['] RDROP , ['] RDROP , ['] RDROP , + + \ Record address of loop end for any LEAVEs to use + HERE SWAP ! + + [COMPILE] ELSE + ['] 2DROP , \ Clean up if loop was entirely skipped (?DO) + [COMPILE] THEN +; + +: LOOP IMMEDIATE + ['] LIT , 1 , + [COMPILE] +LOOP +; + + +\ CASE ------------------------------------------------------------------------ + +: CASE IMMEDIATE + 0 \ push 0 to mark the bottom of the stack +; + +: OF IMMEDIATE + ['] OVER , \ compile OVER + ['] = , \ compile = + [COMPILE] IF \ compile IF + ['] DROP , \ compile DROP +; + +: ENDOF IMMEDIATE + [COMPILE] ELSE \ ENDOF is the same as ELSE +; + +: ENDCASE IMMEDIATE + ['] DROP , \ compile DROP + + \ keep compiling THEN until we get to our zero marker + BEGIN + ?DUP + WHILE + [COMPILE] THEN + REPEAT +; diff --git a/src/lib_3_comments.4th b/src/lib_3_comments.4th new file mode 100644 index 0000000..a5b695b --- /dev/null +++ b/src/lib_3_comments.4th @@ -0,0 +1,22 @@ +\ Parenthetic comments + +: ( IMMEDIATE + 1 \ allowed nested parens by keeping track of depth + BEGIN + >IN @ #TIB @ >= IF \ End of TIB? + QUERY \ Get next line + THEN + + TIB >IN @ + @ 1 >IN +! + DUP [CHAR] ( = IF \ open paren? + DROP \ drop the open paren + 1+ \ depth increases + ELSE + [CHAR] ) = IF \ close paren? + 1- \ depth decreases + THEN + THEN + DUP 0= UNTIL \ continue until we reach matching close paren, depth 0 + DROP \ drop the depth counter +; + diff --git a/src/lib_4_printnum.4th b/src/lib_4_printnum.4th new file mode 100644 index 0000000..290af8f --- /dev/null +++ b/src/lib_4_printnum.4th @@ -0,0 +1,116 @@ +\ Displaying numbers + +( Write n spaces to stdout. ) +: SPACES ( n -- ) + DUP 0> IF + 0 DO SPACE LOOP + ELSE + DROP + THEN +; +( This is the underlying recursive definition of U. ) +: U. ( u -- ) + BASE @ /MOD ( width rem quot ) + ?DUP IF ( if quotient <> 0 then ) + RECURSE ( print the quotient ) + THEN + + ( print the remainder ) + DUP 10 < IF + [CHAR] 0 ( decimal digits 0..9 ) + ELSE + 10 - ( hex and beyond digits A..Z ) + [CHAR] A + THEN + + + EMIT +; + +( This word returns the width (in characters) of an unsigned number in the current base ) +: UWIDTH ( u -- width ) + BASE @ / ( rem quot ) + ?DUP IF ( if quotient <> 0 then ) + RECURSE 1+ ( return 1+recursive call ) + ELSE + 1 ( return 1 ) + THEN +; + +: U.R ( u width -- ) + SWAP ( width u ) + DUP ( width u u ) + UWIDTH ( width u uwidth ) + ROT ( u uwidth width ) + SWAP - ( u width-uwidth ) + ( At this point if the requested width is narrower, we'll have a negative number on the stack. + Otherwise the number on the stack is the number of spaces to print. But SPACES won't print + a negative number of spaces anyway, so it's now safe to call SPACES ... ) + SPACES + ( ... and then call the underlying implementation of U. ) + U. +; + +: .R ( n width -- ) + SWAP ( width n ) + DUP 0< IF + NEGATE ( width u ) + 1 ( save a flag to remember that it was negative | width n 1 ) + -ROT ( 1 width u ) + SWAP ( 1 u width ) + 1- ( 1 u width-1 ) + ELSE + 0 ( width u 0 ) + -ROT ( 0 width u ) + SWAP ( 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 ( was it negative? print the - character ) + [CHAR] - EMIT + THEN + + U. +; + +: . 0 .R SPACE ; + +: .S ( -- ) + [CHAR] < EMIT DEPTH U. [CHAR] > EMIT SPACE + PSP0 1+ + BEGIN + DUP PSP@ 2 - <= + WHILE + DUP @ . + 1+ + REPEAT + DROP +; + +: U. U. SPACE ; + +( ? fetches the integer at an address and prints it. ) +: ? ( addr -- ) @ . ; + +( c a b WITHIN returns true if a <= c and c < b ) +: WITHIN + -ROT ( b c a ) + OVER ( b c a c ) + <= IF + > IF ( b c -- ) + TRUE + ELSE + FALSE + THEN + ELSE + 2DROP ( b c -- ) + FALSE + THEN +; + diff --git a/src/lib_5_strings.4th b/src/lib_5_strings.4th new file mode 100644 index 0000000..99d1d39 --- /dev/null +++ b/src/lib_5_strings.4th @@ -0,0 +1,91 @@ +\ Strings + +: CMOVE ( src dest length -- ) + + DUP 0<= IF + EXIT + THEN + + -ROT OVER - ( length src (dest-src) ) + -ROT DUP ROT + SWAP ( (dest-src) (src+length) src ) + + DO + I @ ( (dest-src) i@ ) + OVER I + ( (dest-src) i@ (dest-src+i) ) + ! ( (dest-src) ) + LOOP + + DROP +; + +: S" IMMEDIATE ( -- addr len ) + STATE @ IF ( compiling? ) + ['] LITSTRING , ( compile LITSTRING ) + HERE ( save the address of the length word on the stack ) + 0 , ( dummy length - we don't know what it is yet ) + + BEGIN + >IN @ #TIB @ >= IF \ End of TIB? + QUERY \ Get next line + THEN + + TIB >IN @ + @ 1 >IN +! \ Get char from TIB + + DUP [CHAR] " <> + WHILE + C, ( copy character ) + REPEAT + DROP ( drop the double quote character at the end ) + DUP ( get the saved address of the length word ) + HERE SWAP - ( calculate the length ) + 1- ( subtract 1 (because we measured from the start of the length word) ) + SWAP ! ( and back-fill the length location ) + ELSE ( immediate mode ) + HERE ( get the start address of the temporary space ) + + BEGIN + >IN @ #TIB @ >= IF \ End of TIB? + QUERY \ Get next line + THEN + + TIB >IN @ + @ 1 >IN +! \ Get char from TIB + + DUP [CHAR] " <> + WHILE + OVER C! ( save next character ) + 1+ ( increment address ) + REPEAT + DROP ( drop the final " character ) + HERE - ( calculate the length ) + HERE ( push the start address ) + SWAP ( addr len ) + THEN +; + +: ." IMMEDIATE ( -- ) + [COMPILE] S" ( read the string, and compile LITSTRING, etc. ) + ['] TYPE , ( compile the final TYPE ) +; + +: .( + BEGIN + >IN @ #TIB @ >= IF \ End of TIB? + QUERY \ Get next line + THEN + + TIB >IN @ + @ 1 >IN +! \ Get char from TIB + + DUP [CHAR] ) = IF + DROP ( drop the double quote character ) + EXIT ( return from this function ) + THEN + EMIT + AGAIN +; + +( Converts address of counted string into address of + start of string and length of string. ) +: COUNT ( addr1 -- addr2 n ) + DUP 1+ SWAP @ ; + + diff --git a/src/lib_6_variables.4th b/src/lib_6_variables.4th new file mode 100644 index 0000000..6829c9c --- /dev/null +++ b/src/lib_6_variables.4th @@ -0,0 +1,59 @@ +\ Constants and Variables + +: CONSTANT + CREATE , +DOES> @ +; + +: ALLOT ( n -- ) + H +! ( adds n to H, after this the old value of H is still on the stack ) +; + +: VARIABLE + CREATE + 1 CELLS ALLOT ( allocate 1 cell of memory, push the pointer to this memory ) +; + +: VALUE ( n -- ) + CREATE , +DOES> @ +; + +: TO IMMEDIATE ( n -- ) + BL WORD ( get the name of the value ) + FIND DROP ( look it up in the dictionary ) + >BODY ( get a pointer to the first data field (the 'LIT') ) + STATE @ IF ( compiling? ) + ['] LIT , ( compile LIT ) + , ( compile the address of the value ) + ['] ! , ( compile ! ) + ELSE ( immediate mode ) + ! ( update it straightaway ) + THEN +; + +( x +TO VAL adds x to VAL ) +: +TO IMMEDIATE + BL WORD ( get the name of the value ) + FIND DROP ( look it up in the dictionary ) + >BODY ( get a pointer to the first data field (the 'LIT') ) + STATE @ IF ( compiling? ) + ['] LIT , ( compile LIT ) + , ( compile the address of the value ) + ['] +! , ( compile +! ) + ELSE ( immediate mode ) + +! ( update it straightaway ) + THEN +; + +( Fill u ints, starting at a, with the value b ) +: FILL ( a u b -- ) + -ROT OVER + SWAP ?DO + DUP I ! + LOOP + DROP +; + +: ERASE ( a u -- ) + 0 FILL +; diff --git a/src/lib_7_printwords.4th b/src/lib_7_printwords.4th new file mode 100644 index 0000000..9533556 --- /dev/null +++ b/src/lib_7_printwords.4th @@ -0,0 +1,48 @@ +\ Display dictionary contents + +: .NAME + DUP @ ( get the flags/length byte ) + F_LENMASK AND ( mask out the flags - just want the length ) + + BEGIN + DUP 0> ( length > 0? ) + WHILE + SWAP 1+ ( addr len -- len addr+1 ) + DUP @ ( len addr -- len addr char | get the next character) + DUP 32 >= OVER 127 <= AND IF + EMIT ( len addr char -- len addr | and print it) + ELSE + BASE @ SWAP HEX + ." \x" 0 .R + BASE ! + THEN + SWAP 1- ( len addr -- addr len-1 | subtract one from length ) + REPEAT + 2DROP ( len addr -- ) +; + +: ?HIDDEN + 1+ ( skip over the link pointer ) + @ ( get the flags/length byte ) + F_HIDDEN AND ( mask the F_HIDDEN flag and return it (as a truth value) ) +; +: ?IMMEDIATE + 1+ ( skip over the link pointer ) + @ ( get the flags/length byte ) + F_IMMED AND ( mask the F_IMMED flag and return it (as a truth value) ) +; + +: WORDS + CR + LATEST @ ( start at LATEST dictionary entry ) + BEGIN + ?DUP ( while link pointer is not null ) + WHILE + DUP ?HIDDEN NOT IF ( ignore hidden words ) + DUP 1+ .NAME ( but if not hidden, print the word ) + SPACE + THEN + @ ( dereference the link pointer - go to previous word ) + REPEAT + CR +; diff --git a/src/lib_8_decompiler.4th b/src/lib_8_decompiler.4th new file mode 100644 index 0000000..d9c9f3a --- /dev/null +++ b/src/lib_8_decompiler.4th @@ -0,0 +1,127 @@ +\ Decompilation + +: >NAME + BEGIN + 1- DUP @ + NFA_MARK AND + NFA_MARK = UNTIL +; + +: >LFA >NAME 1- ; + +: SEE + BL WORD FIND ( find the dictionary entry to decompile ) + + CR + + 0= IF + ." Word '" COUNT TYPE ." ' not found in dictionary." + EXIT + THEN + + >LFA + + ( Now we search again, looking for the next word in the dictionary. This gives us + the length of the word that we will be decompiling. (Well, mostly it does). ) + HERE ( address of the end of the last compiled word ) + LATEST @ ( word last curr ) + BEGIN + 2 PICK ( word last curr word ) + OVER ( word last curr word curr ) + <> ( word last curr word<>curr? ) + WHILE ( word last curr ) + NIP ( word curr ) + DUP @ ( word curr prev (which becomes: word last curr) ) + REPEAT + + DROP ( at this point, the stack is: start-of-word end-of-word ) + SWAP ( end-of-word start-of-word ) + + DUP >CFA @ CASE + DOCOL OF + \ Colon definition + [CHAR] : EMIT SPACE DUP 1+ .NAME SPACE + DUP ?IMMEDIATE IF ." IMMEDIATE " THEN CR + ENDOF + DOVAR OF + \ Variable definition + ." Variable " DUP 1+ .NAME CR + 2DROP EXIT + ENDOF + DOCON OF + \ Constant definition + ." Constant " DUP 1+ .NAME CR + 2DROP EXIT + ENDOF + + \ Unknown codeword + ." Primitive or word with unrecognized codeword." CR + DROP 2DROP EXIT + ENDCASE + + 4 SPACES + + >CFA >BODY ( get the data address, ie. points after DOCOL | end-of-word start-of-data ) + + ( now we start decompiling until we hit the end of the word ) + BEGIN ( end start ) + 2DUP > + WHILE + DUP @ ( end start codeword ) + + CASE + ['] LIT OF ( is it LIT ? ) + 1+ DUP @ ( get next word which is the integer constant ) + . ( and print it ) + ENDOF + ['] LITSTRING OF ( is it LITSTRING ? ) + [CHAR] S EMIT [CHAR] " EMIT SPACE ( print S" ) + 1+ DUP @ ( get the length word ) + SWAP 1+ SWAP ( end start+1 length ) + 2DUP TYPE ( print the string ) + [CHAR] " EMIT SPACE ( finish the string with a final quote ) + + ( end start+1+len, aligned ) + 1- ( because we're about to add 4 below ) + ENDOF + ['] 0BRANCH OF ( is it 0BRANCH ? ) + ." 0BRANCH ( " + 1+ DUP @ ( print the offset ) + . + ." ) " + ENDOF + ['] BRANCH OF ( is it BRANCH ? ) + ." BRANCH ( " + 1+ DUP @ ( print the offset ) + . + ." ) " + ENDOF + ['] ['] OF ( is it ['] ? ) + ." ['] " + 1+ DUP @ ( get the next codeword ) + >NAME ( and force it to be printed as a dictionary entry ) + .NAME SPACE + ENDOF + ['] EXIT OF ( is it EXIT? ) + ( We expect the last word to be EXIT, and if it is then we don't print it + because EXIT is normally implied by ;. EXIT can also appear in the middle + of words, and then it needs to be printed. ) + 2DUP ( end start end start ) + 1+ ( end start end start+1 ) + <> IF ( end start | we're not at the end ) + ." EXIT " + THEN + ENDOF + ( default case: ) + DUP ( in the default case we always need to DUP before using ) + >NAME ( look up the codeword to get the dictionary entry ) + .NAME SPACE ( and print it ) + ENDCASE + + 1+ ( end start+1 ) + REPEAT + + [CHAR] ; EMIT CR + + 2DROP ( restore stack ) +; + diff --git a/src/lib_9_misc.4th b/src/lib_9_misc.4th new file mode 100644 index 0000000..57b7e75 --- /dev/null +++ b/src/lib_9_misc.4th @@ -0,0 +1,47 @@ +\ Miscellaneous core words + +: ROLL ( x_u x_u-1... x_0 u -- x_u-1 ... x_0 x_u ) + 1+ DUP PICK SWAP ( x_u x_u-1 ... x_0 x_u u+1 ) + PSP@ 1- SWAP - PSP@ 2- SWAP + DO + i 1+ @ i ! + LOOP + SWAP DROP +; + +( Compute absolute value. ) +: ABS ( n -- |n| ) + dup 0< if + negate + then +; + +: MAX ( n m -- max ) + 2dup - 0< if + swap drop + else + drop + then +; + +: MIN ( n m -- max ) + 2dup - 0> if + swap drop + else + drop + then +; + +: FORGET + BL WORD FIND >LFA ( find the word, gets the dictionary entry address ) + DUP @ LATEST ! ( set LATEST to point to the previous word ) + H ! ( and store H with the dictionary address ) +; + +: HIDE + BL WORD FIND DROP >NAME + DUP @ F_HIDDEN OR SWAP ! +; + +: UNUSED ( -- cells ) + MEMSIZE HERE - ;