From 60333e365c3400a3498395e2e454caefbe4180d8 Mon Sep 17 00:00:00 2001
From: Jesse McDonald <nybble41@gmail.com>
Date: Sat, 3 Oct 2020 15:25:53 -0500
Subject: [PATCH] fix DOES> to work as described in the ANS Forth standard

---
 jumpforth.S | 74 +++++++++++++++++++++++++++++++++++++----------------
 startup.4th |  2 +-
 2 files changed, 53 insertions(+), 23 deletions(-)

diff --git a/jumpforth.S b/jumpforth.S
index cef4a5d..4422703 100644
--- a/jumpforth.S
+++ b/jumpforth.S
@@ -11,6 +11,12 @@
 
 .set DATA_SEGMENT_ALLOC_SIZE,65536
 
+.set F_IMMED,0x80
+.set F_HIDDEN,0x40
+.set F_LENMASK,0x3f
+
+.set link,0
+
 .macro NEXT
    lodsl
    jmp *(%eax)
@@ -58,15 +64,35 @@ DOCOL:
 /* (By default the DFA field holds the address of the body of the definition) */
    .text
    .align 4
-   .globl SELF
-SELF:
+   .globl DOSELF
+DOSELF:
    pushl 4(%eax)
    NEXT
 
-.set F_IMMED,0x80
-.set F_HIDDEN,0x40
-.set F_LENMASK,0x3f
-.set link,0
+/* The entry point for threaded FORTH words defined with CREATE/DOES> */
+/* Push the return address (%esi) on the return stack */
+/* Load the address of the DOES> code body from the DFA field at %eax+4 */
+/* Push the address of the body of the word (not the DFA field) onto the stack */
+   .text
+   .align 4
+   .globl DODOES
+DODOES:
+   /* Save threaded return address */
+   PUSHRSP %esi
+   /* Load address of DOES> body from DFA into %esi */
+   movl 4(%eax),%esi
+   /* Load name length byte into %eax and mask out flag bits */
+   xor %ebx,%ebx
+   movb 12(%eax),%bl
+   andb $F_LENMASK,%bl
+   /* Calculate %eax + 13 + %ebx and round up to next cell for address of body */
+   addl $16,%eax
+   addl %ebx,%eax
+   andl $-4,%eax
+   /* Push body address on the data stack */
+   push %eax
+   /* Execute the DOES> code */
+   NEXT
 
 .macro defname label:req,codeword:req,dataword:req,name="",flags=0
    .section .rodata
@@ -137,7 +163,8 @@ defconst BUFFER,buffer
 defconst __BUFFER_SIZE,BUFFER_SIZE,"BUFFER_SIZE"
 
 defconst __DOCOL,DOCOL,"DOCOL"
-defconst __SELF,SELF,"SELF"
+defconst __DOSELF,DOSELF,"DOSELF"
+defconst __DODOES,DODOES,"DODOES"
 
 defconst FALSE,0
 defconst TRUE,-1
@@ -1104,20 +1131,12 @@ defword QUOTE,"'"
    .int WORD,FINDERR,EXIT
 
 defword CREATE
-   .int ALIGN,HERE,LIT,SELF,COMMA,LIT,0,COMMA,LATEST,FETCH,COMMA,LIT,0,COMMABYTE
+   .int ALIGN,HERE,LIT,DOSELF,COMMA,LIT,0,COMMA,LATEST,FETCH,COMMA,LIT,0,COMMABYTE
    .int WORD,NIP,DUP,ALLOT,ALIGN
    .int OVER,TFLAGS,STOREBYTE
    .int HERE,OVER,TDFA,STORE
    .int LATEST,STORE,EXIT
 
-defword DOES,"DOES>"
-   .int LATEST,FETCH
-   .int LIT,DOCOL,OVER,TCFA,STORE
-   .int ALIGN,HERE,OVER,TDFA,STORE
-   .int LIT,LIT,COMMA,TBODY,COMMA
-   .int TRUE,STATE,STORE
-   .int EXIT
-
 defword COLON,":"
    .int CREATE
    .int LATEST,FETCH
@@ -1136,13 +1155,24 @@ defword NONAME,":NONAME"
    .int TRUE,STATE,STORE
    .int EXIT
 
+/* ( xt -- ) Clear the F_HIDDEN flag of the word denoted by xt */
+defword _UNHIDE_,"(UNHIDE)",F_HIDDEN
+   .int TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,INVERT,AND,SWAP,STOREBYTE,EXIT
+
 defword SEMI,";",F_IMMED
-   .int LIT,EXIT,COMMA,LATEST,FETCH,TFLAGS
-   .int DUP,FETCHBYTE,DUP,__F_HIDDEN,AND,ZBRANCH,(0f - .)
-   .int __F_HIDDEN,SUB,SWAP,STOREBYTE,BRANCH,(1f - .)
-0: .int TWODROP
-1: .int FALSE,STATE,STORE
-   .int ALIGN,EXIT
+   .int LIT,EXIT,COMMA,LATEST,FETCH,_UNHIDE_
+   .int FALSE,STATE,STORE,ALIGN,EXIT
+
+/* ( dfa -- ) Set CFA of latest word to DODOES and set DFA field to address on stack */
+defword _DOES_,"(DOES)",F_HIDDEN
+   .int LATEST,FETCH,LIT,DODOES,OVER,TCFA,STORE,TDFA,STORE,EXIT
+
+/* Append "<addr> (DOES) EXIT" to the current definition */
+/* where <addr> is the next address after the "EXIT" as a literal number */
+/* Stay in compilation mode for the body of the DOES> clause */
+defword DOES,"DOES>",F_IMMED
+   .int LIT,LIT,COMMA,HERE,LIT,12,ADD,COMMA
+   .int LIT,_DOES_,COMMA,LIT,EXIT,COMMA,EXIT
 
 defword WORD
    .int SKIPSPACE,HERE
diff --git a/startup.4th b/startup.4th
index 02fc0ca..677b7fc 100644
--- a/startup.4th
+++ b/startup.4th
@@ -175,7 +175,7 @@
 \ Named values defined with VALUE can be modified with TO.
 \   Execution: ( x "<spaces>name" -- )
 \   name execution: ( -- value )
-: VALUE CREATE , POSTPONE DOES> POSTPONE @ POSTPONE ; ;
+: VALUE CREATE , DOES> @ ;
 
 \ When compiling, append code to store to the data field area of the named value.
 \ When interpreting, store to the data field directly.