[CREATE] ( 16# E8 C, ' DOCOL @ HERE CELL + - , ' >IN , ' @ , ' 1+ , ' DUP , ' C@ , ' LIT , 16# 29 , ' - , ' 0BRANCH , 16# C , ' BRANCH , 16# FFFFFFDC , ' 1+ , ' 1+ , ' >IN , ' ! , ' ;S , DROP ( the null CA placed on stack by [CREATE]) ( The above compiled '(', which allows comments... perhaps the most important thing at this point. The first two lines merely create the header for the word; see the CREATE statement below for the details. The following lines set up a loop searching for the right parenthesis, and, when found, sets >IN just past it. Since I haven't yet coded words like IF and DO, the branches are being calculated by hand. This really isn't such a big deal... consider the word that contains the offset to be offset 0, then count CELL for each word to your destination. For example, 1+ SP@ @ 0BRANCH 0FFF0 loops back to the 1+, whereas 1+ SP@ @ 0BRANCH 0C BRANCH 0FFE8 DROP skips forward to DROP and loops backwards to 1+.) [CREATE] CREATE 16# E8 C, ( the CALL opcode) ' DOCOL @ HERE CELL + - , ( calls DOCOL) ' [CREATE] , ' DUP , ' 0BRANCH , 16# 14 , ' DUP , ' CELL , ' - , ' ID. , ( the above code printed any preexisting word with the same hash value) ' DROP , ' ;S , ( the CA placed on stack by [CREATE]) DROP ( the null CA placed on stack by [CREATE]) CREATE : ( for defining high level words, but stateless) 16# E8 C, ( the CALL opcode) ' DOCOL @ HERE CELL + - , ( calls DOCOL) ( now repeat for new word) ' CREATE , ' LIT , 16# E8 , ' C, , ' LIT , ' DOCOL , ' @ , ' HERE , ' CELL , ' + , ' - , ' , , ' ;S , : JMP, ( ca -) ' LIT , 16# E9 , ' C, , ' @ , ' HERE , ( calc addr) ' CELL , ' + , ' - , ' , , ( jmp addr) ' ;S , : CALL, ( ca -) ' LIT , 16# E8 , ' C, , ' @ , ' HERE , ( calc addr) ' CELL , ' + , ' - , ' , , ( call addr) ' ;S , : CONSTANT ( for defining constants, which return the value itself) ' CREATE , ' LIT , 16# E8 , ' C, , ' LIT , ' @ , ( calls fetch as DOCON) ' @ , ' HERE , ' CELL , ' + , ' - , ' , , ' ;S , : VARIABLE ( for defining variables, which return address of value) ' CREATE , ' LIT , 16# E8 , ' C, , ' LIT , ' NEXT , ( calls NEXT as DOVAR) ' @ , ' HERE , ' CELL , ' + , ' - , ' , , ' ;S , : NFA ( ca - nfa) ( return NFA for given PFA [=CA, =HASH+DICT]) ' @ , ' LIT , 16# 9 , ' - , ' DUP , ' COUNT , ' SWAP , ' DROP , ' - , ' 1 , ' - , ' ;S , : ID. ( ca -) ( display the name of a word to STDERR, given its CA) ' NFA , ' COUNT , ' 2 , ' TYPE , ' S , ' 2 , ' EMIT , ' ;S , : CELLS ( n - n1) ' CELL , ' * , ' ;S , CREATE TYPE ( addr count filehandle -) ( display string) 16# 5B C, 16# 5A C, 16# 59 C, 16# B8 C, 16# 4 , ( pop bx,dx,cx; mov ax,4h) 16# CD C, 16# 80 C, ( int 80h) ' NEXT JMP, CREATE SP@ ( - sp) ( load sp address onto stack) 16# 54 C, ( push SP) ' NEXT JMP, CREATE SP! ( ptr -) ( store ptr from stack as new SP) 16# 5C C, ( pop SP) ' NEXT JMP, : +! ( n addr - ) ( add n to contents of addr) ' SWAP , ' OVER , ' @ , ' + , ' SWAP , ' ! , ' ;S , : EMIT ( c filehandle -) ' >R , ' SP@ , ' 1 , ' R> , ' TYPE , ' DROP , ' ;S , CREATE OVER ( n1 n2 - n1 n2 n1) 16# 58 C, 16# 5B C, 16# 53 C, 16# 50 C, 16# 53 C, ' NEXT JMP, ( pop ax,bx; push bx,ax,bx; jmp NEXT) CREATE SWAB ( N - byteswappedN) 16# 58 C, 16# 86 C, 16# E0 C, 16# 50 C, ' NEXT JMP, ( pop ax; xchg ah,al; push ax; jmp NEXT) : S, ( s -) ( compile short [16-bit integer]) ' , , ' HERE , ' 2 , ' - , ' DP , ' ! , ' ;S , VARIABLE PADOFFSET 0 , : PAD ( - addr) ' HERE , ' LIT , 16# 100 , ' + , ' ;S , : NEWPAD ( - addr) ' PAD , ' PADOFFSET , ' @ , ' + , ' ;S , : RESET ( - ) ( set PAD to normal offset) ' 0 , ' PADOFFSET , ' ! , ' ;S , VARIABLE BASE36 ( for translating binary to base 36 ASCII: 0123456789ABC...Z) 16# 33323130 , 16# 37363534 , 16# 42413938 , 16# 46454443 , 16# 4A494847 , 16# 4E4D4C4B , 16# 5251504F , 16# 56555453 , 16# 5A595857 , : ASCII ( -n) ( convert an ASCII character to its numerical value) ' PARSE , ' 1+ , ' C@ , ' ;S , : >DIGIT ( n - c) ( Translate low byte to uppercase base36 digit) ' BASE36 , ' + , ' C@ , ' ;S , CREATE U/M ( d n - n1 n2) ( Return quotient n2 and remainder n1 from d/n) 16# 5B C, 16# 5A C, 16# 58 C, 16# F7 C, 16# F3 C, ( pop bx,dx,ax; div bx;) 16# 52 C, 16# 50 C, ' NEXT JMP, ( push dx,ax; jmp NEXT) : / ( n1 n2 - n3) ( return quotient n3 from n1/n2) ' 0 , ' SWAP , ' U/M , ' SWAP , ' DROP , ' ;S , : % ( n1 n2 - n3) ( return modulus n3 from n1/n2) ' 0 , ' SWAP , ' U/M , ' DROP , ' ;S , : . ( n -) ( display number to STDERR) ' <# , ( begin number conversion) ' # , ' # , ' # , ' # , ' # , ' # , ' # , ' # , ' # , ( show leading 0) ' #> , ' 2 , ' TYPE , ' S , ' 2 , ' EMIT , ' ;S , : JZ, ( ca -) ' LIT , 16# 75 , ' C, , ' LIT , 16# 5 , ' C, , ( jnz $+5) ' LIT , 16# E9 , ' C, , ' @ , ' HERE , ' CELL , ' + , ' - , ' , , ( jmp addr) ' ;S , CONSTANT -1 16# FFFFFFFF , ( - -1) CONSTANT 2 16# 2 , ( - 2) CREATE = ( n1 n2 - f) 16# 58 C, 16# 5B C, 16# 29 C, 16# D8 C, ( pop ax,bx; sub ax,bx) ' -1 JZ, ' 0 JMP, ( true if Z set after subtraction, otherwise false) ( Remember that even though this Forth has deferred binding, a word MUST BE DEFINED before it is used, otherwise its CA will be null and will therefore drop you out of the program. That's why we had to define JZ, and JMP, above.) CREATE >R ( n -) 16# 83 C, 16# ED C, CELL C, ( sub cell,bp) 16# 89 C, 16# EB C, 16# 8F C, 16# 3 C, ( mov bx,bp; pop [bx]) ' NEXT JMP, CREATE R ( - n) 16# FF C, 16# B5 C, 0 , ' NEXT JMP, ( push 0[bp]; jmp NEXT) CREATE R> ( - n) 16# FF C, 16# B5 C, 0 , ( push 0[bp]) 16# 45 C, 16# 45 C, 16# 45 C, 16# 45 C, ( inc bp,bp,bp,bp) ' NEXT JMP, CREATE 1- 16# 58 C, 16# 48 C, 16# 50 C, ( pop ax; dec ax; push ax) ' NEXT JMP, VARIABLE BASE 16# 10 , ( default base hexadecimal) ( Remember that numeric input is still hex, regardless of what BASE is) VARIABLE HLD 0 , ( pointer into number conversion space below PAD) : HOLD ( c -) ' HLD , ' @ , ' 1- , ' HLD , ' ! , ( update pointer...) ' HLD , ' @ , ' C! , ' ;S , ( then store the new char) : <# ' PAD , ' HLD , ' ! , ' ;S , : # ( n - n) ' 0 , ' BASE , ' @ , ' U/M , ' SWAP , ' >DIGIT , ' HOLD , ' ;S , : #> ( n - addr c) ' DROP , ' HLD , ' @ , ' PAD , ' OVER , ' - , ' ;S , CREATE C! ( c addr -) 16# 5F C, 16# 58 C, 16# 88 C, 16# 7 C, ' NEXT JMP, ( pop di,ax; mov al,[di]) : WORDS ' DICT , ' @ , ( location of hashtable) ' CELL , ' + , ( skip first entry, null) ' DICT , ' @ , ' LIT , 16# 20000 , ' + , ( end of hashtable) ' OVER , ' - , ' 0BRANCH , 16# 24 , ( done if reached end) ' DUP , ' @ , ' 0BRANCH , 16# C , ' DUP , ' ID. , ( show word if exists) ' BRANCH , 16# FFFFFFB8 , ( loop back until end of hashtable reached) ' DROP , ' ;S , ( clean current pointer off stack) : ALLOT ( count -) ' HERE , ' + , ' DP , ' ! , ' ;S , : WORD ( c - addr) ( Trailing delimiter must exist, or crash!) ( also, don't use with S; use PARSE instead. WORD will crash with S) ' >IN , ' @ , ( get current position in input buffer) ' SWAP , ' OVER , ' SCASB , ' OVER , ' - , ( count to trailing delimiter) ' SWAP , ' OVER , ' HERE , ' SWAP , ' CMOVE , ( copy string to HERE) ' DUP , ' 1- , ' HERE , ' C! , ( store count overwriting first blank) ' >IN , ' @ , ' + , ' 1+ , ' >IN , ' ! , ( point >IN past delimiter) ' HERE , ' ;S , ( return addr of counted string) CREATE SCASB ( c addr - addr') 16# B9 C, -1 , 16# 5F C, ( mov cx, 0ffff; pop di) 16# 58 C, 16# F2 C, 16# AE C, 16# 4F C, ( pop ax; repnz scasb; dec di) 16# 57 C, ( push di) ' NEXT JMP, CREATE CMOVE ( from to count -) 16# 59 C, 16# 5F C, 16# 5B C, ( pop cx,di,bx) 16# 87 C, 16# F3 C, ( xchg si,bx) 16# F3 C, 16# A4 C, ( rep movsb) 16# 89 C, 16# DE C, ( mov si,bx) ' NEXT JMP, CREATE CMPS ( s1 s2 count -) 16# 59 C, 16# 5F C, 16# 5B C, ( pop cx,di,bx) 16# 87 C, 16# F3 C, ( xchg si,bx) 16# F3 C, 16# A6 C, ( rep cmpsb) 16# 89 C, 16# DE C, ( mov si,bx) ' -1 JZ, ' 0 JMP, CREATE (") ( - addr count) 16# 31 C, 16# C0 C, 16# AC C, 16# 56 C, ( xor ax,ax; lodsb; push si) 16# 50 C, 16# 40 C, 16# 01 C, 16# C6 C, ( push ax; inc ax; add si,ax) ' NEXT JMP, ( advance IP to next Forth word before going to NEXT) : " ' LIT , ' (") , ' , , ( compile CFA of runtime word) ' LIT , 16# 22 , ' WORD , ( get string at HERE) ' COUNT , ' 1+ , ' ALLOT , ( include it in word being compiled) ' 0 , ' C, , ' DROP , ' ;S , ( follow with C-style null byte) : S" ( - addr n) ( put string into NEWPAD, update PADOFFSET, and return COUNT) ' LIT , 16# 22 , ' WORD , ( string to HERE) ' COUNT , ' DUP , ' >R , ' NEWPAD , ' SWAP , ' CMOVE , ( copy to NEWPAD) ' PAD , ' R> , ( follow with c-style null byte) ' OVER , ' OVER , ' + , ' 0 , ' SWAP , ' C! , ' DUP , ' 1+ , ' PADOFFSET , ' +! , ' ;S , : BIND ( secondary_ca - primary_ca) ' @ , ' CELL , ' - , ' ;S , ( this isn't postscript 'bind' because it only works on a single word, whereas postscript can bind a whole procedure at once) : CR ( filehandle -) ( send carriage return/linefeed) ' LIT , 16# A , ' SWAP , ' EMIT , ' ;S , : HELLO " postFORTH 0.04.08.10 Copyright (C) 2004 jc@jcomeau.com postFORTH comes with ABSOLUTELY NO WARRANTY. This is free software, and you are welcome to redistribute it under certain conditions; see the file COPYING for details. " ' 2 , ' TYPE , ' 2 , ' CR , " Type WORDS to see a word list. Type Control-D to exit. " ' 2 , ' TYPE , ' 2 , ' CR , ' ;S , : IF ( - addr) ' LIT , ' 0BRANCH , ' , , ( first compile a 0BRANCH) ' HERE , ( place address of branch offset on stack) ' 0 , ' , , ( compile a zero offset for now) ' ;S , : ENDIF ( addr -) ( Just resolves previous IF or ELSE) ' HERE , ' OVER , ' - , ' SWAP , ' ! , ' ;S , : ELSE ( addr - addr') ( Resolve IF, branch to common code) ' LIT , ' BRANCH , ' , , ' HERE , ' 0 , ' , , ' >R , ( save HERE) ' ENDIF , ' R> , ' ;S , : UNTIL ( addr -) ( BEGIN is HERE) ' LIT , ' 0BRANCH , ' , , ' HERE , ' - , ' , , ' ;S , : AGAIN ( addr -) ( BEGIN is HERE) ' LIT , ' BRANCH , ' , , ' HERE , ' - , ' , , ' ;S , CREATE BEGIN ' HERE JMP, ( a faster way of aliasing, just tick and jump) : DO ( -) ( set up DO loop for runtime execution) ' LIT , ' (DO) , ' , , ( compile the runtime word) ' HERE , ' ;S , ( then push the next location on the stack for LOOP) : LOOP ' LIT , ' (LOOP) , ' , , ( compile the runtime word) ' HERE , ' - , ' , , ' ;S , ( compile the branch offset) : +LOOP ( -) ' LIT , ' (+LOOP) , ' , , ( compile the runtime word) ' HERE , ' - , ' , , ' ;S , ( compile the branch offset) : -LOOP ( -) ' LIT , ' (-LOOP) , ' , , ( compile the runtime word) ' HERE , ' - , ' , , ' ;S , ( compile the branch offset) : .S ( ... - ...) ( show stack items to STDERR) ' SP@ , ' SP0 , ' @ , ' = , IF " Stack empty" ' 2 , ' TYPE , ' 2 , ' CR , ELSE ' SP@ , ' SP0 , ' @ , BEGIN ' CELL , ' - , ' DUP , ' @ , ' . , ( show stack items) ' 2DUP , ' = , UNTIL ' 2DROP , ' 2 , ' CR , ' 2 , ' CR , ENDIF ' ;S , ( loop till done) CREATE RP@ ( - n) ( return current return stack pointer) 16# 55 C, ( push bp) ' NEXT JMP, : BT ( -) ( like Unix backtrace, shows return stack) ' RP@ , ' LIT , 16# 8 , ' + , ( skip this EXECUTE) ' RP0 , ' @ , ' = , IF " Return stack empty" ' 2 , ' TYPE , ' 2 , ' CR , ELSE ' RP0 , ' @ , ' CELL , ' - , ( RP0 - CELL has first entry) ' RP@ , ' CELL , ' + , ( skip the EXECUTE that brought us here) BEGIN ' DUP , ' @ , ' CELL , ' - , ' @ , ' ID. , ' CELL , ' + , ' 2DUP , ' = , ( add CELL each time until equal) UNTIL ' 2DROP , ' 2 , ' CR , ENDIF ' ;S , : 2DUP ( n1 n2 - n1 n2 n1 n2) ' OVER , ' OVER , ' ;S , : 2DROP ( n1 n2 -) ' DROP , ' DROP , ' ;S , : JG, ( ca -) ' LIT , 16# 7E , ' C, , ' LIT , 16# 5 , ' C, , ( jle $+5) ' LIT , 16# E9 , ' C, , ' @ , ' HERE , ' CELL , ' + , ' - , ' , , ( jmp addr) ' ;S , : JNG, ( ca -) ' LIT , 16# 7F , ' C, , ' LIT , 16# 5 , ' C, , ( jg $+5) ' LIT , 16# E9 , ' C, , ' @ , ' HERE , ' CELL , ' + , ' - , ' , , ( jmp addr) ' ;S , : JB, ( ca -) ' LIT , 16# 73 , ' C, , ' LIT , 16# 5 , ' C, , ( jnb $+5) ' LIT , 16# E9 , ' C, , ' @ , ' HERE , ' CELL , ' + , ' - , ' , , ( jmp addr) ' ;S , : JNB, ( ca -) ' LIT , 16# 72 , ' C, , ' LIT , 16# 5 , ' C, , ( jb $+5) ' LIT , 16# E9 , ' C, , ' @ , ' HERE , ' CELL , ' + , ' - , ' , , ( jmp addr) ' ;S , CREATE (DO) ( n1 n2 -) ( copy n1 [limit] to TOR, then n2 [start] to TOR) 16# 83 C, 16# ED C, 16# 8 C, ( sub bp, 8) 16# 58 C, 16# 89 C, 16# 45 C, 16# 0 C, ( pop ax; mov [bp+0], ax) 16# 58 C, 16# 89 C, 16# 45 C, CELL C, ( pop ax; mov [bp+cell], ax) ' NEXT JMP, CREATE (LOOP) ( -) ( increment index, check if done and branch if not) 16# FF C, 16# 85 C, 0 , ( incl [bp]) 16# 8B C, 16# 5D C, 0 C, ( mov bx,[bp]) 16# 3B C, 16# 5D C, CELL C, ( cmp bx,[bp+cell]) ' BRANCH JB, 16# 83 C, 16# C5 C, 16# 8 C, ( add bp, 8) ( clear off return stack) 16# AD C, ' NEXT JMP, ( lods; next) ( skip branch offset, on to next word) CREATE (+LOOP) ( n -) ( add to index, check if done and branch if not) 16# 5B C, 1 C, 16# 5D C, 0 C, ( pop bx; add [bp],bx) 16# 8B C, 16# 5D C, 0 C, ( mov bx,[bp]) 16# 3B C, 16# 5D C, CELL C, ( cmp bx,[bp+cell]) ' BRANCH JB, 16# 83 C, 16# C5 C, 16# 8 C, ( add bp, 8) ( clear off return stack) 16# AD C, ' NEXT JMP, ( lods; next) ( skip branch offset, on to next word) CREATE (-LOOP) ( n -) ( subtract from index, check if done and branch if not) 16# 5B C, 16# 29 C, 16# 5D C, 0 C, ( pop bx; sub [bp],bx) 16# 8B C, 16# 5D C, 0 C, ( mov bx,[bp]) 16# 3B C, 16# 5D C, CELL C, ( cmp bx,[bp+cell]) ' BRANCH JNB, 16# 83 C, 16# C5 C, 16# 8 C, ( add bp, 8) ( clear off return stack) 16# AD C, ' NEXT JMP, ( lods; next) ( skip branch offset, on to next word) CREATE > ( n1 n2 - f) ( TRUE if n1 > n2) 16# 5B C, 16# 58 C, ( pop bx,ax) 16# 39 C, 16# D8 C, ( cmp ax,bx) ' 0 JNG, ' -1 JMP, CREATE < ( n1 n2 - f) ( TRUE if n1 < n2) 16# 58 C, 16# 5B C, ( pop ax,bx) 16# 39 C, 16# D8 C, ( cmp ax,bx) ' 0 JNG, ' -1 JMP, : OPEN ( addr n access modbits - handle | error) ' >R , ( save modbits) ' >R , ( save access code) ' DUP , ' >R , ( so we can 0-terminate string) ' PAD , ' SWAP , ' CMOVE , ' 0 , ' R> , ' PAD , ' + , ' C! , ' LIT , 16# 5 , ( syscall into AX register) ' PAD , ( into BX) ' R> , ( access to cx) ' R> , ( modbits to DX) ' SYSCALL , ' ;S , CREATE NEG ( n - -n) 16# 58 C, 16# F7 C, 16# D8 C, 16# 50 C, ( pop ax; neg ax; push ax) ' NEXT JMP, CREATE ~ ( n - ~n) 16# 58 C, 16# F7 C, 16# D0 C, 16# 50 C, ( pop ax; not ax; push ax) ' NEXT JMP, CREATE SYSCALL ( ax bx cx dx - errorcode | result) 16# 5A C, 16# 59 C, 16# 5B C, 16# 58 C, ( pop dx,cx,bx,ax) 16# CD C, 16# 80 C, ( int 80) 16# 50 C, ( push AX ;result or error code) ' NEXT JMP, CREATE SYSCALL5 ( ax bx cx dx si di - errorcode | result) 16# 83 C, 16# ED C, CELL C, ( sub bp,cell) 16# 89 C, 16# 75 C, 0 C, ( mov [bp+0],si) 16# 5F C, 16# 5E C, 16# 5A C, 16# 59 C, 16# 5B C, 16# 58 C, ( pop di,si,dx,cx,bx,ax) 16# CD C, 16# 80 C, ( int 80) 16# 8B C, 16# 75 C, 0 C, ( mov si,[bp]) 16# 83 C, 16# C5 C, CELL C, ( add bp,cell) 16# 50 C, ( push AX ;result or error code) ' NEXT JMP, : 0< ( n - f) ' 0 , ' SWAP , ' > , ' ;S , : FCREATE ( addr n modbits - handle | error) ( see OPEN above) ' LIT , 16# 42 , ( O_RDWR | O_CREAT into CX) ' SWAP , ( modbits into DX) ' OPEN , ' ;S , : CLOSEFILE ( handle - AX or error negated errorcode) ' LIT , 16# 6 , ' SWAP , ' 0 , ' 0 , ' SYSCALL , ' ;S , : READ ( handle bufsize buffer - bytes_read | negated_errorcode) ' >R , ' >R , ' LIT , 16# 3 , ' SWAP , ' R> , ' R> , ' SWAP , ' SYSCALL , ' ;S , : WRITE ( handle #bytes buffer - bytes_written | negated_errorcode) ' >R , ' >R , ' LIT , 16# 4 , ' SWAP , ' R> , ' R> , ' SWAP , ' SYSCALL , ' ;S , VARIABLE INFILE#1 0 , ( stdin to begin with) VARIABLE INFILE#2 0 , ( ditto) VARIABLE OUTFILE1 1 , ( stdout to begin with) VARIABLE OUTFILE2 16# 2 , ( stderr to begin with) : SAVESYSTEM ' LIT , 16# 1ED , ' FCREATE , ' DUP , ' 0< , ' RESET , IF " SAVE aborted: " ' 2 , ' TYPE , ' NEG , ' . , ' 2 , ' CR , ELSE ' DUP , ( we'll need the handle again later) ' LIT , 16# 8048000 , ( load address of ELF executables) ' HERE , ' OVER , ' - , ( image size now calculated) ( now we have to fix up the ELF header before we write the file) ( at this point stack is ( fhandle fhandle location size) ' OVER , ' LIT , 16# 20 , ' + , ' 0 , ' SWAP , ' ! , ( wipe out...) ' OVER , ' LIT , 16# 30 , ' + , ' 0 , ' SWAP , ' ! , ( ...section headers) ' OVER , ' DUP , ' LIT , 16# 1C , ' + , ' @ , ' + , ( 1st phdr) ( now stack is ( fhandle fhandle location size phdr_location) ' OVER , ' OVER , ' LIT , 16# 10 , ' + , ' ! , ( save filesz) ' OVER , ' OVER , ' LIT , 16# 14 , ' + , ' ! , ( save memsz) ' OVER , ' LIT , 16# 3 , ' + , ' LIT , 16# FFFFFFFC , ' & , ( round to word) ( stack now ( fhandle fhandle location size phdr_location bss_offset) ' OVER , ' LIT , 16# 24 , ' + , ' OVER , ' SWAP , ' ! , ( offset of bss) ' LIT , 16# 8048000 , ' + , ( bss_offset now file offset of bss) ' OVER , ' LIT , 16# 28 , ' + , ' OVER , ' SWAP , ' ! , ( vaddr) ' SWAP , ' LIT , 16# 2C , ' + , ' ! , ( paddr) ' SP0 , ' @ , ' >R , ' 0 , ' SP0 , ' ! , ( save and zero SP0) ' SWAP , ' WRITE , ' R> , ' SP0 , ' ! , ' BASE , ' @ , ' SWAP , ' DECIMAL , ' . , " bytes written" ' 2 , ' TYPE , ' 2 , ' CR , ' BASE , ' ! , ' CLOSEFILE , ' DROP ( ignore CLOSE status) , ENDIF ' ;S , : EXIT ( errorlevel -) ( Exit to OS with ERRORLEVEL set) ' 1 , ' SWAP , ' 0 , ' 0 , ' SYSCALL , ' ;S , ( unused CX and DX) : DECIMAL ' LIT , 16# A , ' BASE , ' ! , ' ;S , CREATE UM* ( n n - d) ( unsigned double product of two unsigned singles) 16# 58 C, 16# 5B C, ( pop ax,bx) 16# F7 C, 16# E3 C, ( mul bx) 16# 50 C, 16# 52 C, ( push ax,dx; leave MSBs at top of stack) ' NEXT JMP, : * ' UM* , ' DROP , ' ;S , CREATE D+ ( d1 d2 - d) 16# 5A C, 16# 59 C, 16# 5B C, 16# 58 C, ( pop dx,cx,bx,ax) ( d1 LSBs in ax, d2 LSBs in cx) 1 C, 16# C8 C, ( add ax,cx) ( now subtract MSBs with any borrow) 16# 11 C, 16# D3 C, ( adc bx,dx) 16# 50 C, 16# 53 C, ( push ax,bx; LSBs first) ' NEXT JMP, CREATE D- ( d1 d2 - d) 16# 5A C, 16# 59 C, 16# 5B C, 16# 58 C, ( pop dx,cx,bx,ax) ( d1 LSBs in ax, d2 LSBs in cx) 16# 29 C, 16# C8 C, ( sub ax,cx) ( now subtract MSBs with any borrow) 16# 19 C, 16# D3 C, ( sbb bx,dx) 16# 50 C, 16# 53 C, ( push ax,bx; LSBs first) ' NEXT JMP, CREATE 2@ ( - d) ( doubleword at given location, high word at TOS) 16# 5B C, ( pop bx) 16# FF C, 16# 37 C, ( push [bx]) 16# FF C, 16# 77 C, 16# 2 C, ( push [bx+2]) ' NEXT JMP, CREATE BUMP ( a -) ( bump [increment by one] variable at a) 16# 5B C, ( pop bx) 16# FF C, 16# 7 C, ( inc word ptr bx) ' NEXT JMP, : 0= ( n - f) ' 0 , ' = , ' ;S , : ASC ( - n) ' PARSE , ' 1+ , ' C@ , ' LIT , ' LIT , ( compile the CA of LIT) ' , , ' , , ' ;S , CREATE | ( n1 n2 - n) ( logical OR function) 16# 58 C, 16# 5B C, ( pop ax,bx) 16# 9 C, 16# D8 C, 16# 50 C, ( or ax,bx; push ax) ' NEXT JMP, : DUMP ( addr count -) BEGIN ' SWAP , ' DUP , ' @ , ' . , ' CELL , ' + , ( advance addr) ' SWAP , ' CELL , ' - , ( decrement count) ' DUP , ' 0< , UNTIL ' DROP , ' DROP , ' ;S , : #! ( -) ( indicate to *nix which interpreter to use) ' LIT , 16# A , ' WORD , ' DROP , ' ;S , ( ignore up to next linefeed) : ARGC ( - n) ( return count of args) ' SP0 , ' @ , ' @ , ' ;S , : ARGV[] ( n - addr) ( null-terminated argv[] string) ' DUP , ' ARGC , ' < , ' ~ , ( >= ARGC, point to 0 at end of args) IF ' DROP , ' ARGC , ' 1+ , ' CELLS , ' SP0 , ' @ , ' + , ELSE ' 1+ , ' CELLS , ' SP0 , ' @ , ' + , ' @ , ( get string pointer) ENDIF ' ;S , : LENGTH ( addr - addr n) ( count 0-terminated string) ' DUP , BEGIN ' DUP , ' C@ , ' SWAP , ' 1+ , ' SWAP , ' 0= , UNTIL ' OVER , ' - , ' 1- , ' ;S , : ARGV ( n - addr n2) ( put string from ARGV[] onto stack) ' ARGV[] , ' LENGTH , ' ;S , : TAIL ( execute command line tail if present) ' IN , ' B/BUF , ' S , ' FILL , ( have to clear it first...) ' IN , ' >IN , ' ! , ( init buffer pointer) ' ARGC , ' 2 , ' > , IF ( only if at least pf file.4th) ' LIT , 16# 1 , BEGIN ' 1+ , ( start at 3rd arg) ' DUP , ' ARGV , ' 1+ , ( include trailing null) ' DUP , ' >R , ' >IN , ' @ , ' SWAP , ' CMOVE , ( move string into buffer) ' R> , ' >IN , ' @ , ' + , ' >IN , ' ! , ( update buffer pointer) ' ARGC , ' OVER , ' = , UNTIL ' DROP , ' IN , ' >IN , ' ! , ' INTERPRET , ( execute command line args) ENDIF ' ;S , CREATE << ( n c - n') ( shift n left by c bits) 16# 59 C, 16# 58 C, ( pop cx,ax) 16# D3 C, 16# E0 C, ( shl ax,cl) 16# 50 C, ( push ax) ' NEXT JMP, CREATE >> ( n c - n') ( shift n right by c bits) 16# 59 C, 16# 58 C, ( pop cx,ax) 16# D3 C, 16# E8 C, ( shr ax,cl) 16# 50 C, ( push ax) ' NEXT JMP, : 10# ( - n) ( S: n) ( enter a decimal number) ' 0 , ( start of the translated number) ' PARSE , ' COUNT , ' 0 , DO ' SWAP , ' LIT , 16# A , ' * , ' OVER , ' R , ' + , ' C@ , ' LIT , ASCII 0 , ' - , ' + , ' SWAP , LOOP ' DROP , ( address of the string) ' ;S , : 8# ( - n) ( S: n) ( enter an octal number) ' 0 , ( start of the translated number) ' PARSE , ' COUNT , ' 0 , DO ' SWAP , ' LIT , 16# 3 , ' << , ' OVER , ' R , ' + , ' C@ , ' LIT , ASCII 0 , ' - , ' + , ' SWAP , LOOP ' DROP , ( address of the string) ' ;S , : 2# ( - n) ( S: n) ( enter a binary number) ' 0 , ( start of the translated number) ' PARSE , ' COUNT , ' 0 , DO ' SWAP , ' DUP , ' + , ( same as left shift) ' OVER , ' R , ' + , ' C@ , ' LIT , ASCII 0 , ' - , ' + , ' SWAP , LOOP ' DROP , ( string address) ' ;S , : NOT ( n - !n) ( logical NOT; *nix '!' but we can't use THAT...) IF ' 0 , ELSE ' -1 , ENDIF ' ;S , : HEADER ( addr n -) ( create header from string on stack) ( note that if header format changes, it must be changed here and in f.s) ' HERE , ' >R , ( save current DP) ' DUP , ' C, , ( store first count byte) ' HERE , ' >R , ' DUP , ' ALLOT , ( make space for word name) ' OVER , ' OVER , ' R> , ' SWAP , ' CMOVE , ( and store it) ' DUP , ' C, , ( store 2nd count byte) ' LATEST , ' @ , ' , , ( backlink) ' R , ' LATEST , ' ! , ( update LATEST to point to this word) ' R , ' INDEX , ' DROP , ' @ , ' DUP , ( fetch previous CA if any) IF " Overwriting " ' 2 , ' TYPE , ' CELL , ' - , ' ID. , " with " ' 2 , ' TYPE , ' 2 , ' TYPE , ELSE ' DROP , ' DROP , ' DROP , ( null CA means no hashtable collision) ENDIF ' HERE , ' CELL , ' + , ' DUP , ' , , ( store primary CA) ' R> , ' INDEX , ' DROP , ' ! , ' ;S , ( 2nd CA in hashtable) : EQ ( addr1 n1 addr2 n2 - f) ( test strings for equality) ' >R , ' OVER , ' R> , ' = , IF ( lengths are equal) ' SWAP , ' DUP , ' 0= , IF ' DROP , ' DROP , ' DROP , ' -1 , ( equal if null) ELSE ' CMPS , ENDIF ELSE ' DROP , ' DROP , ' DROP , ' 0 , ENDIF ' ;S , : TASK ' ARGC , ' 1 , ' > , IF ( any arg is a file to be read as STDIN) ' 1 , ' ARGV , ' 0 , ' 0 , ' OPEN , ( open read-only) ' B/BUF , ' IN , ' READ , ' DROP , ' IN , ' >IN , ' ! , ( zero buffer pointer) ' INTERPRET , ' TAIL , ' >CODE , ' QUIT JMP, ELSE ( show banner and launch into normal query-interpret loop) ' HELLO , ' >CODE , ' QUIT JMP, ( jump to original definition of QUIT) ENDIF ' TASK @ ' QUIT BIND ! .S ( let us know if anything left on stack [meaning a bug!]) S" pf" SAVESYSTEM