|Paste number 349395:||fix CREATE|
|When:||2 years, 11 months ago|
|Share:||Tweet this! | http://paste.lisp.org/+7HLF|
From 361044c16fa82f8dac459647c5ef84a0b9c71ae6 Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt <firstname.lastname@example.org> Date: Sat, 24 Jun 2017 02:31:53 -0500 Subject: [PATCH] Fix CREATE, implement DOES>, more words Implemented some new words in forth.s: * 'DODOES Gives the address of the assembly for DODOES. Used by DOES> when compiling machine code to jump to it and activate the following high-level forth code. This is how non-primitive actions for a word can be set. * LATEST! Sets the LATEST pointer. For when the user wants to write their own way of extending the dictionary (word lists, vocabularies, etc). * R@ Copies the top of the return stack to the data stack. Useful for when loops start getting non-trivial and you start wondering of all those ROTs aren't efficient enough. Maybe someday we'll implement a register-allocating compiler. Probably not. Too complicated for bootstrapping. * Not really words but used: DODOES and DOVAR. DOVAR is the default behavior of CREATEd words - it just pushes a pointer to whatever was allotted right after the word was created. DODOES is jumped to in order to invoke high-level forth behaviors for words. * Changed behavior of CREATE to better match the way it usually works. Added some words to inital_library.fs (we should fix that name sometime): * Added a variable BASE to control what base numbers are printed in. * Turns out I misunderstood what WORD did and mis-diagnosed an early problem in ' - so it turns out that nothing was being allotted in the dictionary, just stuff in "string space", which if I understand properly just sort of fills up infinitely as long as WORD is being invoked. Some other forths try to solve this by introducing an input buffer for the current line, at the cost of some complexity (as words like [CHAR] and S" have to take that into account). Anyway, the HERE and DP! are gone from ' now. * Added BOUNDS for common setup for sequence-iterating loops. * Added region-comment "(" (note that it doesn't nest), used most often for stack comments. * Added hex dump printer DUMP and support words, number of bytes printed per line is controlled by LINE-SIZE. It looks pretty nice, much of the design is based off of gforth's. * Added DOES> and supporting words, and used it to make VARIABLE, CONSTANT, and DEFER. * Added TUCK, MIN, SPACES, :NONAME, FILL, and <>. Add LSHIFT and RSHIFT to the wishlist, as ghetto shifting with division seems to behave a bit strangely when given negative values. Also, we're now advanced enough to support the tictactoe I wrote awhile back for gforth! http://paste.lisp.org/display/349394 --- stage2/forth.s | 73 ++++++++++++++++++++++++++++-- stage3/inital_library.fs | 115 ++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 173 insertions(+), 15 deletions(-) diff --git a/stage2/forth.s b/stage2/forth.s index 9f55a43..bf9ba61 100644 --- a/stage2/forth.s +++ b/stage2/forth.s @@ -108,6 +108,28 @@ LOAD R0 R12 0 ; Get Code word target JSR_COROUTINE R0 ; Jump to Code word + +:DODOES + ADDI R1 R12 4 ; Get Parameter Field Address + PUSHR R1 R14 ; Put it on data stack + LOAD R12 R12 0 ; Get location of the jump to this + JUMP @DOCOL ; Go to the high-level forth + +;; 'DODOES - gives the address of the +;; assembly for DODOES. We need that particular bit +;; of assembly to implement DOES>. +:DODOES_ADDR_Text +"'DODOES" +:DODOES_ADDR_Entry + &EXIT_Entry ; Pointer to EXIT + &DODOES_ADDR_Text ; Pointer to name + NOP ; Flags + &DODOES_ADDR_Code ; Where assembly is stored +:DODOES_ADDR_Code + LOADUI R0 $DODOES ; Get address of DODOES + PUSHR R0 R14 ; Put it on data stack + JSR_COROUTINE R11 ; NEXT + ;; DOCOL Function ;; The Interpreter for DO COLON ;; Jumps to NEXT @@ -122,7 +144,7 @@ :Drop_Text "DROP" :Drop_Entry - &EXIT_Entry ; Pointer to EXIT + &DODOES_ADDR_Entry ; Pointer to 'DODOES &Drop_Text ; Pointer to Name NOP ; Flags &Drop_Code ; Where assembly is Stored @@ -684,11 +706,23 @@ PUSHR R9 R14 ; Put LATEST onto stack JSR_COROUTINE R11 ; NEXT +;; LATEST! +:SetLatest_Text +"LATEST!" +:SetLatest_Entry + &Latest_Entry ; Pointer to LATEST + &SetLatest_Text ; Pointer to Name + NOP ; Flags + &SetLatest_Code ; Where assembly is stored +:SetLatest_Code + POPR R9 R14 ; Set LATEST from stack + JSR_COROUTINE R11 ; NEXT + ;; HERE :Here_Text "HERE" :Here_Entry - &Latest_Entry ; Pointer to LATEST + &SetLatest_Entry ; Pointer to LATEST! &Here_Text ; Pointer to Name NOP ; Flags &Here_Code ; Where assembly is Stored @@ -723,11 +757,24 @@ PUSHR R0 R15 ; Shove it onto return stack JSR_COROUTINE R11 ; NEXT +;; R@ +:COPYR_Text +"R@" +:COPYR_Entry + &TOR_Entry ; Pointer to >R + ©R_Text ; Pointer to Name + NOP ; Flags + ©R_Code ; Where assembly is stored +:COPYR_Code + LOAD R0 R15 4 ; Get top of return stack + PUSHR R0 R14 ; Put it on data stack + JSR_COROUTINE R11 ; NEXT + ;; R> :FROMR_Text "R>" :FROMR_Entry - &TOR_Entry ; Pointer to >R + ©R_Entry ; Pointer to >R &FROMR_Text ; Pointer to Name NOP ; Flags &FROMR_Code ; Where assembly is Stored @@ -1133,6 +1180,12 @@ PUSHR R0 R14 ; Push the result JSR_COROUTINE R11 ; NEXT + +:DOVAR + ADDUI R0 R12 4 ; Locate Parameter Field Address + PUSHR R0 R14 ; Push on stack + JSR_COROUTINE R11 ; NEXT + ;; CREATE :Create_Text "CREATE" @@ -1142,16 +1195,30 @@ NOP ; Flags &Create_Code ; Where assembly is Stored :Create_Code + CALLI R15 @Word_Direct ; Get Word POPR R0 R14 ; Get Length POPR R1 R14 ; Get Pointer FALSE R2 ; Set to Zero CMPJUMPI.LE R0 R2 @Create_Code_1 ; Prevent size below 1 + COPY R3 R8 ; Remember HERE for header :Create_Code_0 LOAD8 R2 R1 0 ; Read Byte STORE8 R2 R8 0 ; Write at HERE ADDUI R8 R8 1 ; Increment HERE SUBUI R0 R0 1 ; Decrement Length + ADDUI R1 R1 1 ; Increment string pointer JUMP.NZ R0 @Create_Code_0 ; Keep Looping + FALSE R2 ; Set to Zero + STORE8 R2 R8 0 ; Write null terminator + ADDUI R8 R8 1 ; Increment HERE + COPY R0 R8 ; Remember HERE to set LATEST + ; R9 has latest + PUSHR R9 R8 ; Push pointer to current LATEST + COPY R9 R0 ; Set LATEST to this header + PUSHR R3 R8 ; Push location of name + PUSHR R2 R8 ; Push empty flags + LOADUI R0 $DOVAR ; Load address of DOVAR + PUSHR R0 R8 ; Push address of DOVAR :Create_Code_1 JSR_COROUTINE R11 ; NEXT diff --git a/stage3/inital_library.fs b/stage3/inital_library.fs index 7e5f91f..ac6c207 100644 --- a/stage3/inital_library.fs +++ b/stage3/inital_library.fs @@ -37,8 +37,8 @@ \ Define ALLOT to allocate a give number of bytes : ALLOT HERE + DP! ; -\ Read a word, lookup and return pointer to its definition and don't use up HEAP space doing it -: ' HERE WORD DROP FIND >CFA SWAP DP! ; +\ Read a word, lookup and return pointer to its definition. +: ' WORD DROP FIND >CFA ; \ Lookup a word and write the address of its definition : [COMPILE] ' , ; IMMEDIATE @@ -92,8 +92,11 @@ \ Writes a Byte to HEAP : C, HERE C! 1 ALLOT ; +\ addr count -- high low +: BOUNDS OVER + SWAP ; + \ Prints Memory from address a to a + b when invoked as a b TYPE -: TYPE OVER + SWAP BEGIN 2DUP > WHILE DUP C@ EMIT 1 + REPEAT 2DROP ; +: TYPE BOUNDS BEGIN 2DUP > WHILE DUP C@ EMIT 1 + REPEAT 2DROP ; \ So we don't have to type 10 EMIT for newlines anymore : CR 10 EMIT ; @@ -102,7 +105,8 @@ : STR" HERE BEGIN KEY DUP [CHAR] " != WHILE C, REPEAT DROP HERE OVER - ; \ Extends STR" to work in Compile mode -: S" STATE IF ['] BRANCH , HERE 0 , STR" ROT HERE TARGET! SWAP LITERAL LITERAL ELSE STR" THEN ; IMMEDIATE +: S" STATE IF ['] BRANCH , HERE 0 , STR" ROT HERE TARGET! SWAP LITERAL LITERAL + ELSE STR" THEN ; IMMEDIATE \ Extends S" to behave the way most users want " : ." [COMPILE] S" STATE IF ['] TYPE , ELSE TYPE THEN ; IMMEDIATE @@ -113,8 +117,11 @@ \ add ANS keyword for getting both Quotent and Remainder : /MOD 2DUP MOD >R / R> ; +\ valid bases are from 2 to 36. +CREATE BASE 10 , + \ Primitive needed for printing base 10 numbers -: NEXT-DIGIT 10 /MOD ; +: NEXT-DIGIT BASE @ /MOD ; \ Give us a 400bytes of storage to play with : PAD HERE 100 CELLS + ; @@ -125,16 +132,23 @@ \ Swap the contents of 2 Memory addresses : CSWAP! 2DUP C@ SWAP C@ ROT C! SWAP C! ; -\ Given an address and a number of Chars, reverses a string (handy for little endian systems that have bytes in the wrong order) -: REVERSE-STRING OVER + 1 - BEGIN 2DUP < WHILE 2DUP CSWAP! 1 - SWAP 1 + SWAP REPEAT 2DROP ; +\ Given an address and a number of Chars, reverses a string (handy for little +\ endian systems that have bytes in the wrong order) +: REVERSE-STRING OVER + 1 - + BEGIN 2DUP < WHILE 2DUP CSWAP! 1 - SWAP 1 + SWAP REPEAT 2DROP ; \ Given an address and number, writeout number at address and increment address : +C! OVER C! 1 + ; -\ Given a number and address write out string form of number at address and returns address and length (address should have at least 10 free bytes). + +\ works for hex and stuff +: >ASCII-DIGIT DUP 10 < IF 48 ELSE 87 THEN + ; + +\ Given a number and address write out string form of number at address and +\ returns address and length (address should have at least 10 free bytes). : NUM>STRING DUP >R OVER 0 < IF SWAP NEGATE SWAP [CHAR] - +C! - THEN DUP >R SWAP - BEGIN NEXT-DIGIT ROT SWAP 48 + +C! SWAP DUP WHILE REPEAT + THEN DUP >R SWAP \ R: str-start digits-start + BEGIN NEXT-DIGIT ROT SWAP >ASCII-DIGIT +C! SWAP DUP WHILE REPEAT DROP R> 2DUP - REVERSE-STRING R> SWAP OVER - ; \ A user friendly way to print a number @@ -144,13 +158,90 @@ : STACK-BASE 0x00090000 ; \ Given current stack pointer calculate and display number of underflowed cells -: .UNDERFLOW ." Warning: stack is underflowed by " STACK-BASE SWAP - CELL / . ." cells!" CR ; +: .UNDERFLOW ." Warning: stack is underflowed by " + STACK-BASE SWAP - CELL / . ." cells!" CR ; \ Display the number of entries on stack in <n> form : .HEIGHT STACK-BASE - CELL / ." <" . ." > " ; \ Display count and contents of stack or error message if Underflow -: .S DSP@ DUP STACK-BASE < IF .UNDERFLOW ELSE DUP .HEIGHT STACK-BASE BEGIN 2DUP > WHILE DUP @ . 32 EMIT CELL + REPEAT 2DROP THEN ; +: .S DSP@ DUP STACK-BASE < IF .UNDERFLOW + ELSE DUP .HEIGHT STACK-BASE + BEGIN 2DUP > WHILE DUP @ . 32 EMIT CELL + REPEAT + 2DROP + THEN ; \ Pop off contents of stack to Zero stack : CLEAR-STACK BEGIN DSP@ STACK-BASE > WHILE .S 10 EMIT DROP REPEAT STACK-BASE DSP! ; +: ( BEGIN KEY [CHAR] ) = UNTIL ; IMMEDIATE +\ Note: for further reading, see brad rodriguez's moving forth stuff. +\ The return address currently on the stack points to the next word to be +\ executed. DOER! should only be compiled by DOES> or other similar words, so +\ the address on the return stack should be right past DOER!'s. Which should be +\ the code to make the action for the latest word. Since we only want to set +\ this code as the latest word's action, not actually execute it at this point, +\ we don't bother putting anything back on the return stack - we'll return +\ straight up past the word we came from. + +\ For example: consider this definition +\ : CONSTANT CREATE , DOES> @ ; +\ This compiles to the sequence: DOCOL CREATE , DOER! @ EXIT +\ DOER! will point the latest word (the CREATEd one) to the code right past it - +\ the @ EXIT - and then exit the definition it's in. +: DOER! R> SWAP >CFA ! ; +\ This is a tricky one. Basically, we need to compile a little bit of machine +\ code that will invoke the code that follows. Notes: R12 should, at this point, +\ have the address of the place we got here from. So we should just put +\ that+cell on the stack (for use by what follows DOES>) and run DOCOL. (Note: +\ implemented in forth.s) +\ Assumes most significant byte is at lower address +\ I'm not sure why that 65535 AND is necessary, but it seems to be. Some issue +\ with signed division I guess. +: 2C, 65535 AND DUP 256 / C, 255 AND C, ; \ ghetto right shift +\ Compiles an assembly-level jump to a location. Note that this isn't +\ future-proof, as if HERE gets past 30k or so 16 bits won't be large enough for +\ that jump. We may have to compile more than just a jump in the future in order +\ for DOES> to work properly - we'd need to load the address into a register, +\ having the actual address nearby, and then use that coroutine jump thing. 12 +\ bytes. +: JUMP-TO, HERE 0x3C C, 0x00 C, - 2C, ; +\ Sets the action of the latest word +: DOES> ['] LATEST , ['] DOER! , 'DODOES JUMP-TO, ; IMMEDIATE +\ Sets the action of a certain word +: DOER> ['] DOER! , 'DODOES JUMP-TO, ; IMMEDIATE +: TUCK SWAP OVER ; + +: MIN 2DUP < IF SWAP THEN DROP ; +: HEX 16 BASE ! ; +: DECIMAL 10 BASE ! ; + +CREATE LINE-SIZE CELL , +: PRINTABLE? DUP 127 < SWAP 31 > AND ; +: EMIT-PRINTABLE DUP PRINTABLE? IF EMIT ELSE DROP [CHAR] . EMIT THEN ; +: DUMP-TYPE BOUNDS BEGIN 2DUP > WHILE DUP C@ EMIT-PRINTABLE 1 + REPEAT 2DROP ; +\ will always print two characters. +: .HEX-BYTE DUP 16 / >ASCII-DIGIT EMIT 15 AND >ASCII-DIGIT EMIT ; +: DUMP-LINE 2DUP BOUNDS BEGIN 2DUP > WHILE DUP C@ .HEX-BYTE ." " 1 + REPEAT + 2DROP ." " DUMP-TYPE CR ; +: DUMP-LINES LINE-SIZE @ * BOUNDS + BEGIN 2DUP > WHILE DUP LINE-SIZE @ TUCK DUMP-LINE + REPEAT 2DROP ; +: DUMP LINE-SIZE @ /MOD -ROT 2DUP DUMP-LINES LINE-SIZE @ * + SWAP DUMP-LINE ; + +: VARIABLE CREATE 0 , ; +: CONSTANT CREATE , DOES> @ ; +: NOOP ; +: DEFER CREATE ['] NOOP , DOES> @ EXECUTE ; +: IS ' CELL + STATE IF LITERAL ['] ! , ELSE ! THEN ; IMMEDIATE + + +\ emits n spaces. +: SPACES BEGIN DUP WHILE 32 EMIT 1 - REPEAT DROP ; +' NOOP @ CONSTANT 'DOCOL +\ Starts a definition without a name, leaving the execution token (the thing +\ that can be passed to EXECUTE) on the stack. +: :NONAME HERE 'DOCOL , ] ; + +\ fill n bytes with char. +\ addr n char -- +: FILL >R BOUNDS BEGIN 2DUP > WHILE DUP R@ C! 1 + REPEAT 2DROP R> DROP ; +: <> != ; -- 2.13.1
This paste has no annotations.