jumpforth/jumpforth.S

/* gcc -m32 -nostdlib -static -o jumpforth jumpforth.S */

#include <asm/unistd.h>

.code32

.set JUMPFORTH_VERSION,1

.set RETURN_STACK_SIZE,8192

.set DATA_SEGMENT_INITIAL_SIZE,65536

.set F_IMMED,0x80
.set F_HIDDEN,0x40
.set F_LENMASK,0x3f

.set link,0

.macro NEXT
   lodsl
   jmp *(%eax)
.endm

.macro PUSHRSP reg
   lea -4(%ebp),%ebp
   movl \reg ,(%ebp)
.endm

.macro POPRSP reg
   mov (%ebp),\reg
   lea 4(%ebp),%ebp
.endm

   .text
   .balign 4
   .globl _start
_start:
   cld
   mov (%esp),%eax
   mov %eax,data_ARGC
   lea 4(%esp),%eax
   mov %eax,data_ARGV
   sub $64,%esp
   mov %esp,data_S0
   mov $return_stack_top,%ebp
   xor %ebx,%ebx
   movl $__NR_brk,%eax
   int $0x80
   movl %eax,data_C0
   movl %eax,data_CP
   movl %eax,%ebx
   addl $DATA_SEGMENT_INITIAL_SIZE + 4096 - 1,%ebx
   andl $-4096,%ebx
   movl %ebx,data_BRK
   movl $__NR_brk,%eax
   int $0x80
   cmpl %eax,(data_BRK)
   jne 0f
   mov $cold_start,%esi
   NEXT
0: movl $254,%ebx
   movl $__NR_exit,%eax
   int $0x80
   jmp 0b

/* The entry point for threaded FORTH words */
/* Push the return address (%esi) on the return stack */
/* Load the address of the body of the definition from the DFA field at %eax+4 */
   .text
   .balign 4
   .globl DOCOL
DOCOL:
   PUSHRSP %esi
   movl 4(%eax),%esi
   NEXT

/* The entry point for deferred words */
/* The real execution token is in the DFA field */
/* Load the target xt and branch to the address in the target's codeword field */
   .text
   .balign 4
   .globl DODEFER
DODEFER:
   movl 4(%eax),%eax
   jmp *(%eax)

/* The default behavior for words defined with CREATE, VARIABLE, or CONSTANT */
/* Place the value of the DFA field on the top of the stack */
   .text
   .balign 4
   .globl DODATA
DODATA:
   pushl 4(%eax)
   NEXT

/* The default behavior for words defined with VALUE (or defvalue) */
/* Load the word at the address in the DFA field and place it on the stack */
   .text
   .balign 4
   .globl DOLOAD
DOLOAD:
   movl 4(%eax),%eax
   pushl (%eax)
   NEXT

/* 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
   .balign 4
   .globl DODOES
DODOES:
   /* Save threaded return address */
   PUSHRSP %esi
   /* Load address of DOES> body from DFA into %esi */
   movl 4(%eax),%esi
   /* Load address of word body (after DFA) onto stack */
   add $8,%eax
   push %eax
   /* Execute the DOES> code */
   NEXT

.macro litstring text:req
   .int LITSTRING
   .byte (9f - 8f)
8: .ascii "\text"
9: .balign 4
.endm

.macro defname label:req,codeword:req,dataword:req,name="",flags=0
   .section .data
   .balign 4
   .skip (-(9f-8f+1) & 3),0
.ifeqs "\name",""
8: .ascii "\label"
.else
8: .ascii "\name"
.endif
9: .byte \flags+(9b-8b)
   .int link
   .globl \label
\label :
   .set link,\label
   .int \codeword
   .int \dataword
.endm

.macro defword label:req,name="",flags=0
defname \label,DOCOL,thread_\label,"\name",\flags
   .section .rodata
   .balign 4
   .globl thread_\label
thread_\label :
.endm

.macro defcode label:req,name="",dataword=0,flags=0
defname \label,code_\label,\dataword,"\name",\flags
   .text
   .globl code_\label
code_\label :
.endm

.macro defdata label:req,name="",flags=0
defname \label,DODATA,data_\label,"\name",\flags
   .data
   .balign 4
data_\label :
.endm

.macro defvar label:req,initial=0,name="",flags=0
defdata \label,"\name",\flags
   .int \initial
.endm

.macro defconst label:req,value:req,name="",flags=0
defname \label,DODATA,\value,"\name",\flags
.endm

/* Parameters are stored like variables but produce a value, not an address. */
/* Use this for data which is read-only after initialization. */
.macro defvalue label:req,initial=0,name="",flags=0
defname \label,DOLOAD,data_\label,"\name",\flags
   .data
   .balign 4
data_\label :
   .int \initial
.endm

.macro defdefer label:req,value:req,name="",flags=0
defname \label,DODEFER,\value,"\name",\flags
.endm

defconst VERSION,JUMPFORTH_VERSION

defconst R0,return_stack_top

defconst __DOCOL,DOCOL,"DOCOL"
defconst __DODEFER,DODEFER,"DODEFER"
defconst __DODATA,DODATA,"DODATA"
defconst __DOLOAD,DOLOAD,"DOLOAD"
defconst __DODOES,DODOES,"DODOES"

defconst FALSE,0
defconst TRUE,-1

defconst CELL,4

defconst __F_IMMED,F_IMMED,"F_IMMED"
defconst __F_HIDDEN,F_HIDDEN,"F_HIDDEN"
defconst __F_LENMASK,F_LENMASK,"F_LENMASK"

/* NOTE: These are initialized in _start and read-only thereafter. */
defvalue C0     /* first byte of the heap */
defvalue S0     /* initial (empty) data stack pointer */
defvalue ARGC   /* number of command-line arguments (including program name) */
defvalue ARGV   /* address of array of command-line arguments (C string pointers) */

/* STATE controls whether we are currently interpreting (0) or compiling (1) */
defvar STATE,0  /* default to interpreting */

/* >IN gives the current offset of the parse area within the input buffer */
defvar IN,0,">IN"

/* NOTE: These are initialized in _start but vary during runtime. */
defvar CP       /* "compilation pointer", next free byte in the heap */
defvar BRK      /* the (current) end of the heap */

/* The current compilation word list, initially BOOTSTRAP-WORDLIST */
defvar CURRENT,data_BOOTSTRAP_WORDLIST

/* ( a -- ) */
defcode DROP
   pop %eax
   NEXT

/* ( a b -- b a ) */
defcode SWAP
   pop %ebx
   pop %eax
   push %ebx
   push %eax
   NEXT

/* ( a -- a a ) */
defcode DUP
   pop %eax
   push %eax
   push %eax
   NEXT

/* ( a b -- a b a ) */
defcode OVER
   pushl 4(%esp)
   NEXT

/* ( a b -- b ) */
defcode NIP
   pop %ebx
   pop %eax
   push %ebx
   NEXT

/* ( a b -- b a b ) */
defcode TUCK
   pop %ebx
   pop %eax
   push %ebx
   push %eax
   push %ebx
   NEXT

/* ( a b c -- b c a ) */
defcode ROT
   pop %ecx
   pop %ebx
   pop %eax
   push %ebx
   push %ecx
   push %eax
   NEXT

/* ( a b c -- c a b ) */
defcode NROT,"-ROT"
   pop %ecx
   pop %ebx
   pop %eax
   push %ecx
   push %eax
   push %ebx
   NEXT

/* ( a b -- ) */
defcode TWODROP,"2DROP"
   pop %ebx
   pop %eax
   NEXT

/* ( a b c d -- c d a b ) */
defcode TWOSWAP,"2SWAP"
   pop %edx
   pop %ecx
   pop %ebx
   pop %eax
   push %ecx
   push %edx
   push %eax
   push %ebx
   NEXT

/* ( a b -- a b a b ) */
defcode TWODUP,"2DUP"
   pop %ebx
   pop %eax
   push %eax
   push %ebx
   push %eax
   push %ebx
   NEXT

/* ( a b c d -- a b c d a b ) */
defcode TWOOVER,"2OVER"
   pushl 12(%esp)
   pushl 12(%esp)
   NEXT

/* ( a b c d -- c d ) */
defcode TWONIP,"2NIP"
   pop %edx
   pop %ecx
   pop %ebx
   pop %eax
   push %ecx
   push %edx
   NEXT

/* ( a b c d -- c d a b c d ) */
defcode TWOTUCK,"2TUCK"
   pop %edx
   pop %ecx
   pop %ebx
   pop %eax
   push %ecx
   push %edx
   push %eax
   push %ebx
   push %ecx
   push %edx
   NEXT

/* ( a b c d e f -- c d e f a b ) */
defcode TWOROT,"2ROT"
   pop %edx
   pop %ecx
   pop %ebx
   pop %eax
   xchg %eax,4(%esp)
   xchg %ebx,(%esp)
   push %ecx
   push %edx
   push %eax
   push %ebx
   NEXT

/* ( a b c d e f -- e f a b c d ) */
defcode NTWOROT,"-2ROT"
   pop %edx
   pop %ecx
   pop %ebx
   pop %eax
   xchg %ecx,4(%esp)
   xchg %edx,(%esp)
   push %ecx
   push %edx
   push %eax
   push %ebx
   NEXT

/* ( xn ... x1 n -- ) */
defcode NDROP
   pop %eax
   lea (%esp,%eax,4),%esp
   NEXT

/* ( xu ... x0 u -- xu ... x0 xu ) */
defcode PICK
   pop %eax
   pushl (%esp,%eax,4)
   NEXT

/* ( xu ... x0 u -- xu-1 ... x0 xu ) */
defcode ROLL
   pop %ecx
   movl (%esp,%ecx,4),%ebx
   mov %esi,%edx
   lea -4(%esp,%ecx,4),%esi
   lea (%esp,%ecx,4),%edi
   std
   rep movsd
   cld
   mov %edx,%esi
   movl %ebx,(%esp)
   NEXT

/* ( 0 -- 0 ) */
/* ( a -- a a ) */
defcode QDUP,"?DUP"
   movl (%esp),%eax
   test %eax,%eax
   jz 1f
   push %eax
1: NEXT

/* ( 0 -- 0 0 ) */
/* ( a -- a ) */
defcode QZDUP,"?0DUP"
   movl (%esp),%eax
   test %eax,%eax
   jnz 1f
   push %eax
1: NEXT

/* ( a b -- a+b ) */
defcode ADD,"+"
   pop %eax
   addl %eax,(%esp)
   NEXT

/* ( a b -- a-b ) */
defcode SUB,"-"
   pop %eax
   subl %eax,(%esp)
   NEXT

/* ( a -- a+1 ) */
defcode ADD1,"1+"
   incl (%esp)
   NEXT

/* ( a -- a-1 ) */
defcode SUB1,"1-"
   decl (%esp)
   NEXT

/* ( x1 -- x2 ) Two's complement of x1 */
defcode NEGATE
   negl (%esp)
   NEXT

/* ( n -- u ) Absolute value */
defcode ABS
   pop %eax
   test %eax,%eax
   jnl 0f
   neg %eax
0: push %eax
   NEXT

/* ( n1|u1 n2|u2 -- n3|u3 ) Multiply (signed or unsigned) */
defcode MUL,"*"
   pop %eax
   pop %ebx
   imull %ebx,%eax
   push %eax
   NEXT

/* ( n1 n2 -- d ) Multiply signed, producting a double-cell result */
defcode MMUL,"M*"
   pop %eax
   pop %ebx
   imull %ebx,%eax
   push %eax
   push %edx
   NEXT

/* ( u1 u2 -- ud ) Multiply unsigned, producting a double-cell result */
defcode UMMUL,"UM*"
   pop %eax
   pop %ebx
   mull %ebx
   push %eax
   push %edx
   NEXT

/* ( n -- d ) Convert a single-cell signed integer to a double-cell integer */
defcode STOD,"S>D"
   movl (%esp),%eax
   cltd
   push %edx
   NEXT

/* ( d1|ud1 d2|ud2 -- d3|ud3 ) Double-cell addition */
defcode DADD,"D+"
   pop %ebx
   pop %eax
   addl %eax,4(%esp)
   adcl %ebx,(%esp)
   NEXT

/* ( d1|ud1 d2|ud2 -- d3|ud3 ) Double-cell subtraction */
defcode DSUB,"D-"
   pop %ebx
   pop %eax
   subl %eax,4(%esp)
   sbbl %ebx,(%esp)
   NEXT

/* ( d1|ud1 d2|ud2 -- d3|ud3 ) Double-cell multiplication */
defcode DMUL,"D*"
   pop %ecx
   pop %eax
   pop %ebx
   pop %edx
   imul %edx,%ecx
   imul %eax,%ebx
   mul %edx
   add %ebx,%ecx
   add %ecx,%edx
   push %eax
   push %edx
   NEXT

defcode DNEGATE
   notl 4(%esp)
   notl (%esp)
   addl $1,4(%esp)
   adcl $0,(%esp)
   NEXT

/* ( d1 +n1 -- n-remainder d-quotient ) Flooring division with remainder */
/* NOTE: ANS FORTH has the quotient as a single-cell value (with potential overflow) */
/* WARNING: This implementation does not handle negative divisors (just dividends) */
defcode FMDIVMOD,"FM/MOD"
   pop %ebx  /* divisor */
   pop %eax  /* upper 32 bits of dividend */
   cdq
   idivl %ebx
   test %edx,%edx
   jns 0f
   dec %eax
   add %ebx,%edx
0: mov %eax,%ecx
   pop %eax  /* lower 32 bits of dividend */
   div %ebx
   push %edx  /* modulus */
   push %eax  /* lower 32 bits of quotient */
   push %ecx  /* upper 32 bits of quotient */
   NEXT

/* ( ud1 u1 -- u-modulus ud-quotient ) Unsigned division with remainder */
/* NOTE: ANS FORTH has the quotient as a single-cell value (with potential overflow) */
defcode UMDIVMOD,"UM/MOD"
   pop %ebx
   pop %edx
   cmp %ebx,%edx
   jae 1f
   xor %ecx,%ecx
0: pop %eax
   divl %ebx
   push %edx
   push %eax
   push %ecx
   NEXT
1: mov %edx,%eax
   xor %edx,%edx
   divl %ebx
   mov %eax,%ecx
   jmp 0b

/* ( n1 n2 n3 -- (n1*n2)%n3 (n1*n2)/n3 ) */
/* Equivalent to >R M* R> SM/MOD S>D */
/* Note: The intermediate value between multiplication and division is 64 bits */
defcode MULDIVMOD,"*/MOD"
   pop %ecx
   pop %ebx
   pop %eax
   imull %ebx
   idivl %ecx
   push %edx
   push %eax
   NEXT

/* Same as MULDIVMOD but for unsigned inputs */
/* Equivalent to >R UM* R> UM/MOD DROP */
defcode UMULDIVMOD,"U*/MOD"
   pop %ecx
   pop %ebx
   pop %eax
   mull %ebx
   divl %ecx
   push %edx
   push %eax
   NEXT

/* ( x1 -- x2 ) Shift left by one bit */
defcode TWOMUL,"2*"
   shll $1,(%esp)
   NEXT

/* ( n1 -- n2 ) Arithmetic (signed) shift right by one bit */
defcode TWODIV,"2/"
   sarl $1,(%esp)
   NEXT

/* ( u1 -- u2 ) Logical (unsigned) shift right by one bit */
defcode UTWODIV,"U2/"
   shrl $1,(%esp)
   NEXT

defcode DTWOMUL,"D2*"
   shll $1,4(%esp)
   rcll $1,(%esp)
   NEXT

defcode DTWODIV,"D2/"
   sarl $1,(%esp)
   rcrl $1,4(%esp)
   NEXT

defcode DUTWODIV,"DU2/"
   shrl $1,(%esp)
   rcrl $1,4(%esp)
   NEXT

/* ( x1 u -- x2 ) Shift left by u bits */
defcode LSHIFT
   pop %ecx
   cmp $32,%ecx
   jae 1f
   shll %cl,(%esp)
   NEXT
1: movl $0,(%esp)
   NEXT

/* ( u1 u -- u2 ) Logical (unsigned) shift right by u bits */
defcode RSHIFT
   pop %ecx
   cmp $32,%ecx
   jae 1f
   shrl %cl,(%esp)
   NEXT
1: movl $0,(%esp)
   NEXT

/* ( xd1 u -- xd2 ) Shift left by u bits */
defcode DLSHIFT
   pop %ecx
   cmp $32,%ecx
   jae 1f
   movl 4(%esp),%eax
   shldl %cl,%eax,(%esp)
   shll %cl,4(%esp)
   NEXT
1: pop %ebx
   pop %eax
   xor %ebx,%ebx
   cmp $64,%ecx
   jae 2f
   shl %cl,%eax
   push %ebx
   push %eax
   NEXT
2: push %ebx
   push %ebx
   NEXT

/* ( ud1 u -- ud2 ) Logical (unsigned) shift right by u bits */
defcode DRSHIFT
   pop %ecx
   cmp $32,%ecx
   jae 1f
   movl (%esp),%eax
   shrdl %cl,%eax,4(%esp)
   shrl %cl,(%esp)
   NEXT
1: pop %ebx
   pop %eax
   xor %eax,%eax
   cmp $64,%ecx
   jae 2f
   shr %cl,%ebx
   push %ebx
   push %eax
   NEXT
2: push %eax
   push %eax
   NEXT


.macro defzcmp label,ncc,name="\label",flags=0
defcode \label,"\name",0,\flags
   pop %eax
   xor %edi,%edi
   test %eax,%eax
   j\ncc 0f
   dec %edi
0: push %edi
   NEXT
.endm

/* ( n|u -- flag ) Equality operators with implicit zero, e.g. flag=d==0 */
defzcmp ZEQU,ne,"0="
defzcmp ZNEQU,e,"0<>"

/* ( n -- flag ) Signed relational operators with implicit zero, e.g. flag=d<0 */
defzcmp ZLT,nl,"0<"
defzcmp ZGT,ng,"0>"
defzcmp ZLE,nle,"0<="
defzcmp ZGE,nge,"0>="

.macro defdzcmp label,ncc,name="\label",flags=0
defcode \label,"\name",0,\flags
   pop %ebx
   pop %eax
   xor %edi,%edi
   sub $0,%ebx
   sbb $0,%eax
   j\ncc 0f
   dec %edi
0: push %edi
   NEXT
.endm

/* ( d|ud -- flag ) Double-cell equality operators with implicit zero */
defdzcmp DZEQU,ne,"D0="
defdzcmp DZNEQU,e,"D0<>"

/* ( d -- flag ) Double-cell signed relational operators with implicit zero */
defdzcmp DZLT,nl,"D0<"
defdzcmp DZGT,ng,"D0>"
defdzcmp DZLE,nle,"D0<="
defdzcmp DZGE,nge,"D0>="

.macro defcmp label,ncc,name="\label",flags=0
defcode \label,"\name",0,\flags
   pop %eax
   pop %ebx
   xor %edi,%edi
   cmp %eax,%ebx
   j\ncc 0f
   dec %edi
0: push %edi
   NEXT
.endm

/* ( n1|u1 n2|u2 -- flag ) Equality operators */
defcmp EQU,ne,"="
defcmp NEQU,e,"<>"

/* ( n1 n2 -- flag ) Signed relational operators */
defcmp LT,nl,"<"
defcmp GT,ng,">"
defcmp LE,nle,"<="
defcmp GE,nge,">="

/* ( u1 u2 -- flag ) Unsigned relational operators */
defcmp ULT,nb,"U<"
defcmp UGT,na,"U>"
defcmp ULE,nbe,"U<="
defcmp UGE,nae,"U>="

.macro defdcmp label,ncc,name="\label",flags=0
defcode \label,"\name",0,\flags
   pop %edx
   pop %ecx
   pop %ebx
   pop %eax
   xor %edi,%edi
   sub %edx,%ebx
   sbb %ecx,%eax
   j\ncc 0f
   dec %edi
0: push %edi
   NEXT
.endm

/* ( d1|ud1 d2|ud2 -- flag ) Double-cell equality operators */
defdcmp DEQU,ne,"D="
defdcmp DNEQU,e,"D<>"

/* ( d1 d2 -- flag ) Double-cell signed relational operators */
defdcmp DLT,nl,"D<"
defdcmp DGT,ng,"D>"
defdcmp DLE,nle,"D<="
defdcmp DGE,nge,"D>="

/* ( ud1 ud2 -- flag ) Double-cell unsigned relational operators */
defdcmp DULT,nb,"DU<"
defdcmp DUGT,na,"DU>"
defdcmp DULE,nbe,"DU<="
defdcmp DUGE,nae,"DU>="

defcode AND
   pop %eax
   andl %eax,(%esp)
   NEXT

defcode OR
   pop %eax
   orl %eax,(%esp)
   NEXT

defcode XOR
   pop %eax
   xorl %eax,(%esp)
   NEXT

defcode INVERT
   notl (%esp)
   NEXT

defcode STOREBYTE,"C!"
   pop %ebx
   pop %eax
   movb %al,(%ebx)
   NEXT

defcode FETCHBYTE,"C@"
   pop %ebx
   xor %eax,%eax
   movb (%ebx),%al
   push %eax
   NEXT

defcode STORE,"!"
   pop %ebx
   popl (%ebx)
   NEXT

defcode FETCH,"@"
   pop %ebx
   pushl (%ebx)
   NEXT

defcode INCREMENT,"+!"
   pop %ebx
   pop %eax
   addl %eax,(%ebx)
   NEXT

defcode DECREMENT,"-!"
   pop %ebx
   pop %eax
   subl %eax,(%ebx)
   NEXT

/* ( x1 a-addr -- x2 ) Store x1 in the cell at a-addr and return the old value */
defcode XCHG
   pop %eax
   mov (%eax),%ebx
   popl (%eax)
   push %ebx
   NEXT

/* ( a-addr1 a-addr2 -- ) Swap the values in two memory locations */
defcode EXCHANGE
   pop %ebx
   pop %eax
   mov (%eax),%ecx
   mov (%ebx),%edx
   mov %ecx,(%ebx)
   mov %edx,(%eax)
   NEXT

defcode TWOSTORE,"2!"
   pop %ebx
   popl (%ebx)
   popl 4(%ebx)
   NEXT

defcode TWOFETCH,"2@"
   pop %ebx
   pushl 4(%ebx)
   pushl (%ebx)
   NEXT

/* ( xd1 a-addr -- xd2 ) Store xd1 in the double-cell a-addr; return the old value */
/* Equivalent to: DUP 2@ 2>R 2! 2R> */
defcode TWOXCHG,"2XCHG"
   pop %eax
   mov 4(%eax),%ebx
   mov (%eax),%ecx
   popl (%eax)
   popl 4(%eax)
   push %ebx
   push %ecx
   NEXT

/* ( c-addr u char -- ) Fill u characters starting at c-addr with char */
defcode FILL
   pop %eax
   pop %ecx
   pop %edi
   rep stosb
   NEXT

/* ( xu ... x1 n a-addr -- ) Store x1 through xn in ascending cells at a-addr */
defcode NSTORE,"N!"
   mov %esi,%edx
   pop %edi
   pop %ecx
   mov %esp,%esi
   lea (%esp,%ecx,4),%esp
   rep movsd
   mov %edx,%esi
   NEXT

/* ( n a-addr -- xu ... x1 ) Load x1 through xn from ascending cells at a-addr */
defcode NFETCH,"N@"
   mov %esi,%edx
   pop %esi
   pop %ecx
   mov %ecx,%ebx
   neg %ebx
   lea (%esp,%ebx,4),%esp
   mov %esp,%edi
   rep movsd
   mov %edx,%esi
   NEXT

/* ( src dst n -- ) Block copy n bytes from src to dst (ascending addresses) */
defcode CMOVE
   mov %esi,%edx
   pop %ecx
   pop %edi
   pop %esi
   rep movsb
   mov %edx,%esi
   NEXT

/* ( src dst n -- ) Block copy n bytes from src to dst (descending addresses) */
defcode CMOVE_UP,"CMOVE>"
   mov %esi,%edx
   pop %ecx
   pop %edi
   pop %esi
   lea -1(%edi,%ecx),%edi
   lea -1(%esi,%ecx),%esi
   std
   rep movsb
   cld
   mov %edx,%esi
   NEXT

/* ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 ) Lexically compare two strings */
defcode COMPARE
   mov %esi,%edx
   mov (%esp),%ecx
   mov 8(%esp),%ebx
   xor %eax,%eax
   cmp %ebx,%ecx
   jbe 1f
   mov %ebx,%ecx
1: mov 12(%esp),%esi
   mov 4(%esp),%edi
   repe cmpsb
   je 3f
2: seta %al
   shl $1,%eax
   dec %eax
   jmp 4f
3: cmp (%esp),%ebx
   jne 2b
4: add $16,%esp
   push %eax
   mov %edx,%esi
   NEXT

/* ( a -- ) ( R: -- a ) */
defcode TOR,">R"
   pop %eax
   PUSHRSP %eax
   NEXT

/* ( R: a -- ) ( -- a ) */
defcode FROMR,"R>"
   POPRSP %eax
   push %eax
   NEXT

/* ( R: a -- a ) ( -- a ) */
defcode RFETCH,"R@"
   pushl (%ebp)
   NEXT

/* ( R: xu ... x0 -- xu ... x0 ) ( S: u -- xu ) */
defcode RPICK
   pop %eax
   pushl (%ebp,%eax,4)
   NEXT

/* ( a b -- ) ( R: -- a b ) */
defcode TWOTOR,"2>R"
   pop %ebx
   pop %eax
   PUSHRSP %eax
   PUSHRSP %ebx
   NEXT

/* ( R: a b -- ) ( -- a b ) */
defcode TWOFROMR,"2R>"
   POPRSP %ebx
   POPRSP %eax
   push %eax
   push %ebx
   NEXT

/* ( R: a b -- a b ) ( -- a b ) */
defcode TWORFETCH,"2R@"
   pushl 4(%ebp)
   pushl (%ebp)
   NEXT

/* ( xu ... x1 u -- ) ( R: -- xu ... x1 u ) */
defcode NTOR,"N>R"
   mov %esi,%edx
   movl (%esp),%ecx
   add $1,%ecx
   mov %ecx,%ebx
   shl $2,%ebx
   sub %ebx,%ebp
   mov %esp,%esi
   mov %ebp,%edi
   rep movsd
   mov %esi,%esp
   mov %edx,%esi
   NEXT

/* ( R: xu ... x1 u -- ) ( -- xu ... x1 u ) */
defcode NFROMR,"NR>"
   mov %esi,%edx
   movl (%ebp),%ecx
   add $1,%ecx
   mov %ecx,%ebx
   shl $2,%ebx
   sub %ebx,%esp
   mov %ebp,%esi
   mov %esp,%edi
   rep movsd
   mov %esi,%ebp
   mov %edx,%esi
   NEXT

/* ( R: xu ... x1 u -- xu ... x1 u ) ( -- xu ... x1 u ) */
defcode NRFETCH,"NR@"
   mov %esi,%edx
   movl (%ebp),%ecx
   add $1,%ecx
   mov %ecx,%ebx
   shl $2,%ebx
   sub %ebx,%esp
   mov %ebp,%esi
   mov %esp,%edi
   rep movsd
   mov %edx,%esi
   NEXT

/* ( -- a-addr ) */
defcode RSPFETCH,"RSP@"
   push %ebp
   NEXT

/* ( a-addr -- ) */
defcode RSPSTORE,"RSP!"
   pop %ebp
   NEXT

/* ( R: x -- ) */
defcode RDROP
   addl $4,%ebp
   NEXT

/* ( R: a b -- ) */
defcode TWORDROP,"2RDROP"
   addl $8,%ebp
   NEXT

/* ( R: xn ... x1 n -- ) */
defcode NRDROP
   POPRSP %eax
   lea (%ebp,%eax,4),%ebp
   NEXT

/* ( -- a-addr ) Get the data stack pointer (address of cell below a-addr) */
defcode SPFETCH,"SP@"
   push %esp
   NEXT

/* ( a-addr -- ) Set the data stack pointer */
defcode SPSTORE,"SP!"
   pop %esp
   NEXT

defcode LIT
   lodsl
   push %eax
   NEXT

defcode TWOLIT,"2LIT"
   lodsl
   mov %eax,%ebx
   lodsl
   push %eax
   push %ebx
   NEXT

defcode LITSTRING
   xor %eax,%eax
   lodsb
   push %esi
   push %eax
   lea 3(%esi,%eax),%esi
   andl $-4,%esi
   NEXT

defcode BRANCH
   add (%esi),%esi
   NEXT

defcode ZBRANCH,"0BRANCH"
   pop %eax
   test %eax,%eax
   jz code_BRANCH
   lodsl
   NEXT

.macro deflocals idx:req,fetch_label:req,fetch_name:req,store_label:req,store_name:req
defcode \fetch_label,\fetch_name
   pushl ((\idx + 1) * 4)(%ebp)
   NEXT
defcode \store_label,\store_name
   popl ((\idx + 1) * 4)(%ebp)
   NEXT
.endm

deflocals 0,FETCH_L0,"L0@",STORE_L0,"L0!"
deflocals 1,FETCH_L1,"L1@",STORE_L1,"L1!"
deflocals 2,FETCH_L2,"L2@",STORE_L2,"L2!"
deflocals 3,FETCH_L3,"L3@",STORE_L3,"L3!"
deflocals 4,FETCH_L4,"L4@",STORE_L4,"L4!"
deflocals 5,FETCH_L5,"L5@",STORE_L5,"L5!"
deflocals 6,FETCH_L6,"L6@",STORE_L6,"L6!"
deflocals 7,FETCH_L7,"L7@",STORE_L7,"L7!"

defcode EXIT
   POPRSP %esi
   NEXT

defcode EXECUTE
   pop %eax
   jmp *(%eax)

/* ( x1 -- x2 ) Compute a non-cryptographic 32-bit hash of a 32-bit cell */
/* Adapted from Bob Jenkins's "4-byte integer hash, full avalanche"      */
/* hashint() algorithm <http://burtleburtle.net/bob/hash/integer.html>.  */
/* This is intended for use in hash tables and coded in assembly for performance */
defcode HASHCELL
   pop %eax
   mov %eax,%ebx; shl  $6,%ebx; sub %ebx,%eax
   mov %eax,%ebx; shr $17,%ebx; xor %ebx,%eax
   mov %eax,%ebx; shl  $9,%ebx; sub %ebx,%eax
   mov %eax,%ebx; shl  $4,%ebx; xor %ebx,%eax
   mov %eax,%ebx; shl  $3,%ebx; sub %ebx,%eax
   mov %eax,%ebx; shl $10,%ebx; xor %ebx,%eax
   mov %eax,%ebx; shr $15,%ebx; xor %ebx,%eax
   push %eax
   NEXT

/* ( ebx ecx edx esi edi ebp eax/sc -- eax/result ) */
defcode SYSCALL6
   mov %ebp,%ecx
   mov %esi,%ebx
   pop %eax
   pop %ebp
   pop %edi
   pop %esi
   pop %edx
   xchg %ecx,(%esp)
   xchg %ebx,4(%esp)
   int $0x80
   pop %ebp
   pop %esi
   push %eax
   NEXT

/* ( ebx ecx edx esi edi eax/sc -- eax/result ) */
defcode SYSCALL5
   mov %esi,%ebx
   pop %eax
   pop %edi
   pop %esi
   pop %edx
   pop %ecx
   xchg %ebx,(%esp)
   int $0x80
   pop %esi
   push %eax
   NEXT

/* ( ebx ecx edx esi eax/sc -- eax/result ) */
defcode SYSCALL4
   mov %esi,%edi
   pop %eax
   pop %esi
   pop %edx
   pop %ecx
   pop %ebx
   int $0x80
   mov %edi,%esi
   push %eax
   NEXT

/* ( ebx ecx edx eax/sc -- eax/result ) */
defcode SYSCALL3
   pop %eax
   pop %edx
   pop %ecx
   pop %ebx
   int $0x80
   push %eax
   NEXT

/* ( ebx ecx eax/sc -- eax/result ) */
defcode SYSCALL2
   pop %eax
   pop %ecx
   pop %ebx
   int $0x80
   push %eax
   NEXT

/* ( ebx eax/sc -- eax/result ) */
defcode SYSCALL1
   pop %eax
   pop %ebx
   int $0x80
   push %eax
   NEXT

/* ( eax/sc -- eax/result ) */
defcode SYSCALL0
   pop %eax
   int $0x80
   push %eax
   NEXT

/* No runtime effect, but this code address can be used for debugger breakpoints */
defcode BREAK
   NEXT

/* This marks the start of the bootstrap word list */
.eqv last_primitive,BREAK
.set link,0

   .section .data
bootstrap_data_begin:

/* The word list containing all the primitive words */
defvar PRIMITIVE_WORDLIST,last_primitive,"PRIMITIVE-WORDLIST"

/* The list of basic non-primitive words used to bootstrap the startup.4th file */
defvar BOOTSTRAP_WORDLIST,last_word,"BOOTSTRAP-WORDLIST"

defdefer BOOTSTRAP_ALLOT,ALLOT,"BOOTSTRAP-ALLOT"
defdefer BOOTSTRAP_GET_ORDER,GET_ORDER,"BOOTSTRAP-GET-ORDER"
defdefer BOOTSTRAP_PARSENUMBER,PARSENUMBER,"BOOTSTRAP-PARSENUMBER"

/* ( c-addr u -- "ccc" ) */
defword TYPE,,F_HIDDEN
   .int LIT,1,NROT,LIT,__NR_write,SYSCALL3,DROP,EXIT

/* ( c -- "c" ) */
defword EMIT,,F_HIDDEN
   .int SPFETCH,LIT,1,SWAP,LIT,1,LIT,__NR_write,SYSCALL3,TWODROP,EXIT

/* ( -- "<eol>" ) */
defword EOL,,F_HIDDEN
   .int LIT,10,EMIT,EXIT

/* Used for any fatal errors that occur during bootstrapping */
defword BAILOUT
   .int BREAK
   litstring "Fatal error\n"
   .int TYPE
0: .int LIT,254,LIT,__NR_exit,SYSCALL1,DROP,BRANCH,(0b - .)
   .int EXIT /* just to mark the end */

defword UNEXPECTED_EOF,"UNEXPECTED-EOF",F_HIDDEN
   litstring "Unexpected end of input\n"
   .int TYPE,BAILOUT,EXIT

/* During bootstrapping the source buffer is the embedded file "startup.4th". */
/* ( -- c-addr u ) */
defword SOURCE
   .int LIT,startup_defs,LIT,(startup_defs_end - startup_defs),EXIT

/* ( -- c-addr u ) Current parse area (input buffer minus first >IN characters) */
defword PARSE_AREA,"PARSE-AREA",F_HIDDEN
   .int SOURCE,IN,FETCH,ROT,OVER,ADD,NROT,SUB,EXIT

/* ( "c" -- c ) Leaves c at the start of the parse area */
defword PEEK_CHAR,"PEEK-CHAR",F_HIDDEN
   .int PARSE_AREA,ZBRANCH,(0f - .),FETCHBYTE,EXIT
0: .int UNEXPECTED_EOF,EXIT

/* ( "c" -- c ) Removes and returns the first character in the parse area */
defword NEXT_CHAR,"NEXT-CHAR",F_HIDDEN
   .int PEEK_CHAR,LIT,1,IN,INCREMENT,EXIT

/* ( c -- flag ) */
defword ISSPACE,"SPACE?",F_HIDDEN
   /* check for space (32) first and return true if input matches */
   .int DUP,LIT,32,EQU,QDUP,ZBRANCH,(0f - .),NIP,EXIT
   /* otherwise test for 9...13 inclusive (HT, LF, VT, FF, CR) */
0: .int LIT,9,SUB,LIT,(13 - 9),ULT,EXIT

/* Simplified version that can only work within the preallocated data region */
/* The startup.4th should replace this with a more complete version */
defword ALLOT
   .int CP,INCREMENT,EXIT

defword HERE,,F_HIDDEN
   .int CP,FETCH,EXIT

defword COMMA,","
   .int HERE,CELL,BOOTSTRAP_ALLOT,STORE,EXIT

defword COMMABYTE,"C,",F_HIDDEN
   .int HERE,LIT,1,BOOTSTRAP_ALLOT,STOREBYTE,EXIT

/* ( addr -- a-addr ) Round up to next cell-aligned address */
defword ALIGNED,,F_HIDDEN
   .int LIT,3,ADD,LIT,-4,AND,EXIT

/* ( -- ) Allocate data space up to the next cell-aligned address */
/* Any bytes skipped over during alignment should be considered uninitialized */
defword ALIGN,,F_HIDDEN
   .int HERE,DUP,ALIGNED,SWAP,SUB,BOOTSTRAP_ALLOT,EXIT

/* ( c-addr-1 u-1 c-addr-2 u-2 -- flag ) */
defword STREQU,"=S",F_HIDDEN
   .int ROT,OVER,EQU,ZBRANCH,(1f - .)         /* c-addr-1 c-addr-2 u-2  R:           */
0: .int DUP,ZBRANCH,(2f - .)                  /* c-addr-1 c-addr-2 u    R:           */
   .int SUB1                                  /* c-addr-1 c-addr-2 u'   R:           */
   .int ROT,DUP,FETCHBYTE,TOR,ADD1            /* c-addr-2 u' c-addr-1'  R: ch-1      */
   .int ROT,DUP,FETCHBYTE,TOR,ADD1            /* u' c-addr-1' c-addr-2' R: ch-1 ch-2 */
   .int ROT,FROMR,FROMR,NEQU,ZBRANCH,(0b - .) /* c-addr-1' c-addr-2' u' R:           */
1: .int TWODROP,DROP,FALSE,EXIT               /* FALSE                  R:           */
2: .int TWODROP,DROP,TRUE,EXIT                /* TRUE                   R:           */

/* ( xt -- a-addr ) Body a.k.a. data-field address (next cell after the dataword field) */
defword TBODY,">BODY",F_HIDDEN
   .int LIT,8,ADD,EXIT

/* ( xt -- dfa-addr ) Address of the dataword field */
defword TDFA,">DFA",F_HIDDEN
   .int CELL,ADD,EXIT

/* ( xt -- cfa-addr ) Address of the codeword field */
defword TCFA,">CFA",F_HIDDEN
   .int EXIT

/* ( xt -- link-addr ) Address of the link field */
defword TLINK,">LINK",F_HIDDEN
   .int LIT,4,SUB,EXIT

/* ( xt -- flags-addr ) Address of the flag/length byte */
defword TFLAGS,">FLAGS",F_HIDDEN
   .int LIT,5,SUB,EXIT

/* ( xt -- name-addr name-len ) Address and length of the name field */
defword TNAME,">NAME",F_HIDDEN
   .int TFLAGS,DUP,FETCHBYTE,__F_LENMASK,AND,TUCK,SUB,SWAP,EXIT ;

/* ( xt -- flag ) Is the F_IMMED flag set? */
defword ISIMMEDIATE,"IMMEDIATE?",F_HIDDEN
   .int TFLAGS,FETCHBYTE,__F_IMMED,AND,ZNEQU,EXIT

/* ( xt -- flag ) Is the F_HIDDEN flag set? */
defword ISHIDDEN,"HIDDEN?",F_HIDDEN
   .int TFLAGS,FETCHBYTE,__F_HIDDEN,AND,ZNEQU,EXIT

/* ( xt -- flag ) Is the xt a non-primitive bootstrap word? */
defword ISBOOTSTRAP,"BOOTSTRAP?",F_HIDDEN
   .int DUP,LIT,bootstrap_data_begin,UGE,ZBRANCH,(0f - .)
   .int LIT,bootstrap_data_end,ULT,EXIT
0: .int DROP,FALSE,EXIT

/* ( -- widn ... wid1 n ) Return the current search order */
/* Redefining this word with DEFER! will change the bootstrap search order */
defword GET_ORDER,"GET-ORDER",F_HIDDEN
   .int BOOTSTRAP_WORDLIST,PRIMITIVE_WORDLIST,CURRENT,FETCH,LIT,3,EXIT

/* ( c-addr u wid -- 0 | xt 1 | xt -1 ) */
/* 0 = not found; 1 = non-immediate; -1 = immediate */
defword SEARCH_WORDLIST,"SEARCH-WORDLIST"
   .int FETCH                                 /* c-addr u entry */
0: .int DUP,ZBRANCH,(4f - .)                  /* c-addr u entry */
   .int DUP,ISHIDDEN,ZBRANCH,(2f - .)         /* c-addr u entry */
1: .int TLINK,FETCH,BRANCH,(0b - .)           /* c-addr u link */
2: .int DUP,TOR,NROT,FROMR,TNAME,TWOOVER      /* entry c-addr u n-addr n-len c-addr u */
   .int STREQU,ZBRANCH,(3f - .)               /* entry c-addr u */
   .int TWODROP,DUP,ISIMMEDIATE,LIT,1,OR,EXIT /* entry 1 | entry -1 */
3: .int ROT,BRANCH,(1b - .)                   /* c-addr u entry */
4: .int NIP,NIP,EXIT                          /* 0 */

/* ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) */
defword FIND,,F_HIDDEN
   .int TWOTOR,BOOTSTRAP_GET_ORDER
0: .int DUP,ZBRANCH,(1f - .)
   .int SUB1,SWAP,TWORFETCH,ROT,SEARCH_WORDLIST,QDUP,ZBRANCH,(0b - .)
   .int TWORDROP,TWOTOR,NDROP,TWOFROMR,EXIT
1: .int TWOFROMR,ROT,EXIT

/* ( c-addr u -- xt 1 | xt -1 ) */
defword FIND_OR_BAILOUT,"FIND-OR-BAILOUT",F_HIDDEN
   .int FIND,QDUP,ZBRANCH,(0f - .),EXIT
0: litstring "Word not found: "
   .int TYPE,TYPE,EOL,BAILOUT,EXIT

/* ( "<spaces>" -- ) */
defword SKIP_SPACE,"SKIP-SPACE",F_HIDDEN
0: .int PARSE_AREA,ZBRANCH,(1f - .)
   .int FETCHBYTE,ISSPACE,ZBRANCH,(2f - .)
   .int LIT,1,IN,INCREMENT,BRANCH,(0b - .)
1: .int DROP
2: .int EXIT

/* ( "<spaces?>ccc<space>" -- c-addr u ) */
defword PARSE_NAME,"PARSE-NAME",F_HIDDEN
   .int SKIP_SPACE
   .int PARSE_AREA,DROP,LIT,1
   .int NEXT_CHAR,DROP
0: .int PARSE_AREA,ZBRANCH,(1f - .)
   .int FETCHBYTE,ISSPACE,ZEQU,ZBRANCH,(2f - .)
   .int ADD1,LIT,1,IN,INCREMENT,BRANCH,(0b - .)
1: .int DROP
2: .int EXIT

defword ESCAPED_CHAR,,F_HIDDEN
   .int NEXT_CHAR,DUP,LIT,'\\',NEQU,ZBRANCH,(0f - .),EXIT
0: .int DROP,NEXT_CHAR
   .int LIT,'0',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,0,EXIT
0: .int LIT,'a',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,7,EXIT
0: .int LIT,'b',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,8,EXIT
0: .int LIT,'t',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,9,EXIT
0: .int LIT,'n',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,10,EXIT
0: .int LIT,'v',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,11,EXIT
0: .int LIT,'f',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,12,EXIT
0: .int LIT,'r',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,13,EXIT
0: .int LIT,34,OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,34,EXIT /* double-quote */
0: .int LIT,39,OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,39,EXIT /* single-quote */
0: .int LIT,92,OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,92,EXIT /* backslash */
0: litstring "Unknown escape sequence: \\"
   .int TYPE,EMIT,EOL,BAILOUT,EXIT

/* ( "ccc<quote>" -- c-addr u ) */
defword READSTRING,,F_HIDDEN
   .int HERE
0: .int PEEK_CHAR,LIT,34,NEQU,ZBRANCH,(1f - .)
   .int ESCAPED_CHAR,COMMABYTE,BRANCH,(0b - .)
1: .int LIT,1,IN,INCREMENT,HERE,OVER,SUB,ALIGN,EXIT

defword PARSENUMBER,,F_HIDDEN
   .int DUP,LIT,0,GT,ZBRANCH,(7f - .)
   .int OVER,FETCHBYTE,LIT,'-',EQU,DUP,TOR,LIT,0,TOR,ZBRANCH,(0f - .)
   .int DUP,LIT,1,GT,ZBRANCH,(6f - .),BRANCH,(1f - .)
0: .int OVER,FETCHBYTE,LIT,'0',SUB
   .int DUP,LIT,9,ULE,ZBRANCH,(5f - .)
   .int FROMR,LIT,10,MUL,ADD,TOR
1: .int SUB1,QDUP,ZBRANCH,(8f - .)
   .int SWAP,ADD1,SWAP,BRANCH,(0b - .)
5: .int DROP
6: .int RDROP,RDROP
7: .int TWODROP,LIT,0,EXIT
8: .int DROP,FROMR,FROMR,ZBRANCH,(9f - .)
   .int NEGATE
9: .int LIT,1,EXIT

defword INTERPRET,,F_HIDDEN
   .int SKIP_SPACE
   .int PEEK_CHAR,LIT,34,EQU,ZBRANCH,(1f - .)
   .int   LIT,1,IN,INCREMENT
   .int   STATE,FETCH,ZBRANCH,(0f - .)
   .int     LIT,LITSTRING,COMMA,HERE,LIT,0,COMMABYTE
   .int     READSTRING,ROT,STOREBYTE,DROP,ALIGN,EXIT
   /*     ELSE */
   litstring "Tried to interpret a string literal\n"
   .int     TYPE,BAILOUT
   /*   ELSE */
1: .int   PARSE_NAME,TWOTOR
   .int   TWORFETCH,BOOTSTRAP_PARSENUMBER,QDUP,ZBRANCH,(4f - .)
   .int     TWORDROP,STATE,FETCH,ZEQU,ZBRANCH,(2f - .)
   .int       DROP,EXIT
   /*       ELSE-IF */
2: .int     LIT,2,EQU,ZBRANCH,(3f - .)
   .int       LIT,TWOLIT,COMMA,COMMA,COMMA,EXIT
   /*       ELSE */
3: .int       LIT,LIT,COMMA,COMMA,EXIT
   /*     ELSE */
4: .int     TWOFROMR,FIND_OR_BAILOUT,DROP
   .int     STATE,FETCH,ZBRANCH,(5f - .)
   /*       ( OR ) */
   .int     DUP,ISIMMEDIATE,ZBRANCH,(6f - .)
5: .int       EXECUTE,EXIT
   /*       ELSE */
6: .int       DUP,ISBOOTSTRAP,ZBRANCH,(7f - .)
   litstring "Tried to compile bootstrap word: "
   .int       TYPE,TNAME,TYPE,EOL,BAILOUT
7: .int       COMMA,EXIT

defword QUIT,,F_HIDDEN
   .int R0,RSPSTORE
0: .int INTERPRET,BRANCH,(0b - .)
   .int EXIT

defword LATEST,,F_HIDDEN
   .int CURRENT,FETCH,FETCH,EXIT

defword COMMANAME,"NAME,",F_HIDDEN
   .int TUCK,ALIGN,HERE,OVER,ADD,ADD1,NEGATE,CELL,SUB1,AND,BOOTSTRAP_ALLOT
   .int HERE,OVER,BOOTSTRAP_ALLOT,SWAP,CMOVE,COMMABYTE,EXIT

/* CREATE depends on various bootstrap words */
defword CREATE
   .int PARSE_NAME,COMMANAME,LATEST,COMMA
   .int HERE,CURRENT,FETCH,STORE
   .int __DODATA,COMMA,HERE,CELL,ADD,COMMA,EXIT

/*
** These next few words aren't strictly necessary for bootstrapping but
** do make the early parts of the startup.4th file much more readable.
*/

defword LBRACKET,"[",F_IMMED
   .int FALSE,STATE,STORE,EXIT

defword RBRACKET,"]",F_IMMED
   .int TRUE,STATE,STORE,EXIT

defword BACKSLASH,"\\",F_IMMED
0: .int NEXT_CHAR,LIT,10,EQU,ZBRANCH,(0b - .),EXIT

defword OPENPAREN,"(",F_IMMED
0: .int NEXT_CHAR,LIT,')',EQU,ZBRANCH,(0b - .),EXIT

defword COLON,":"
   /* Make word & fetch address */
   .int CREATE
   /* Set as hidden */
   .int LATEST,TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,OR,SWAP,STOREBYTE
   /* Convert to DOCOL codeword */
   .int __DOCOL,LATEST,TCFA,STORE
   /* Enter compilation mode */
   .int TRUE,STATE,STORE,EXIT

defword SEMI,";",F_IMMED
   /* Terminate the code with EXIT */
   .int LIT,EXIT,COMMA
   /* Fetch the address of the latest definition */
   .int LATEST
   /* Clear the F_HIDDEN flag */
   .int TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,INVERT,AND,SWAP,STOREBYTE
   /* Leave compilation mode */
   .int FALSE,STATE,STORE,EXIT

defword CONSTANT
   .int CREATE,LATEST,TDFA,STORE,EXIT

/* ( target-xt deferred-xt -- ) */
defword DEFERSTORE,"DEFER!"
   .int __DODEFER,OVER,TCFA,STORE,TDFA,STORE,EXIT

/* ( "<spaces>ccc" -- ) */
defword DEFER
   .int CREATE,LIT,BAILOUT,LATEST,DEFERSTORE,EXIT

defword QUOTE,"'"
   .int PARSE_NAME,FIND_OR_BAILOUT,DROP,EXIT

defword LITERAL,,F_IMMED
   .int LIT,LIT,COMMA,COMMA,EXIT

defword CHAR
   .int PARSE_NAME,DROP,FETCHBYTE,EXIT

defword POSTPONE,,F_IMMED
   .int PARSE_NAME,FIND_OR_BAILOUT,ZGT,ZBRANCH,(0f - .)
   .int LITERAL
   /* this would compile bootstrap COMMA into the definition */
   /* .int LITERAL,LIT,COMMA,COMMA,EXIT */
   /* instead, try to use whichever COMPILE, is currently in scope */
   /* and fail if no COMPILE, is available */
   litstring "COMPILE,"
   .int FIND,ZEQU,ZBRANCH,(0f - .)
   litstring "POSTPONE used on non-immediate word without COMPILE,: "
   .int TYPE,TWODROP,TNAME,TYPE,EOL,BAILOUT
0: .int DUP,ISBOOTSTRAP,ZBRANCH,(1f - .)
   litstring "POSTPONE used on bootstrap word: "
   .int TYPE,TNAME,TYPE,EOL,BAILOUT
1: .int COMMA,EXIT

defword AHEAD,,F_IMMED
   .int LIT,BRANCH,COMMA,HERE,LIT,0,COMMA,EXIT

defword IF,,F_IMMED
   .int LIT,ZBRANCH,COMMA,HERE,LIT,0,COMMA,EXIT

defword THEN,,F_IMMED
   .int HERE,OVER,SUB,SWAP,STORE,EXIT

defword ELSE,,F_IMMED
   .int AHEAD,SWAP,THEN,EXIT

defword BEGIN,,F_IMMED
   .int HERE,EXIT

defword AGAIN,,F_IMMED
   .int LIT,BRANCH,COMMA,HERE,SUB,COMMA,EXIT

defword UNTIL,,F_IMMED
   .int LIT,ZBRANCH,COMMA,HERE,SUB,COMMA,EXIT

defword WHILE,,F_IMMED
   .int IF,SWAP,EXIT

defword REPEAT,,F_IMMED
   .int AGAIN,THEN,EXIT

   .section .data
bootstrap_data_end:

/*
** End of convenience words
*/

/* This is the initial value of the BUILTIN-WORDLIST variable */
.eqv last_word,REPEAT

   .section .rodata
   .balign 4
cold_start:
   .int QUIT

   .section .startup,"a"
startup_defs:
   .incbin "startup.4th"
startup_defs_end:

   .bss
   .balign 4096
return_stack:
   .space RETURN_STACK_SIZE
return_stack_top: