/* gcc -m32 -nostdlib -static -o jumpforth jumpforth.S */ #include .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 .align 4 .globl _start _start: cld 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 .align 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 .align 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 .align 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 .align 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 .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 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: .align 4 .endm .macro defname label:req,codeword:req,dataword:req,name="",flags=0 .section .data .align 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 .align 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 .align 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 .align 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 */ /* 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 word list containing all the standard FORTH words */ /* Initially it just mirrors the primitive list */ /* The rest will be populated by the startup.4th script */ defvar FORTH_WORDLIST,last_primitive,"FORTH-WORDLIST" /* The current compilation word list, initially FORTH-WORDLIST */ defvar CURRENT,data_FORTH_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 shll %cl,(%esp) NEXT /* ( u1 u -- u2 ) Logical (unsigned) shift right by u bits */ defcode RSHIFT pop %ecx shrl %cl,(%esp) NEXT /* ( xd1 u -- xd2 ) Shift left by u bits */ defcode DLSHIFT pop %ecx movl 4(%esp),%eax shldl %cl,%eax,(%esp) shll %cl,4(%esp) NEXT /* ( ud1 u -- ud2 ) Logical (unsigned) shift right by u bits */ defcode DRSHIFT pop %ecx movl (%esp),%eax shrdl %cl,%eax,4(%esp) shrl %cl,(%esp) 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 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 /* ( 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 /* ( -- 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 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 . */ /* 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 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 /* ( -- "" ) */ 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,FORTH_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 /* ( "" -- ) */ 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 /* ( "ccc" -- 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" -- 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,FALSE,EXIT 8: .int DROP,FROMR,FROMR,ZBRANCH,(9f - .) .int NEGATE 9: .int TRUE,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,TWODUP,BOOTSTRAP_PARSENUMBER,ZBRANCH,(3f - .) .int STATE,FETCH,TWONIP,ZBRANCH,(2f - .) .int LIT,LIT,COMMA,COMMA 2: .int EXIT /* ELSE */ 3: .int FIND_OR_BAILOUT,DROP .int STATE,FETCH,ZBRANCH,(4f - .) /* ( OR ) */ .int DUP,ISIMMEDIATE,ZBRANCH,(5f - .) 4: .int EXECUTE,EXIT /* ELSE */ 5: .int DUP,ISBOOTSTRAP,ZBRANCH,(6f - .) litstring "Tried to compile bootstrap word: " .int TYPE,TNAME,TYPE,EOL,BAILOUT 6: .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 /* ( "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 .align 4 cold_start: .int QUIT .section .startup,"a" startup_defs: .incbin "startup.4th" startup_defs_end: .bss .align 4096 return_stack: .space RETURN_STACK_SIZE return_stack_top: