andrius
/
stage0
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
This commit is contained in:
Caleb Ristvedt 2017-06-24 02:31:53 -05:00 committed by Jeremiah Orians
parent 871f8e281d
commit 1a6c7d5afe
No known key found for this signature in database
GPG Key ID: 7457821534D2ACCD
2 changed files with 173 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
stage2/forth.s
View File

@ -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

115
stage3/inital_library.fs
View File

@ -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 ;
: <> != ;