;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; A Forth by Chris Hinsley ;; nasm -f macho forth.nasm ;; ld -o forth -e _main forth.o ;; ./forth ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; %define VERSION_NUM 30 ; various buffer area sizes %define DATA_STACK_SIZE 1024 %define USER_DEFS_SIZE (64*1024) %define NUM_HASH_CHAINS 64 %define MAX_LINE_SIZE 128 %define SYS_exit 1 %define SYS_read 3 %define SYS_write 4 %define SYS_open 5 %define SYS_close 6 %define SYS_unlink 10 %define SYS_mprotect 74 %define SYS_fsync 95 %define SYS_rename 128 %define SYS_stat 188 %define SYS_lseek 199 %define SYS_fstat 189 %define SYS_ftruncate 201 %define PROT_READ 0x01 ;pages can be read %define PROT_WRITE 0x02 ;pages can be written %define PROT_EXEC 0x04 ;pages can be executed %define PROT_ALL (PROT_READ | PROT_WRITE | PROT_EXEC) %define PAGE_SIZE 4096 ;;;;;;;;;;;;;;;;;;;;;;;;;; ; some NASM codeing macros ;;;;;;;;;;;;;;;;;;;;;;;;;; %macro loopstart 0 %push loopstart %$loop_start: %endmacro %macro break 0 jmp %$loop_exit %endmacro %macro breakif 1 j%+1 %$loop_exit %endmacro %macro loopend 0 jmp %$loop_start %$loop_exit: %pop %endmacro %macro repeat 0 %push repeat %$loop_start: %endmacro %macro until 1 j%-1 %$loop_start %$loop_exit: %pop %endmacro %macro if 1 %push if j%-1 %$ifnot %endmacro %macro else 0 %ifctx if %repl else jmp %$ifend %$ifnot: %else %error "expected `if' before `else'" %endif %endmacro %macro endif 0 %ifctx if %$ifnot: %pop %elifctx else %$ifend: %pop %else %error "expected `if' or `else' before `endif'" %endif %endmacro ;;;;;;;;;;;;;;;; ; base VM macros ;;;;;;;;;;;;;;;; ; eip Forths IP ; esp Forths R ; ebp Forths S ; ebx Forths TOS ; push on to return stack %macro PUSHRSP 1 push %1 %endm ; pop top of return stack %macro POPRSP 1 pop %1 %endm ; save into return stack %macro PUTRSP 2 %if (%2 = 0) mov [esp], %1 %elif ((%2 >= -128) && (%2 < 128)) mov [byte esp + %2], %1 %else mov [long esp + %2], %1 %endif %endm ; load from return stack %macro PICKRSP 2 %if (%2 = 0) mov %1, [esp] %elif ((%2 >= -128) && (%2 < 128)) mov %1, [byte esp + %2] %else mov %1, [long esp + %2] %endif %endm ; set return stack %macro SETRSP 1 mov esp, %1 %endm ; get return stack %macro GETRSP 1 mov %1, esp %endm ; adjust return stack %macro ADDRSP 1 %if ((%1 >= -128) && (%1 < 128)) add esp, byte %1 %else add esp, %1 %endif %endm ; push on to data stack %macro PUSHDSP 1 sub ebp, byte 4 mov [ebp], %1 %endm ; pop top of data stack %macro POPDSP 1 mov %1, [ebp] add ebp, byte 4 %endm ; save into data stack %macro PUTDSP 2 %if (%2 = 0) mov [ebp], %1 %elif ((%2 >= -128) && (%2 < 128)) mov [byte ebp + %2], %1 %else mov [long ebp + %2], %1 %endif %endm ; load from data stack %macro PICKDSP 2 %if (%2 = 0) mov %1, [ebp] %elif ((%2 >= -128) && (%2 < 128)) mov %1, [byte ebp + %2] %else mov %1, [long ebp + %2] %endif %endm ; set data stack %macro SETDSP 1 mov ebp, %1 %endm ; get data stack %macro GETDSP 1 mov %1, ebp %endm ; adjust data stack %macro ADDDSP 1 %if ((%1 >= -128) && (%1 < 128)) add ebp, byte %1 %else add ebp, %1 %endif %endm ; load value onto data stack %macro LOADTOS 1 PUSHDSP ebx mov ebx, %1 %endm ; move from data to return stack %macro TORSP 0 PUSHRSP ebx POPDSP ebx %endm ; move from return to data stack %macro FROMRSP 0 PUSHDSP ebx POPRSP ebx %endm ; copy from return to data stack %macro FETCHRSP 0 PUSHDSP ebx PICKRSP ebx, 0 %endm ; align reg %define DP_ALIGN 3 %macro ALIGNREG 1 add %1, byte DP_ALIGN and %1, byte ~DP_ALIGN %endm ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; dictionary building macros ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; format of dictionary entry flag byte %define F_IMMED 0x80 %define F_HIDDEN 0x20 %define F_LENMASK 0x1f %define NULL 0 %define H_LLINK 0 %define H_HLINK 4 %define H_NSIZE 8 %define H_NAME 9 %define XT_BODY -12 %define XT_LENGTH -8 %define XT_COMPILE -4 %define XT_SIZE 12 %macro defword 4 %push newword %strlen len %1 align 4 dic_%3: dd NULL ; LATEST list link dd NULL ; hash chain link db len + %2 ; flags + length byte db %1 ; the name dd %3 ; body pointer dd %$code_end - %3 ; code length dd %4 ; compile action word %3: %endm ; assembler code follows %macro defword_end 0 %$code_end: %pop %endm %macro defvar 4 defword %1, %2, %3, WORD_INLINE_COMMA LOADTOS var_%3 ret defword_end align 4 var_%3: dd %4 %endm %macro defvar2 5 defword %1, %2, %3, WORD_INLINE_COMMA LOADTOS var_%3 ret defword_end align 4 var_%3: dd %4 dd %5 %endm %macro defconst 4 defword %1, %2, %3, WORD_INLINE_COMMA LOADTOS %4 ret defword_end %endm ;;;;;;;;;;;;;;;;;;;;;;;;;; ; entry point ;;;;;;;;;;;;;;;;;;;;;;;;;; SECTION .text global _main _main: ; use mprotect to allow read/write/execute of the data section mov edx, forth_start and edx, -PAGE_SIZE ;start address mov ecx, forth_end sub ecx, edx ;length mov ebx, PROT_ALL ;flags push ebx push ecx push edx push 0 ;padding mov eax, SYS_mprotect int 0x80 add esp, 16 jmp forth_start SECTION .data forth_start: ; init data and return stacks, saving initial positions ; in Forth vars R0 and S0 cld GETRSP [var_WORD_SZ] SETDSP [var_WORD_SZ] ADDRSP -DATA_STACK_SIZE GETRSP [var_WORD_RZ] ; link built in dictionary mov esi, dictionary_start xor edi, edi repeat lodsd mov [eax + H_LLINK], edi mov edi, eax push esi mov cl, [eax + H_NSIZE] and ecx, F_LENMASK lea esi, [eax + H_NAME] call strhashi and ebx, NUM_HASH_CHAINS-1 mov esi, hash_buckets mov eax, [esi + (ebx * 4)] mov [esi + (ebx * 4)], edi mov [edi + H_HLINK], eax pop esi cmp esi, dictionary_end until z mov [var_WORD_LATEST], edi ; run temp interpreter loop till we can get into the real QUIT word call WORD_LBRAC ; interpret state LOADTOS 666q ; octal ! TORSP LOADTOS 0 TORSP LOADTOS bootfile TORSP call WORD_SYS_OPEN call WORD_SYSCALL ADDRSP 12 TORSP ; ( fd ) of "forth.f" loopstart LOADTOS tib_buffer LOADTOS MAX_LINE_SIZE FETCHRSP ; ( c-addr len fd ) call WORD_READLINE ; ( num flag flag ) call WORD_DROP2 LOADTOS tib_buffer call WORD_SWAP call WORD_INHASH call WORD_STORE2 LOADTOS 0 call WORD_TOIN call WORD_STORE call WORD_INTERPRET loopend ; and loop till QUIT takes over ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; a few case insensative string operations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; %macro to_lower 1 ; lower case check cmp %1, 'A' if ge cmp %1, 'Z' if le ; make it lower case add %1, byte 'a' - 'A' endif endif %endm strcpyi: test ecx, ecx if nz strcpyi_l1: lodsb to_lower al stosb loop strcpyi_l1 endif ret strcmpi: test ecx, ecx if nz strcmpi_l1: lodsb mov bl, [edi] lea edi, [edi + 1] to_lower al to_lower bl cmp bl, al if z loop strcmpi_l1 endif endif ret ;;;;;;;;;;;;;;; ; hash function ;;;;;;;;;;;;;;; strhashi: mov ebx, 5381 test ecx, ecx if nz mov edx, 33 strhashi_l1: lodsb movzx eax, al to_lower eax imul ebx, edx add ebx, eax loop strhashi_l1 endif ret ;;;;;;;;;;;;;;;;;;; ; syscall functions ;;;;;;;;;;;;;;;;;;; _syscall: int 0x80 if c neg eax endif ret _lsyscall: int 0x80 if c not eax not edx add eax, 1 adc edx, 0 endif ret ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; built in variables ; STATE Is the interpreter executing code (0) or compiling a word (non-zero)? ; LATEST Points to the latest (most recently defined) word in the dictionary. ; DP Points to the next free byte of memory. When compiling, compiled words go here. ; S0 Stores the address of the top of the parameter stack. ; R0 The address of the top of the return stack. ; BASE The current base for printing and reading numbers. ; #IN The current input buffer descriptor. ; >IN The current input offset. ; SOURCEFD The current input source file descriptor. ; BLK The current block number. ; CHARBUF Single char buffer. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; defvar "state", 0, WORD_STATE, 0 defvar "dp", 0, WORD_DP, dictionary_start defvar "latest", 0, WORD_LATEST, 0 defvar "s0", 0, WORD_SZ, 0 defvar "r0", 0, WORD_RZ, 0 defvar "base", 0, WORD_BASE, 10 defvar2 "#IN", 0, WORD_INHASH, 0, 0 defvar ">in", 0, WORD_TOIN, 0 defvar "sourcefd", 0, WORD_SOURCEFD, 0 defvar "blk", 0, WORD_BLK, 0 defvar "charbuf", 0, WORD_CHARBUF, 0 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; built in constants ; VERSION The current version of this FORTH. ; WORDBUF The address of the buffer WORD uses. ; LINESIZE The line buffer size. ; F_IMMED The IMMEDIATE flag's actual value. ; F_HIDDEN The HIDDEN flag's actual value. ; F_LENMASK The length mask in the flags/len byte. ; H_NSIZE The flags/len field offset. ; H_NAME The name field offset. ; XT_BODY The xt body pointer. ; XT_LENGTH The xt length field offset. ; XT_COMPILE The xt compile field offset. ; XT_SIZE The xt size offset. ; SYS_* The numeric codes of various syscalls. ; O_* Various sycall flags/modes. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; defconst "version", 0, WORD_VERSION, VERSION_NUM defconst "wordbuf", 0, WORD_WORDBUF, word_buf defconst "linesize", 0, WORD_LINESIZE, MAX_LINE_SIZE defconst "f_immed", 0, WORD__F_IMMED, F_IMMED defconst "f_hidden", 0, WORD__F_HIDDEN, F_HIDDEN defconst "f_lenmask", 0, WORD__F_LENMASK, F_LENMASK defconst "h_nsize", 0, WORD__H_NSIZE, H_NSIZE defconst "h_name", 0, WORD__H_NAME, H_NAME defconst "xt_body", 0, WORD__XT_BODY, XT_BODY defconst "xt_length", 0, WORD__XT_LENGTH, XT_LENGTH defconst "xt_compile", 0, WORD__XT_COMPILE, XT_COMPILE defconst "xt_size", 0, WORD__XT_SIZE, XT_SIZE defconst "sys_exit", 0, WORD_SYS_EXIT, SYS_exit defconst "sys_open", 0, WORD_SYS_OPEN, SYS_open defconst "sys_close", 0, WORD_SYS_CLOSE, SYS_close defconst "sys_read", 0, WORD_SYS_READ, SYS_read defconst "sys_write", 0, WORD_SYS_WRITE, SYS_write defconst "sys_unlink", 0, WORD_SYS_UNLINK, SYS_unlink defconst "sys_rename", 0, WORD_SYS_RENAME, SYS_rename defconst "sys_ftruncate", 0, WORD_SYS_FTRUNCATE, SYS_ftruncate defconst "sys_fsync", 0, WORD_SYS_FSYNC, SYS_fsync defconst "sys_lseek", 0, WORD_SYS_LSEEK, SYS_lseek defconst "sys_fstat", 0, WORD_SYS_FSTAT, SYS_fstat defconst "sys_stat", 0, WORD_SYS_STAT, SYS_stat defconst "o_rdonly", 0, WORD_O_RDONLY, 0x0 defconst "o_wronly", 0, WORD_O_WRONLY, 0x1 defconst "o_rdwr", 0, WORD_O_RDWR, 0x2 defconst "o_creat", 0, WORD_O_CREAT, 0x100 defconst "o_excl", 0, WORD_O_EXCL, 0x200 defconst "o_trunc", 0, WORD_O_TRUNC, 0x1000 defconst "o_append", 0, WORD_O_APPEND, 0x2000 defconst "o_nonblock", 0, WORD_O_NONBLOCK, 0x4000 ;;;;;;;;;;;;;;;;;;;;;;;;;;; ; data stack ordering words ;;;;;;;;;;;;;;;;;;;;;;;;;;; defword "dsp@", 0, WORD_DSPFETCH, WORD_INLINE_COMMA PUSHDSP ebx GETDSP ebx ret defword_end defword "dsp!", 0, WORD_DSPSTORE, WORD_INLINE_COMMA SETDSP ebx POPDSP ebx ret defword_end defword "drop", 0, WORD_DROP, WORD_INLINE_COMMA POPDSP ebx ret defword_end defword "swap", 0, WORD_SWAP, WORD_INLINE_COMMA xchg ebx, [ebp] ret defword_end defword "dup", 0, WORD_DUP, WORD_INLINE_COMMA PUSHDSP ebx ret defword_end defword "over", 0, WORD_OVER, WORD_INLINE_COMMA PUSHDSP ebx PICKDSP ebx, 4 ret defword_end defword "rot", 0, WORD_ROT, WORD_INLINE_COMMA mov eax, ebx PICKDSP ecx, 0 PICKDSP ebx, 4 PUTDSP eax, 0 PUTDSP ecx, 4 ret defword_end defword "-rot", 0, WORD_NROT, WORD_INLINE_COMMA mov eax, ebx PICKDSP ebx, 0 PICKDSP ecx, 4 PUTDSP ecx, 0 PUTDSP eax, 4 ret defword_end defword "2drop", 0, WORD_DROP2, WORD_INLINE_COMMA PICKDSP ebx, 4 ADDDSP 8 ret defword_end defword "2dup", 0, WORD_DUP2, WORD_INLINE_COMMA PICKDSP eax, 0 ADDDSP -8 PUTDSP eax, 0 PUTDSP ebx, 4 ret defword_end defword "2swap", 0, WORD_SWAP2, WORD_INLINE_COMMA mov eax, ebx PICKDSP ecx, 0 PICKDSP ebx, 4 PICKDSP edx, 8 PUTDSP edx, 0 PUTDSP eax, 4 PUTDSP ecx, 8 ret defword_end defword "2rot", 0, WORD_ROT2, WORD_INLINE_COMMA mov eax, ebx PICKDSP ecx, 16 PICKDSP ebx, 12 PICKDSP edx, 8 PICKDSP edi, 4 PICKDSP esi, 0 PUTDSP edx, 16 PUTDSP edi, 12 PUTDSP esi, 8 PUTDSP eax, 4 PUTDSP ecx, 0 ret defword_end defword "?dup", 0, WORD_QDUP, WORD_INLINE_COMMA test ebx, ebx if nz PUSHDSP ebx endif ret defword_end defword "!?dup", 0, WORD_NQDUP, WORD_INLINE_COMMA test ebx, ebx if z PUSHDSP ebx endif ret defword_end defword "nip", 0, WORD_NIP, WORD_INLINE_COMMA ADDDSP 4 ret defword_end defword "tuck", 0, WORD_TUCK, WORD_INLINE_COMMA PICKDSP eax, 0 PUTDSP ebx, 0 PUSHDSP eax ret defword_end defword "pick", 0, WORD_PICK, WORD_INLINE_COMMA mov ebx, [ebp + (ebx * 4)] ret defword_end defword "2tuck", 0, WORD_TUCK2, WORD_INLINE_COMMA PICKDSP eax, 0 PICKDSP ecx, 4 PICKDSP edx, 8 ADDDSP -8 PUTDSP eax, 0 PUTDSP ecx, 4 PUTDSP edx, 8 PUTDSP ebx, 12 PUTDSP eax, 16 ret defword_end defword "2nip", 0, WORD_NIP2, WORD_INLINE_COMMA PICKDSP eax, 0 ADDDSP 8 PUTDSP eax, 0 ret defword_end defword "2over", 0, WORD_OVER2, WORD_INLINE_COMMA ADDDSP -8 PUTDSP ebx, 4 PICKDSP ebx, 16 PUTDSP ebx, 0 PICKDSP ebx, 12 ret defword_end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; return stack ordering words ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; defword ">r", 0, WORD_TOR, WORD_INLINE_COMMA TORSP ret defword_end defword "r>", 0, WORD_FROMR, WORD_INLINE_COMMA FROMRSP ret defword_end defword "2>r", 0, WORD_TOR2, WORD_INLINE_COMMA ADDRSP -8 PICKDSP ecx, 0 PUTRSP ebx, 0 PUTRSP ecx, 4 PICKDSP ebx, 4 ADDDSP 8 ret defword_end defword "2r>", 0, WORD_FROMR2, WORD_INLINE_COMMA ADDDSP -8 PUTDSP ebx, 4 PICKRSP ebx, 0 PICKRSP ecx, 4 PUTDSP ecx, 0 ADDRSP 8 ret defword_end defword "rsp@", 0, WORD_RSPFETCH, WORD_INLINE_COMMA PUSHDSP ebx GETRSP ebx ret defword_end defword "r@", 0, WORD_RFETCH, WORD_INLINE_COMMA PUSHDSP ebx PICKRSP ebx, 0 ret defword_end defword "r!", 0, WORD_RSTORE, WORD_INLINE_COMMA PUTRSP ebx, 0 POPDSP ebx ret defword_end defword "2r@", 0, WORD_RFETCH2, WORD_INLINE_COMMA ADDDSP -8 PUTDSP ebx, 4 PICKRSP ebx, 4 PICKRSP ecx, 0 PUTDSP ecx, 0 ret defword_end defword "rsp!", 0, WORD_RSPSTORE, WORD_INLINE_COMMA SETRSP ebx POPDSP ebx ret defword_end defword "rdrop", 0, WORD_RDROP, WORD_INLINE_COMMA ADDRSP 4 ret defword_end defword "2rdrop", 0, WORD_RDROP2, WORD_INLINE_COMMA ADDRSP 8 ret defword_end defword "n>r", 0, WORD_NTOR, WORD_CALL_COMMA PUSHDSP ebx PICKRSP eax, 0 mov ecx, ebx inc ecx neg ebx lea esp, [esp + (ebx * 4)] mov esi, ebp mov edi, esp rep movsd mov ebp, esi POPDSP ebx jmp eax defword_end defword "nr>", 0, WORD_NFROMR, WORD_CALL_COMMA PUSHDSP ebx POPRSP eax PICKRSP ebx, 0 inc ebx mov ecx, ebx neg ebx lea ebp, [ebp + (ebx * 4)] mov esi, esp mov edi, ebp rep movsd mov esp, esi POPDSP ebx jmp eax defword_end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; memory fetch and store words ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; defword "!", 0, WORD_STORE, WORD_INLINE_COMMA PICKDSP eax, 0 mov [ebx], eax PICKDSP ebx, 4 ADDDSP 8 ret defword_end defword "@", 0, WORD_FETCH, WORD_INLINE_COMMA mov ebx, [ebx] ret defword_end defword "+!", 0, WORD_ADDSTORE, WORD_INLINE_COMMA PICKDSP eax, 0 add [ebx], eax PICKDSP ebx, 4 ADDDSP 8 ret defword_end defword "-!", 0, WORD_SUBSTORE, WORD_INLINE_COMMA PICKDSP eax, 0 sub [ebx], eax PICKDSP ebx, 4 ADDDSP 8 ret defword_end defword "c!", 0, WORD_STOREBYTE, WORD_INLINE_COMMA PICKDSP eax, 0 mov [ebx], al PICKDSP ebx, 4 ADDDSP 8 ret defword_end defword "c+!", 0, WORD_ADDBYTE, WORD_INLINE_COMMA PICKDSP eax, 0 add [ebx], al PICKDSP ebx, 4 ADDDSP 8 ret defword_end defword "c@", 0, WORD_FETCHBYTE, WORD_INLINE_COMMA mov eax, ebx xor ebx, ebx mov bl, [eax] ret defword_end defword "w!", 0, WORD_STORESHORT, WORD_INLINE_COMMA PICKDSP eax, 0 mov [ebx], ax PICKDSP ebx, 4 ADDDSP 8 ret defword_end defword "w@", 0, WORD_FETCHSHORT, WORD_INLINE_COMMA mov eax, ebx xor ebx, ebx mov bx, [eax] ret defword_end defword "2!", 0, WORD_STORE2, WORD_INLINE_COMMA PICKDSP ecx, 4 PICKDSP edx, 0 mov [ebx + 4], ecx mov [ebx], edx PICKDSP ebx, 8 ADDDSP 12 ret defword_end defword "2@", 0, WORD_FETCH2, WORD_INLINE_COMMA ADDDSP -4 mov ecx, [ebx +4] mov ebx, [ebx] PUTDSP ecx, 0 ret defword_end defword "blank", 0, WORD_BLANK, WORD_CALL_COMMA mov ecx, ebx PICKDSP ebx, 4 PICKDSP edi, 0 ADDDSP 8 mov eax, 0x20 rep stosb ret defword_end defword "erase", 0, WORD_ERASE, WORD_CALL_COMMA mov ecx, ebx PICKDSP ebx, 4 PICKDSP edi, 0 ADDDSP 8 xor eax, eax rep stosb ret defword_end defword "fill", 0, WORD_FILL, WORD_CALL_COMMA mov eax, ebx PICKDSP ebx, 8 PICKDSP edi, 4 PICKDSP ecx, 0 ADDDSP 12 rep stosb ret defword_end defword "cmove>", 0, WORD_CMOVEB, WORD_CALL_COMMA mov ecx, ebx PICKDSP ebx, 8 PICKDSP esi, 4 PICKDSP edi, 0 ADDDSP 12 lea esi, [esi + ecx - 1] lea edi, [edi + ecx - 1] std rep movsb cld ret defword_end defword "cmove", 0, WORD_CMOVE, WORD_CALL_COMMA mov ecx, ebx PICKDSP ebx, 8 PICKDSP esi, 4 PICKDSP edi, 0 ADDDSP 12 rep movsb ret defword_end defword "move", 0, WORD_MOVE, WORD_CALL_COMMA mov ecx, ebx PICKDSP ebx, 8 PICKDSP esi, 4 PICKDSP edi, 0 ADDDSP 12 cmp esi, edi if a rep movsb else lea esi, [esi + ecx -1] lea edi, [edi + ecx -1] std rep movsb cld endif ret defword_end ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; single precision alu words ;;;;;;;;;;;;;;;;;;;;;;;;;;;; defword "+", 0, WORD_ADD, WORD_INLINE_COMMA add ebx, [ebp] ADDDSP 4 ret defword_end defword "-", 0, WORD_SUB, WORD_INLINE_COMMA mov eax, ebx POPDSP ebx sub ebx, eax ret defword_end defword "*", 0, WORD_MULL, WORD_INLINE_COMMA imul ebx, [ebp] ADDDSP 4 ret defword_end defword "/", 0, WORD_DIV, WORD_INLINE_COMMA POPDSP eax cdq idiv ebx mov ebx, eax ret defword_end defword "mod", 0, WORD_MOD, WORD_INLINE_COMMA POPDSP eax cdq idiv ebx mov ebx, edx ret defword_end defword "1+", 0, WORD_INCR, WORD_INLINE_COMMA add ebx, byte 1 ret defword_end defword "1-", 0, WORD_DECR, WORD_INLINE_COMMA sub ebx, byte 1 ret defword_end defword "4+", 0, WORD_INCR4, WORD_INLINE_COMMA add ebx, byte 4 ret defword_end defword "4-", 0, WORD_DECR4, WORD_INLINE_COMMA sub ebx, byte 4 ret defword_end defword "2+", 0, WORD_INCR2, WORD_INLINE_COMMA add ebx, byte 2 ret defword_end defword "2-", 0, WORD_DECR2, WORD_INLINE_COMMA sub ebx, byte 2 ret defword_end defword "2*", 0, WORD_TWOMUL, WORD_INLINE_COMMA shl ebx, byte 1 ret defword_end defword "2/", 0, WORD_TWODIV, WORD_INLINE_COMMA sar ebx, byte 1 ret defword_end defword "abs", 0, WORD_ABS, WORD_INLINE_COMMA mov eax, ebx sar eax, byte 31 add ebx, eax xor ebx, eax ret defword_end defword "min", 0, WORD_MIN, WORD_INLINE_COMMA POPDSP eax cmp ebx, eax if g mov ebx, eax endif ret defword_end defword "max", 0, WORD_MAX, WORD_INLINE_COMMA POPDSP eax cmp ebx, eax if l mov ebx, eax endif ret defword_end defword "lshift", 0, WORD_LSHIFT, WORD_INLINE_COMMA mov ecx, ebx POPDSP ebx shl ebx, cl ret defword_end defword "rshift", 0, WORD_RSHIFT, WORD_INLINE_COMMA mov ecx, ebx POPDSP ebx shr ebx, cl ret defword_end defword "and", 0, WORD_AND, WORD_INLINE_COMMA and ebx, [ebp] ADDDSP 4 ret defword_end defword "or", 0, WORD_OR, WORD_INLINE_COMMA or ebx, [ebp] ADDDSP 4 ret defword_end defword "xor", 0, WORD_XOR, WORD_INLINE_COMMA xor ebx, [ebp] ADDDSP 4 ret defword_end defword "negate", 0, WORD_NEGATE, WORD_INLINE_COMMA neg ebx ret defword_end defword "invert", 0, WORD_INVERT, WORD_INLINE_COMMA not ebx ret defword_end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; single precision comparision words ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; defword "=", 0, WORD_EQ, WORD_INLINE_COMMA cmp [ebp], ebx sete bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword "<>", 0, WORD_NE, WORD_INLINE_COMMA cmp [ebp], ebx setne bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword "<", 0, WORD_LT, WORD_INLINE_COMMA cmp [ebp], ebx setl bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword ">", 0, WORD_GT, WORD_INLINE_COMMA cmp [ebp], ebx setg bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword "u<", 0, WORD_ULT, WORD_INLINE_COMMA cmp [ebp], ebx setb bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword "u>", 0, WORD_UGT, WORD_INLINE_COMMA cmp [ebp], ebx seta bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword "u<=", 0, WORD_ULTEQ, WORD_INLINE_COMMA cmp [ebp], ebx setbe bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword "u>=", 0, WORD_UGTEQ, WORD_INLINE_COMMA cmp [ebp], ebx setae bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword "<=", 0, WORD_LTEQ, WORD_INLINE_COMMA cmp [ebp], ebx setle bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword ">=", 0, WORD_GTEQ, WORD_INLINE_COMMA cmp [ebp], ebx setge bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword "0=", 0, WORD_ZEQ, WORD_INLINE_COMMA test ebx, ebx setz bl movzx ebx, bl neg ebx ret defword_end defword "0<>", 0, WORD_ZNE, WORD_INLINE_COMMA test ebx, ebx setnz bl movzx ebx, bl neg ebx ret defword_end defword "0<", 0, WORD_ZLT, WORD_INLINE_COMMA test ebx, ebx setl bl movzx ebx, bl neg ebx ret defword_end defword "0>", 0, WORD_ZGT, WORD_INLINE_COMMA test ebx, ebx setg bl movzx ebx, bl neg ebx ret defword_end defword "0<=", 0, WORD_ZLTEQ, WORD_INLINE_COMMA test ebx, ebx setle bl movzx ebx, bl neg ebx ret defword_end defword "0>=", 0, WORD_ZGTEQ, WORD_INLINE_COMMA test ebx, ebx setge bl movzx ebx, bl neg ebx ret defword_end ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; double precision ALU words ;;;;;;;;;;;;;;;;;;;;;;;;;;;; defword "s>d", 0, WORD_STOD, WORD_INLINE_COMMA mov eax, ebx cdq PUSHDSP eax mov ebx, edx ret defword_end defword "d>s", 0, WORD_DTOS, WORD_INLINE_COMMA POPDSP ebx ret defword_end defword "d+", 0, WORD_DPLUS, WORD_INLINE_COMMA PICKDSP ecx, 8 PICKDSP edx, 4 PICKDSP eax, 0 add eax, ecx adc ebx, edx PUTDSP eax, 8 ADDDSP 8 ret defword_end defword "d-", 0, WORD_DMINUS, WORD_INLINE_COMMA PICKDSP ecx, 8 PICKDSP edx, 4 PICKDSP eax, 0 sub ecx, eax sbb edx, ebx PUTDSP ecx, 8 mov ebx, edx ADDDSP 8 ret defword_end defword "d2*", 0, WORD_D2STAR, WORD_INLINE_COMMA PICKDSP eax, 0 shl eax, 1 rcl ebx, 1 PUTDSP eax, 0 ret defword_end defword "d2/", 0, WORD_D2SLASH, WORD_INLINE_COMMA PICKDSP eax, 0 sar ebx, 1 rcr eax, 1 PUTDSP eax, 0 ret defword_end defword "*/", 0, WORD_MULDIV, WORD_INLINE_COMMA PICKDSP edx, 4 PICKDSP eax, 0 imul edx idiv ebx mov ebx, eax ADDDSP 8 ret defword_end defword "*/mod", 0, WORD_STARSMOD, WORD_INLINE_COMMA PICKDSP edx, 4 PICKDSP eax, 0 imul edx idiv ebx PUTDSP edx, 4 ADDDSP 4 mov ebx, eax ret defword_end defword "/mod", 0, WORD_DIVMOD, WORD_INLINE_COMMA PICKDSP eax, 0 cdq idiv ebx PUTDSP edx, 0 mov ebx, eax ret defword_end defword "dnegate", 0, WORD_DNEGATE, WORD_INLINE_COMMA PICKDSP eax, 0 not eax not ebx add eax, 1 adc ebx, 0 PUTDSP eax, 0 ret defword_end defword "dabs", 0, WORD_DABS, WORD_INLINE_COMMA test ebx, ebx if l PICKDSP eax, 0 not eax not ebx add eax, 1 adc ebx, 0 PUTDSP eax, 0 endif ret defword_end defword "dmax", 0, WORD_DMAX, WORD_INLINE_COMMA PICKDSP ecx, 8 PICKDSP edx, 4 PICKDSP eax, 0 ADDDSP 8 mov esi, ecx mov edi, edx sub esi, eax sbb edi, ebx if l PUTDSP eax, 0 else mov ebx, edx endif ret defword_end defword "dmin", 0, WORD_DMIN, WORD_INLINE_COMMA PICKDSP ecx, 8 PICKDSP edx, 4 PICKDSP eax, 0 ADDDSP 8 mov esi, ecx mov edi, edx sub esi, eax sbb edi, ebx if ge PUTDSP eax, 0 else mov ebx, edx endif ret defword_end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; double precision comparision words ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; defword "d0=", 0, WORD_DZEQ, WORD_INLINE_COMMA or ebx, [ebp] setz bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword "d0<>", 0, WORD_DZNEQ, WORD_INLINE_COMMA or ebx, [ebp] setnz bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword "d0<", 0, WORD_DZLT, WORD_INLINE_COMMA test ebx, ebx setl bl ADDDSP 4 movzx ebx, bl neg ebx ret defword_end defword "d=", 0, WORD_DEQ, WORD_INLINE_COMMA PICKDSP ecx, 8 PICKDSP eax, 4 sub ecx, [ebp] sbb eax, ebx setz bl ADDDSP 12 movzx ebx, bl neg ebx ret defword_end defword "d<>", 0, WORD_DNEQ, WORD_INLINE_COMMA PICKDSP ecx, 8 PICKDSP eax, 4 sub ecx, [ebp] sbb eax, ebx setnz bl ADDDSP 12 movzx ebx, bl neg ebx ret defword_end defword "d<", 0, WORD_DLT, WORD_INLINE_COMMA PICKDSP ecx, 8 PICKDSP eax, 4 sub ecx, [ebp] sbb eax, ebx setl bl ADDDSP 12 movzx ebx, bl neg ebx ret defword_end defword "du<", 0, WORD_DULT, WORD_INLINE_COMMA PICKDSP ecx, 8 PICKDSP eax, 4 sub ecx, [ebp] sbb eax, ebx setb bl ADDDSP 12 movzx ebx, bl neg ebx ret defword_end ;;;;;;;;;;;;;;;;;;;;;;; ; mixed precision words ;;;;;;;;;;;;;;;;;;;;;;; defword "m+", 0, WORD_MPLUS, WORD_INLINE_COMMA PICKDSP eax, 4 PICKDSP edx, 0 add eax, ebx adc edx, 0 PUTDSP eax, 4 mov ebx, edx ADDDSP 4 ret defword_end defword "m-", 0, WORD_MMINUS, WORD_INLINE_COMMA PICKDSP eax, 4 PICKDSP edx, 0 sub eax, ebx sbb edx, 0 PUTDSP eax, 4 mov ebx, edx ADDDSP 4 ret defword_end defword "m*", 0, WORD_MULSTAR, WORD_INLINE_COMMA PICKDSP eax, 0 imul ebx PUTDSP eax, 0 mov ebx, edx ret defword_end defword "m/", 0, WORD_MSLASH, WORD_INLINE_COMMA PICKDSP eax, 4 PICKDSP edx, 0 idiv ebx mov ebx, eax ADDDSP 8 ret defword_end defword "um*", 0, WORD_UMULSTAR, WORD_INLINE_COMMA PICKDSP eax, 0 mul ebx PUTDSP eax, 0 mov ebx, edx ret defword_end defword "um/mod", 0, WORD_UMDIVMOD, WORD_INLINE_COMMA PICKDSP eax, 4 PICKDSP edx, 0 div ebx PUTDSP edx, 4 mov ebx, eax ADDDSP 4 ret defword_end defword "fm/mod", 0, WORD_FMDIVMOD, WORD_INLINE_COMMA PICKDSP edx, 0 PICKDSP eax, 4 mov ecx, ebx ADDDSP 4 xor ecx, edx idiv ebx test ecx, ecx if s test edx, edx if nz dec eax add edx, ebx endif endif PUTDSP edx, 0 mov ebx, eax ret defword_end defword "sm/rem", 0, WORD_SMDIVREM, WORD_INLINE_COMMA PICKDSP eax, 4 PICKDSP edx, 0 idiv ebx PUTDSP edx, 4 mov ebx, eax ADDDSP 4 ret defword_end defword "u/mod", 0, WORD_UDIVMOD, WORD_INLINE_COMMA xor edx, edx PICKDSP eax, 0 div ebx PUTDSP edx, 0 mov ebx, eax ret defword_end defword "dm*", 0, WORD_DMULSTAR, WORD_CALL_COMMA call WORD_TUCK call WORD_MULL TORSP call WORD_UMULSTAR FROMRSP call WORD_ADD ret defword_end ;;;;;;;;;;;;;;;;;;;; ; control flow words ;;;;;;;;;;;;;;;;;;;; defword "branch", 0, WORD_BRANCH, WORD_INLINE_COMMA i_jmp: jmp strict near i_ret ret defword_end defword "0branch", 0, WORD_ZBRANCH, WORD_INLINE_COMMA mov eax, ebx POPDSP ebx test eax, eax jz strict near i_jmp ret defword_end defword "exit", 0, WORD_EXIT, WORD_EXIT_COMMA i_ret: ret defword_end defword "exit,", 0, WORD_EXIT_COMMA, WORD_CALL_COMMA mov edi, [var_WORD_DP] sub edi, 5 cmp edi, [lastcall] ; are we just after a call instruction ? if z mov al, [i_jmp] mov [edi], al ; change it to a jmp endif mov edi, [var_WORD_DP] mov al, [i_ret] stosb mov [var_WORD_DP], edi POPDSP ebx ret defword_end defword "execute", 0, WORD_EXECUTE, WORD_CALL_COMMA mov eax, ebx ; Get xt into eax POPDSP ebx ; After xt runs its ret will continue executing the current word. jmp eax ; and jump to it. defword_end ;;;;;;;;;;;;;;;;;;;;;;;;;; ; terminal input words ;;;;;;;;;;;;;;;;;;;;;;;;;; defword "read-char", 0, WORD_READCHAR, WORD_CALL_COMMA mov ecx, var_WORD_CHARBUF ; 2nd param: buffer mov edx, 1 ; 3rd param: max length push edx push ecx push ebx mov eax, SYS_read ; syscall: read call _syscall add esp, 12 xor ebx, ebx test eax, eax if be mov ebx, -1 endif ret defword_end defword "read-line", 0, WORD_READLINE, WORD_CALL_COMMA call WORD_NROT call WORD_OVER call WORD_ADD call WORD_OVER ; ( fd start end cur ) readline_l1: PICKDSP eax, 0 cmp ebx, eax jz readline_l4 PUSHDSP ebx PICKDSP ebx, 12 call WORD_READCHAR test ebx, ebx jz readline_l2 call WORD_DROP call WORD_DROP2 call WORD_DROP2 LOADTOS 0 LOADTOS 0 LOADTOS -1 jmp readline_l5 readline_l2: mov ebx, [var_WORD_CHARBUF] cmp ebx, 10 ; LF jz readline_l3 call WORD_OVER call WORD_STOREBYTE call WORD_INCR jmp readline_l1 readline_l3: call WORD_DROP readline_l4: call WORD_NIP call WORD_SWAP call WORD_SUB call WORD_NIP LOADTOS -1 LOADTOS 0 readline_l5: ret defword_end defword "key", 0, WORD_KEY, WORD_CALL_COMMA PUSHDSP ebx xor ebx, ebx ; stdin call WORD_READCHAR mov ebx, [var_WORD_CHARBUF] ret defword_end defword "accept", 0, WORD_ACCEPT, WORD_CALL_COMMA call WORD_OVER call WORD_ADD call WORD_OVER ; ( start end cur ) accept_l1: call WORD_KEY cmp ebx, 127 ; BS jz accept_l2 cmp ebx, 10 ; LF jz accept_l3 call WORD_OVER ; ( start end cur key cur ) call WORD_STOREBYTE call WORD_INCR ; ( start end cur' ) PICKDSP eax, 0 cmp ebx, eax jz accept_l4 jmp accept_l1 accept_l2: PICKDSP eax, 4 ; ( start end cur' ) cmp ebx, eax jz accept_l1 call WORD_DECR jmp accept_l1 accept_l3: call WORD_DROP ; ( start end cur' ) accept_l4: call WORD_NIP call WORD_SWAP call WORD_SUB ret defword_end defword "tabs>spaces", 0, WORD_TABSTOSPACES, WORD_CALL_COMMA mov ecx, ebx POPDSP esi test ecx, ecx if nz repeat lodsb cmp al, 9 ;TAB if z mov byte [esi - 1], ' ' endif dec ecx until z endif POPDSP ebx ret defword_end ;;;;;;;;;;;;;;;;;;;;;;; ; terminal output words ;;;;;;;;;;;;;;;;;;;;;;; defword "type-fd", 0, WORD_TYPE_FD, WORD_CALL_COMMA PICKDSP edx, 0 ; 3rd param: length of string PICKDSP ecx, 4 ; 2nd param: address of string ADDDSP 8 ; 1st param: FD in ebx mov eax, SYS_write ; write syscall push edx push ecx push ebx call _syscall add esp, 12 POPDSP ebx ret defword_end defword "type", 0, WORD_TYPE, WORD_CALL_COMMA LOADTOS 1 ; stdout call WORD_TYPE_FD ret defword_end defword "emit", 0, WORD_EMIT, WORD_CALL_COMMA mov [emit_scratch], bl ; write needs the address of the byte to write mov ebx, emit_scratch LOADTOS 1 call WORD_TYPE ret defword_end ;;;;;;;;;;;;;;;;;;; ; system call words ;;;;;;;;;;;;;;;;;;; defword "syscall", 0, WORD_SYSCALL, WORD_CALL_COMMA pop eax mov [syscallret], eax ; save return address mov eax, ebx ; System call number (see ) call _syscall mov ebx, eax ; Result (negative for -errno) jmp [syscallret] ; return to caller defword_end defword "lsyscall", 0, WORD_LSYSCALL, WORD_CALL_COMMA pop eax mov [syscallret], eax ; save return address mov eax, ebx ; System call number (see ) call _lsyscall PUSHDSP eax mov ebx, edx ; Result (negative for -errno) jmp [syscallret] ; return to caller defword_end ;;;;;;;;;;;;;; ; string words ;;;;;;;;;;;;;; defword "count", 0, WORD_COUNT, WORD_CALL_COMMA xor eax, eax mov al, [ebx] inc ebx LOADTOS eax ret defword_end defword "-trailing", 0, WORD_TRAILING, WORD_CALL_COMMA test ebx, ebx if nz PICKDSP esi, 0 mov ecx, ebx add esi, ebx dec esi std trailing_l1: lodsb cmp al, ' ' if be loop trailing_l1 endif mov ebx, ecx cld endif ret defword_end defword "/string", 0, WORD_SSTRING, WORD_CALL_COMMA mov eax, ebx POPDSP ebx PICKDSP ecx, 0 sub ebx, eax add ecx, eax PUTDSP ecx, 0 ret defword_end defword "compare", 0, WORD_COMPARE, WORD_CALL_COMMA PICKDSP esi, 8 PICKDSP edx, 4 PICKDSP edi, 0 ADDDSP 12 mov ecx, ebx cmp edx, ebx if be mov ecx, edx endif test ecx, ecx ; ecx lowest length jnz compare_l2 cmp edx, ebx jz compare_l3 ; both are 0 length jmp compare_l4 ; otherwise the longest wins compare_l2: cmpsb jnz compare_l4 ; chars not same loop compare_l2 cmp edx, ebx ; all chars same jnz compare_l4 ; strings not same size compare_l3: xor ebx, ebx ; same jmp compare_l7 compare_l4: ja compare_l6 compare_l5: mov ebx, -1 jmp compare_l7 compare_l6: mov ebx, 1 compare_l7: ret defword_end defword "icompare", 0, WORD_COMPAREI, WORD_CALL_COMMA PICKDSP esi, 8 PICKDSP edx, 4 PICKDSP edi, 0 ADDDSP 12 mov ecx, ebx cmp edx, ebx if be mov ecx, edx endif test ecx, ecx ; ecx lowest length jnz comparei_l2 cmp edx, ebx jz comparei_l3 ; both are 0 length jmp comparei_l4 ; otherwise the longest wins comparei_l2: mov al, [esi] mov ah, [edi] to_lower al to_lower ah cmp ah, al jnz comparei_l4 ; chars not same inc edi inc esi loop comparei_l2 cmp edx, ebx ; all chars same jnz comparei_l4 ; strings not same size comparei_l3: xor ebx, ebx ; same jmp comparei_l7 comparei_l4: ja comparei_l6 comparei_l5: mov ebx, -1 jmp comparei_l7 comparei_l6: mov ebx, 1 comparei_l7: ret defword_end ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; dictionary searching words ;;;;;;;;;;;;;;;;;;;;;;;;;;;; defword "find", 0, WORD_FIND, WORD_CALL_COMMA call WORD_DUP call WORD_COUNT call WORD_FIND_DICT test ebx, ebx if nz mov dl, [ebx + H_NSIZE] call WORD_TCFA LOADTOS 1 and edx, F_IMMED if z neg ebx endif call WORD_ROT call WORD_DROP endif ret defword_end defword "(find)", 0, WORD_FIND_DICT, WORD_CALL_COMMA mov ecx, ebx ; ecx = length POPDSP edi ; edi = address PUSHRSP ecx mov esi, edi call strhashi and ebx, NUM_HASH_CHAINS-1 mov esi, hash_buckets mov edx, [esi + (ebx * 4)] POPRSP ecx ; edx can now scan back through this hash chain findd_l1: test edx, edx ; NULL pointer? (end of the linked list) je findd_l4 xor eax, eax mov al, [edx + H_NSIZE] ; al = flags+length field and al, (F_HIDDEN|F_LENMASK) ; al = name length cmp al, cl ; Length is the same? jne findd_l2 PUSHRSP ecx ; Save the length PUSHRSP edi ; Save the address (repe cmpsb will move this pointer) lea esi, [edx + H_NAME] ; Dictionary string we are checking against. call strcmpi POPRSP edi POPRSP ecx jne findd_l2 ; Not the same. mov ebx, edx ret findd_l2: mov edx, [edx + H_HLINK] ; Move back through the link field to the previous word jmp findd_l1 ; .. and loop. findd_l4: xor ebx, ebx ; Return zero to indicate not found. ret defword_end defword ">cfa", 0, WORD_TCFA, WORD_CALL_COMMA add ebx, H_NSIZE mov al, [ebx] ; Load flags+len into al. inc ebx ; skip flags+len byte. and eax, F_LENMASK ; Just the length, not the flags. add ebx, eax ; skip the name add ebx, XT_SIZE ; skip to the xt ret defword_end defword "(bucket)", 0, WORD_BUCKET, WORD_CALL_COMMA mov ecx, ebx ; ecx = length POPDSP ebx ; ebx = address of name PUSHRSP esi mov esi, ebx call strhashi and ebx, NUM_HASH_CHAINS-1 mov esi, hash_buckets lea ebx, [esi + (ebx * 4)] POPRSP esi ret defword_end defword "unused", 0, WORD_UNUSED, WORD_CALL_COMMA LOADTOS forth_end LOADTOS [var_WORD_DP] call WORD_SUB ret defword_end ;;;;;;;;;;;;;;;;;;;;;;;;;;; ; dictionary building words ;;;;;;;;;;;;;;;;;;;;;;;;;;; defword "align", 0, WORD_ALIGNDP, WORD_CALL_COMMA mov eax, [var_WORD_DP] ALIGNREG eax mov [var_WORD_DP], eax ret defword_end defword "header,", 0, WORD_HEADER_COMMA, WORD_CALL_COMMA mov ecx, ebx ; ecx = length POPDSP ebx ; ebx = address of name call WORD_ALIGNDP ; align header mov edi, [var_WORD_DP] ; edi is the address of the header mov eax, [var_WORD_LATEST] ; Get link pointer mov [edi + H_LLINK], eax ; and store it in the header. mov [var_WORD_LATEST], edi PUSHRSP ebx ; hash chain PUSHRSP ecx mov esi, ebx call strhashi and ebx, NUM_HASH_CHAINS-1 mov esi, hash_buckets mov eax, [esi + (ebx * 4)] mov [esi + (ebx * 4)], edi mov [edi + H_HLINK], eax ; and store it in the header. POPRSP ecx POPRSP esi mov [edi + H_NSIZE], cl ; Store the length/flags byte. add edi, H_NAME call strcpyi mov ecx, XT_SIZE xor eax, eax rep stosb ; clear the gap till the xt mov [var_WORD_DP], edi mov long [edi + XT_COMPILE], WORD_CALL_COMMA ;compile action POPDSP ebx ret defword_end defword "lit,", 0, WORD_LIT_COMMA, WORD_CALL_COMMA mov esi, litc_l1 mov edi, [var_WORD_DP] mov ecx, litc_l2 - litc_l1 - 4 rep movsb mov [var_WORD_DP], edi ret defword_end litc_l1: LOADTOS 0xBAADF00D litc_l2: defword "slits", 0, WORD_SLITS, WORD_CALL_COMMA PUSHDSP ebx POPRSP esi xor eax, eax lodsb ; get the length of the string PUSHDSP esi ; push the address of the start of the string mov ebx, eax ; push length on the stack add esi, eax ; skip past the string jmp esi defword_end defword "clits", 0, WORD_CLITS, WORD_CALL_COMMA FROMRSP xor eax, eax mov al, [ebx] lea eax, [ebx + eax + 1] jmp eax defword_end defword ",", 0, WORD_COMMA, WORD_CALL_COMMA mov edi, [var_WORD_DP] ; DP mov eax, ebx stosd ; Store it. mov [var_WORD_DP], edi ; Update DP (incremented) POPDSP ebx ret defword_end defword "c,", 0, WORD_CHAR_COMMA, WORD_CALL_COMMA mov eax, ebx mov edi, [var_WORD_DP] ; DP stosb ; Store it. mov [var_WORD_DP], edi ; Update DP (incremented) POPDSP ebx ret defword_end defword ":", 0, WORD_COLON, WORD_CALL_COMMA call WORD_PARSENAME call WORD_HEADER_COMMA ; Create the dictionary entry / header mov eax, [var_WORD_DP] mov [eax + XT_BODY], eax call WORD_LATEST call WORD_FETCH call WORD_HIDDEN ; Make the word hidden call WORD_RBRAC ; Go into compile mode. ret defword_end defword "create", 0, WORD_CREATE, WORD_CALL_COMMA call WORD_PARSENAME call WORD_HEADER_COMMA mov esi, create_l1 mov edi, [var_WORD_DP] PUSHRSP edi mov ecx, create_l4 - create_l1 rep movsb mov [var_WORD_DP], edi mov edx, edi call WORD_ALIGNDP POPRSP eax mov edi, [var_WORD_DP] sub edx, eax mov [eax + create_l2 - create_l1 - 4], edi mov [eax + XT_BODY], edi mov [eax + XT_LENGTH], edx ret defword_end create_l1: LOADTOS 0xBAADF00D create_l2: call strict near create_l3 create_l3: ret create_l4: defword "dodoes", 0, WORD_DODOES, WORD_CALL_COMMA call WORD_LATEST call WORD_FETCH call WORD_TCFA add ebx, create_l3 - create_l1 - 4 POPDSP eax sub eax, ebx sub eax, 4 mov [ebx], eax POPDSP ebx ret defword_end defword "does>", F_IMMED, WORD_DOES, WORD_CALL_COMMA call WORD_LIT_COMMA LOADTOS [var_WORD_DP] add ebx, 10 call WORD_COMMA LOADTOS WORD_DODOES call WORD_COMPILE_COMMA LOADTOS 0 mov bl, [does_l1] call WORD_CHAR_COMMA does_l1: ret defword_end defword "postpone", F_IMMED, WORD_POSTPONE, WORD_CALL_COMMA call WORD_PARSENAME call WORD_FIND_DICT mov dl, [ebx + H_NSIZE] call WORD_TCFA and edx, F_IMMED if z call WORD_LIT_COMMA call WORD_COMMA LOADTOS WORD_COMPILE_COMMA endif jmp WORD_COMPILE_COMMA ret defword_end defword "call,", 0, WORD_CALL_COMMA, WORD_CALL_COMMA mov edi, [var_WORD_DP] mov [lastcall], edi ; record last location of last call mov esi, i_call movsb mov eax, ebx sub eax, 4 sub eax, edi stosd mov [var_WORD_DP], edi POPDSP ebx ret defword_end defword "inline,", 0, WORD_INLINE_COMMA, WORD_CALL_COMMA mov ecx, [ebx + XT_LENGTH] dec ecx ; actual code length minus ret mov esi, ebx mov edi, [var_WORD_DP] rep movsb ; inline copy the code mov [var_WORD_DP], edi ; update DP POPDSP ebx ret defword_end defword "compile,", 0, WORD_COMPILE_COMMA, WORD_INLINE_COMMA call [ebx + XT_COMPILE] ret defword_end defword ";", F_IMMED, WORD_SEMICOLON, WORD_CALL_COMMA LOADTOS WORD_EXIT i_call: call strict near WORD_COMPILE_COMMA call WORD_LATEST call WORD_FETCH call WORD_HIDDEN ; toggle hidden flag -- unhide the word (see below for definition). call WORD_LBRAC ; go back to IMMEDIATE mode. mov edx, ebx mov ebx, [var_WORD_LATEST] call WORD_TCFA mov ecx, [var_WORD_DP] sub ecx, ebx mov [ebx + XT_LENGTH], ecx ; set code size of word mov ebx, edx ret defword_end defword "immediate", 0, WORD_IMMEDIATE, WORD_CALL_COMMA mov edi, [var_WORD_LATEST] ; LATEST word. add edi, H_NSIZE ; Point to name/flags byte. xor byte [edi], F_IMMED ; Toggle the IMMED bit. ret defword_end defword "hidden", 0, WORD_HIDDEN, WORD_CALL_COMMA add ebx, H_NSIZE ; Point to name/flags byte. xor byte [ebx], F_HIDDEN ; Toggle the HIDDEN bit. POPDSP ebx ret defword_end defword "[", F_IMMED, WORD_LBRAC, WORD_CALL_COMMA mov long [var_WORD_STATE], 0 ; Set STATE to 0. ret defword_end defword "]", 0, WORD_RBRAC, WORD_CALL_COMMA mov long [var_WORD_STATE], 1 ; Set STATE to 1. ret defword_end ;;;;;;;;;;;;;;;;;;;;; ; source buffer words ;;;;;;;;;;;;;;;;;;;;; defword "source", 0, WORD_SOURCE, WORD_CALL_COMMA call WORD_INHASH call WORD_FETCH2 ret defword_end defword "refill", 0, WORD_REFILL, WORD_CALL_COMMA LOADTOS tib_buffer call WORD_LINESIZE ; ( tib len ) call WORD_OVER call WORD_SWAP ; ( tib tib len ) call WORD_ACCEPT ; read line into TIB call WORD_DUP2 call WORD_TABSTOSPACES call WORD_INHASH call WORD_STORE2 ; set as current WORD_SOURCE LOADTOS 0 call WORD_TOIN call WORD_STORE ; set to start of buffer LOADTOS -1 ret defword_end defword "isspace?", 0, WORD_ISSPACE, WORD_CALL_COMMA LOADTOS ' ' call WORD_ULTEQ ret defword_end defword "isnotspace?", 0, WORD_ISNOTSPACE, WORD_CALL_COMMA call WORD_ISSPACE call WORD_ZEQ ret defword_end defword "xt-skip", 0, WORD_XTSKIP, WORD_CALL_COMMA TORSP xtskip_l1: test ebx, ebx jz xtskip_l3 call WORD_OVER call WORD_FETCHBYTE FETCHRSP call WORD_EXECUTE test ebx, ebx jz xtskip_l2 mov ebx, 1 call WORD_SSTRING jmp xtskip_l1 xtskip_l2: call WORD_DROP xtskip_l3: ADDRSP 4 ret defword_end ;;;;;;;;;;;;;;;;;;;;;; ; input parseing words ;;;;;;;;;;;;;;;;;;;;;; defword "parse-name", 0, WORD_PARSENAME, WORD_CALL_COMMA call WORD_SOURCE call WORD_TOIN call WORD_FETCH call WORD_SSTRING LOADTOS WORD_ISSPACE call WORD_XTSKIP call WORD_OVER TORSP LOADTOS WORD_ISNOTSPACE call WORD_XTSKIP call WORD_DUP2 LOADTOS 1 call WORD_MIN call WORD_ADD call WORD_SOURCE call WORD_DROP call WORD_SUB call WORD_TOIN call WORD_STORE call WORD_DROP FROMRSP call WORD_TUCK call WORD_SUB ; code to print out "P CR" ;LOADTOS 80 ;call WORD_EMIT ;LOADTOS 32 ;call WORD_EMIT ;call WORD_DUP2 ;call WORD_TYPE ;LOADTOS 10 ;call WORD_EMIT ret defword_end defword "word-name", 0, WORD_WORDNAME, WORD_CALL_COMMA call WORD_PARSENAME ; ( start len ) LOADTOS word_buf ; ( string size buf ) call WORD_DUP2 ; ( string size buf size buf ) call WORD_STOREBYTE ; ( string size buf ) call WORD_INCR ; ( string size buf+1 ) call WORD_SWAP ; ( string buf+1 size ) call WORD_CMOVE LOADTOS word_buf ; ( cstring ) ; debug code to print out "N CR" ;LOADTOS 78 ;call WORD_EMIT ;LOADTOS 32 ;call WORD_EMIT ;call WORD_DUP2 ;call WORD_TYPE ;LOADTOS 10 ;call WORD_EMIT ret defword_end defword "interp-name", 0, WORD_INTERPNAME, WORD_CALL_COMMA call WORD_PARSENAME ; ( start len ) LOADTOS intep_name_buf ; ( string size buf ) call WORD_DUP2 ; ( string size buf size buf ) call WORD_STOREBYTE ; ( string size buf ) call WORD_INCR ; ( string size buf+1 ) call WORD_SWAP ; ( string buf+1 size ) call WORD_CMOVE LOADTOS intep_name_buf ;( cstring ) ret defword_end defword "interpret", 0, WORD_INTERPRET, WORD_CALL_COMMA loopstart call WORD_INTERPNAME mov al, [ebx] test al, al breakif z ; debug code to print out "I CR" ;LOADTOS 73 ;call WORD_EMIT ;LOADTOS 32 ;call WORD_EMIT ;call WORD_DUP ;call WORD_COUNT ;call WORD_TYPE ;LOADTOS 10 ;call WORD_EMIT call WORD_INTERP loopend call WORD_DROP ret defword_end defword "interp", 0, WORD_INTERP, WORD_CALL_COMMA call WORD_FIND ; ( cstring 0 | xt 1 | xt | -1 ) mov eax, ebx POPDSP ebx test eax, eax jz tryasnumber jle nonimediate executeword: mov eax, ebx POPDSP ebx jmp eax nonimediate: mov eax, [var_WORD_STATE] test eax, eax ; are we in imedeate mode ? jz executeword jmp WORD_COMPILE_COMMA ; compile xt tryasnumber: call WORD_COUNT ; ( adr len ) LOADTOS 0 LOADTOS 0 call WORD_SWAP2 ; ( 0d addr len ) call WORD_TOSNUMBER ; ( d addr len ) test ebx, ebx jnz parseproblem call WORD_DROP2 call WORD_DROP ; ( num ) mov eax, [var_WORD_STATE] test eax, eax if nz call WORD_LIT_COMMA ; compile LIT call WORD_COMMA ; compile value endif ret parseproblem: LOADTOS errmsg LOADTOS errmsgend - errmsg LOADTOS 2 call WORD_TYPE_FD LOADTOS errmsgnl LOADTOS 1 LOADTOS 2 call WORD_TYPE_FD LOADTOS tib_buffer LOADTOS [var_WORD_TOIN] LOADTOS 2 call WORD_TYPE_FD LOADTOS errmsgnl LOADTOS 1 LOADTOS 2 call WORD_TYPE_FD call WORD_DROP2 call WORD_DROP2 ret defword_end defword ">number", 0, WORD_TONUMBER, WORD_CALL_COMMA call WORD_OVER call WORD_ADD call WORD_SWAP ; ( ud end cur ) tonumber_l1: PICKDSP eax, 0 cmp ebx, eax jz near tonumber_l4 call WORD_DUP call WORD_FETCHBYTE ; ( ud end cur char ) to_lower ebx sub ebx, byte '0' jb tonumber_l3 ; < '0'? cmp ebx, byte 10 jb tonumber_l2 ; <= '9' ? sub ebx, byte 'a' - '0' jb tonumber_l3 ; < 'a' ? add ebx, byte 10 tonumber_l2: cmp ebx, [var_WORD_BASE] jge tonumber_l3 ; >= WORD_BASE ? TORSP call WORD_SWAP2 ; ( end cur ud ) LOADTOS [var_WORD_BASE] call WORD_DMULSTAR FROMRSP call WORD_MPLUS ; ( end cur ud' ) call WORD_SWAP2 call WORD_INCR ; ( ud' end cur' ) jmp tonumber_l1 tonumber_l3: call WORD_DROP tonumber_l4: call WORD_SWAP call WORD_OVER call WORD_SUB ; ( ud' c-addr u2 ) ret defword_end defword ">snumber", 0, WORD_TOSNUMBER, WORD_CALL_COMMA test ebx, ebx if nz PICKDSP eax, 0 mov cl, [eax] cmp cl, '-' jnz WORD_TONUMBER ; not '-' inc eax PUTDSP eax, 0 dec ebx call WORD_TONUMBER call WORD_SWAP2 call WORD_DNEGATE call WORD_SWAP2 endif ret defword_end ;;;;;;;;;;; ; tick word ;;;;;;;;;;; defword "ticks", 0, WORD_TICKS, WORD_CALL_COMMA sub ebp, byte 8 rdtsc mov [byte ebp -4], ebx mov [ebp], eax mov ebx, edx ret defword_end ;;;;;;;;;;; ; test word ;;;;;;;;;;; defword "test", 0, WORD_TEST, WORD_CALL_COMMA ret defword_end ;;;;;;;;;;;;;;;;; ; read/write data ;;;;;;;;;;;;;;;;; align 4 syscallret: ; return address saved by syscall dd 0 lastcall: ; last call layed down by compiler dd 0 tib_buffer: ; keyboard input buffer times MAX_LINE_SIZE db 0 word_buf: ; static buffer where WORD returns. Subsequent calls ; overwrite this buffer. times MAX_LINE_SIZE db 0 intep_name_buf: ; static buffer where INTERPNAME returns. Subsequent calls ; overwrite this buffer. times MAX_LINE_SIZE db 0 emit_scratch: ; scratch used by EMIT db 0 errmsg: db "PARSE ERROR:" errmsgend: errmsgnl: db 10 bootfile: db "forth.f" db 0 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; dictionary hash table (64) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; align 4 hash_buckets: dd 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 dd 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 dd 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 dd 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; addresses of all built in dictionary words. ; this ends up as part of the user space after booting ! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; align 4 dictionary_start: dd dic_WORD_ABS dd dic_WORD_ACCEPT dd dic_WORD_ADD dd dic_WORD_ADDBYTE dd dic_WORD_ADDSTORE dd dic_WORD_ALIGNDP dd dic_WORD_AND dd dic_WORD_BASE dd dic_WORD_BLANK dd dic_WORD_BLK dd dic_WORD_BRANCH dd dic_WORD_BUCKET dd dic_WORD_CALL_COMMA dd dic_WORD_CHARBUF dd dic_WORD_CHAR_COMMA dd dic_WORD_CLITS dd dic_WORD_CMOVE dd dic_WORD_CMOVEB dd dic_WORD_COLON dd dic_WORD_COMMA dd dic_WORD_COMPARE dd dic_WORD_COMPAREI dd dic_WORD_COMPILE_COMMA dd dic_WORD_COUNT dd dic_WORD_CREATE dd dic_WORD_D2SLASH dd dic_WORD_D2STAR dd dic_WORD_DABS dd dic_WORD_DECR dd dic_WORD_DECR2 dd dic_WORD_DECR4 dd dic_WORD_DEQ dd dic_WORD_DIV dd dic_WORD_DIVMOD dd dic_WORD_DLT dd dic_WORD_DMAX dd dic_WORD_DMIN dd dic_WORD_DMINUS dd dic_WORD_DMULSTAR dd dic_WORD_DNEGATE dd dic_WORD_DNEQ dd dic_WORD_DODOES dd dic_WORD_DOES dd dic_WORD_DP dd dic_WORD_DPLUS dd dic_WORD_DROP dd dic_WORD_DROP2 dd dic_WORD_DSPFETCH dd dic_WORD_DSPSTORE dd dic_WORD_DTOS dd dic_WORD_DULT dd dic_WORD_DUP dd dic_WORD_DUP2 dd dic_WORD_DZEQ dd dic_WORD_DZLT dd dic_WORD_DZNEQ dd dic_WORD_EMIT dd dic_WORD_EQ dd dic_WORD_ERASE dd dic_WORD_EXECUTE dd dic_WORD_EXIT dd dic_WORD_FETCH dd dic_WORD_FETCH2 dd dic_WORD_FETCHBYTE dd dic_WORD_FETCHSHORT dd dic_WORD_FILL dd dic_WORD_FIND dd dic_WORD_FIND_DICT dd dic_WORD_FMDIVMOD dd dic_WORD_FROMR dd dic_WORD_FROMR2 dd dic_WORD_GT dd dic_WORD_GTEQ dd dic_WORD_HEADER_COMMA dd dic_WORD_HIDDEN dd dic_WORD_IMMEDIATE dd dic_WORD_INCR dd dic_WORD_INCR2 dd dic_WORD_INCR4 dd dic_WORD_INHASH dd dic_WORD_INLINE_COMMA dd dic_WORD_INTERP dd dic_WORD_INTERPNAME dd dic_WORD_INTERPRET dd dic_WORD_INVERT dd dic_WORD_ISNOTSPACE dd dic_WORD_ISSPACE dd dic_WORD_KEY dd dic_WORD_LATEST dd dic_WORD_LBRAC dd dic_WORD_LINESIZE dd dic_WORD_LIT_COMMA dd dic_WORD_LSHIFT dd dic_WORD_LSYSCALL dd dic_WORD_LT dd dic_WORD_LTEQ dd dic_WORD_MAX dd dic_WORD_MIN dd dic_WORD_MMINUS dd dic_WORD_MOD dd dic_WORD_MOVE dd dic_WORD_MPLUS dd dic_WORD_MSLASH dd dic_WORD_MULDIV dd dic_WORD_MULL dd dic_WORD_MULSTAR dd dic_WORD_NE dd dic_WORD_NEGATE dd dic_WORD_NFROMR dd dic_WORD_NIP dd dic_WORD_NIP2 dd dic_WORD_NQDUP dd dic_WORD_NROT dd dic_WORD_NTOR dd dic_WORD_OR dd dic_WORD_OVER dd dic_WORD_OVER2 dd dic_WORD_O_APPEND dd dic_WORD_O_CREAT dd dic_WORD_O_EXCL dd dic_WORD_O_NONBLOCK dd dic_WORD_O_RDONLY dd dic_WORD_O_RDWR dd dic_WORD_O_TRUNC dd dic_WORD_O_WRONLY dd dic_WORD_PARSENAME dd dic_WORD_PICK dd dic_WORD_POSTPONE dd dic_WORD_QDUP dd dic_WORD_RBRAC dd dic_WORD_RDROP dd dic_WORD_RDROP2 dd dic_WORD_READCHAR dd dic_WORD_READLINE dd dic_WORD_REFILL dd dic_WORD_RFETCH dd dic_WORD_RFETCH2 dd dic_WORD_ROT dd dic_WORD_ROT2 dd dic_WORD_RSHIFT dd dic_WORD_RSPFETCH dd dic_WORD_RSPSTORE dd dic_WORD_RSTORE dd dic_WORD_RZ dd dic_WORD_SEMICOLON dd dic_WORD_SLITS dd dic_WORD_SMDIVREM dd dic_WORD_SOURCE dd dic_WORD_SOURCEFD dd dic_WORD_SSTRING dd dic_WORD_STARSMOD dd dic_WORD_STATE dd dic_WORD_STOD dd dic_WORD_STORE dd dic_WORD_STORE2 dd dic_WORD_STOREBYTE dd dic_WORD_STORESHORT dd dic_WORD_SUB dd dic_WORD_SUBSTORE dd dic_WORD_SWAP dd dic_WORD_SWAP2 dd dic_WORD_SYSCALL dd dic_WORD_SYS_CLOSE dd dic_WORD_SYS_EXIT dd dic_WORD_SYS_FSTAT dd dic_WORD_SYS_FSYNC dd dic_WORD_SYS_FTRUNCATE dd dic_WORD_SYS_LSEEK dd dic_WORD_SYS_OPEN dd dic_WORD_SYS_READ dd dic_WORD_SYS_RENAME dd dic_WORD_SYS_STAT dd dic_WORD_SYS_UNLINK dd dic_WORD_SYS_WRITE dd dic_WORD_SZ dd dic_WORD_TABSTOSPACES dd dic_WORD_TCFA dd dic_WORD_TICKS dd dic_WORD_TOIN dd dic_WORD_TONUMBER dd dic_WORD_TOR dd dic_WORD_TOR2 dd dic_WORD_TOSNUMBER dd dic_WORD_TRAILING dd dic_WORD_TUCK dd dic_WORD_TUCK2 dd dic_WORD_TWODIV dd dic_WORD_TWOMUL dd dic_WORD_TYPE dd dic_WORD_TYPE_FD dd dic_WORD_UDIVMOD dd dic_WORD_UGT dd dic_WORD_UGTEQ dd dic_WORD_ULT dd dic_WORD_ULTEQ dd dic_WORD_UMDIVMOD dd dic_WORD_UMULSTAR dd dic_WORD_UNUSED dd dic_WORD_VERSION dd dic_WORD_WORDBUF dd dic_WORD_WORDNAME dd dic_WORD_XOR dd dic_WORD_XTSKIP dd dic_WORD_ZBRANCH dd dic_WORD_ZEQ dd dic_WORD_ZGT dd dic_WORD_ZGTEQ dd dic_WORD_ZLT dd dic_WORD_ZLTEQ dd dic_WORD_ZNE dd dic_WORD__F_HIDDEN dd dic_WORD__F_IMMED dd dic_WORD__F_LENMASK dd dic_WORD__H_NAME dd dic_WORD__H_NSIZE dd dic_WORD__XT_BODY dd dic_WORD__XT_COMPILE dd dic_WORD__XT_LENGTH dd dic_WORD__XT_SIZE dd dic_WORD_TEST dictionary_end: ;;;;;;;;;;;;;;;;;;;;;;;;;; ; room for user dictionary ;;;;;;;;;;;;;;;;;;;;;;;;;; times USER_DEFS_SIZE db 0 forth_end: