Paste number 349395: fix CREATE

Paste number 349395: fix CREATE
Pasted by: reepca
When:3 years, 1 month ago
Share:Tweet this! | http://paste.lisp.org/+7HLF
Channel:None
Paste contents:
Raw Source | XML | Display As
From 361044c16fa82f8dac459647c5ef84a0b9c71ae6 Mon Sep 17 00:00:00 2001
From: Caleb Ristvedt <caleb.ristvedt@cune.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
+	&COPYR_Text                 ; Pointer to Name
+	NOP                         ; Flags
+	&COPYR_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
+	&COPYR_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.

Colorize as:
Show Line Numbers

Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.