Contents of file "f.4th"

[CREATE] (
    16# E8 C,
    ' DOCOL @ HERE 16# 2 + - ,
    ' >IN , ' @ , ' 1+ , ' DUP , ' C@ , ' LIT , 16# 29 , ' - ,
    ' 0BRANCH , 16# 6 , ' BRANCH , 16# FFEE , ' 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. By the way, I tried using ;S to delimit comments, but could not
get this to work when redirecting input to a disk file, since disk input by
default is RAW mode, and EOL was not recognized as the end of a record. I
even tried setting it to COOKED using INT 21/44, but that didn't work either.
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 two for each word to
your destination. For example, 1+ SP@ @ 0BRANCH 0FFF8 loops back to the 1+,
whereas 1+ SP@ @ 0BRANCH 06 BRANCH 0FFF4 DROP skips forward to DROP and loops
backwards to 1+.)

[CREATE] CREATE
    16# E8 C, ( the CALL opcode)
    ' DOCOL @ HERE 16# 2 + - , ( calls DOCOL)
    ' [CREATE] , ' DUP , ' 0BRANCH , 16# A , ' DUP , ' 1- , ' 1- , ' 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 HIGHLEVEL ( for defining high level words; no states yet for ':')
    16# E8 C, ( the CALL opcode)
    ' DOCOL @ HERE 16# 2 + - , ( calls DOCOL) ( now repeat for new word)
    ' CREATE , ' LIT , 16# E8 , ' C, ,
    ' LIT , ' DOCOL , ' @ , ' HERE , ' 1+ , ' 1+ , ' - , ' , , ' ;S ,

HIGHLEVEL CONSTANT ( for defining constants, which return the value itself)
    ' CREATE , ' LIT , 16# E8 , ' C, , ' LIT , ' @ , ( calls fetch as DOCON)
    ' @ , ' HERE , ' 1+ , ' 1+ , ' - , ' , , ' ;S ,

HIGHLEVEL VARIABLE ( for defining variables, which return address of value)
    ' CREATE , ' LIT , 16# E8 , ' C, , ' LIT , ' NEXT , ( calls NEXT as DOVAR)
    ' @ , ' HERE , ' 1+ , ' 1+ , ' - , ' , , ' ;S ,

HIGHLEVEL NFA ( ca - nfa) ( return NFA for given PFA [=CA, =HASH+DICT])
    ' @ , ' LIT , 16# 5 , ' - , ' DUP , ' COUNT , ' SWAP , ' DROP , ' - ,
    ' 1 , ' - , ' ;S ,

HIGHLEVEL ID.  ( ca -) ( display the name of a word, given its CA)
    ' NFA , ' COUNT , ' TYPE , ' BL , ' EMIT , ' ;S ,

CREATE TYPE  ( addr count -) ( display string on screen)
    16# 59 C, 16# 5A C, 16# B4 C, 16# 40 C, ( pop cx; pop dx; mov ah,40h)
    16# BB C, 1 C, 0 C, 16# CD C, 16# 21 C, ( mov bx,1; int 21h)
    16# E9 C, ' NEXT @ HERE 16# 2 + - , ( jmp NEXT)

CREATE SP@ ( - sp) ( load sp address onto stack) 16# 54 C, ( push SP)
    16# E9 C, ' NEXT @ HERE 16# 2 + - , ( jmp NEXT)

HIGHLEVEL EMIT ( c -) ' SP@ , ' 1 , ' 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, 16# E9 C, ' NEXT @ HERE 16# 2 + - ,
    ( pop ax,bx; push bx,ax,bx; jmp NEXT)

CREATE SWAPBYTES ( N - byteswappedN) 16# 58 C, 16# 86 C, 16# E0 C,
    16# 50 C, 16# E9 C, ' NEXT @ HERE 16# 2 + - ,
    ( pop ax; xchg ah,al; push ax; jmp NEXT)
( By the way, I wanted to use SWAB instead of SWAPBYTES, but it collided
with the CA of ;S. How to know? Tick it and then ID.: ' SWAB ID. shows ;S)

HIGHLEVEL SCRATCH ( - addr) ' HERE , ' LIT , 16# 100 , ' + , ' ;S ,
( 256 from HERE... same as PAD but PAD collided with >IN [same CRC-10].)

VARIABLE BASE36 ( for translating binary to base 36 ASCII: 0123456789ABC...Z)
16# 3130 , 16# 3332 , 16# 3534 , 16# 3736 , 16# 3938 , 16# 4241 ,
16# 4443 , 16# 4645 , 16# 4847 , 16# 4A49 , 16# 4C4B , 16# 4E4D ,
16# 504F , 16# 5251 , 16# 5453 , 16# 5655 , 16# 5857 , 16# 5A59 ,

HIGHLEVEL >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, 16# E9 C, ' NEXT @ HERE 16# 2 + - , ( push dx,ax; jmp NEXT)

HIGHLEVEL . ( n -) ' <# , ' # , ' # , ' # , ' # , ' # , ' #> ,
    ' TYPE , ' BL , ' EMIT , ' ;S ,

HIGHLEVEL JZ, ( ca -) ' LIT , 16# 75 , ' C, , ' LIT , 16# 3 , ' C, , ( jnz $+3)
' LIT , 16# E9 , ' C, , ' @ , ' HERE , ' 1+ , ' 1+ , ' - , ' , , ( jmp addr)
' ;S ,

HIGHLEVEL JMP, ( ca -) ' LIT , 16# E9 , ' C, , ' @ , ' HERE , ( calc addr)
    ' 1+ , ' 1+ , ' - , ' , , ( jmp addr) ' ;S ,

CONSTANT -1 16# FFFF , ( - -1)

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# 4D C, 16# 4D C, 16# 8F C, 16# 46 C,
    0 C, ( dec bp,bp; pop [bp]) ' NEXT JMP,

CREATE R ( - n) 16# FF C, 16# 76 C, 0 C, ' NEXT JMP, ( push [bp]; jmp NEXT)

CREATE R> ( - n) 16# FF C, 16# 76 C, 0 C, 16# 45 C, 16# 45 C,
    ( push [bp]; inc 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 SCRATCH)

HIGHLEVEL HOLD ( c -) ' HLD , ' @ , ' 1- , ' HLD , ' ! , ( update pointer...)
    ' HLD , ' @ , ' C! , ' ;S , ( then store the new char)

HIGHLEVEL <# ' SCRATCH , ' HLD , ' ! , ' ;S ,

HIGHLEVEL # ( n - n) ' 0 , ' BASE , ' @ , ' U/M , ' SWAP ,
    ' >DIGIT , ' HOLD , ' ;S ,

HIGHLEVEL #> ( n - addr c) ' DROP , ' HLD , ' @ , ' SCRATCH , ' OVER ,
    ' - , ' ;S ,

CREATE C! ( c addr -) 16# 5B C, 16# 58 C, 16# 88 C, 16# 7 C, ' NEXT JMP,

HIGHLEVEL WORDS ' DICT , ' @ , ( skip first entry, null) ' 1+ , ' 1+ ,
    ' DICT , ' @ , ' LIT , 16# 800 , ' + , ' OVER , ' - , ' 0BRANCH ,
    16# 12 , ' DUP , ' @ , ' 0BRANCH , 16# 6 , ' DUP , ' ID. ,
    ' BRANCH , 16# FFDC , ' DROP , ' ;S ,

HIGHLEVEL ALLOT ( count -) ' HERE , ' + , ' DP , ' ! , ' ;S ,

HIGHLEVEL WORD ( c - addr) ( Trailing delimiter must exist, or CRASH!)
( also, don't use with BL; use PARSE instead. WORD will crash with BL)
    ' >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)

( This following word was SCAN until I was testing my BTOA program and it
kept dropping out to the command prompt. Then I found SCAN collided with
INTERPRET. Realize that SAFECREATE hadn't been used at this point.)

CREATE SCASB ( c addr - addr') 16# B9 C, 16# FFFF ,
    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 (") ( - addr count) 16# 89 C, 16# F3 C, 16# 43 C, ( mov bx,si; inc bx)
    16# 53 C, 16# 8B C, 16# 4 C,
    16# 30 C, 16# E4 C, ( push bx; mov ax,[si]; xor ah,ah)
    16# 50 C, 1 C, 16# C6 C, 16# 46 C, ( push ax; add si,ax; inc si)
    ' NEXT JMP, ( advance IP to next Forth word before going to NEXT)

HIGHLEVEL "  ' LIT , ' (") , ' , , ( compile CFA of runtime word)
    ' LIT , 16# 22 , ' WORD , ( get string at HERE)
    ' COUNT , ' 1+ , ' ALLOT , ( include it in word being compiled)
    ' DROP , ' ;S ,

HIGHLEVEL bind ( secondary_ca - primary_ca) ( lowercase like postscript)
    ' @ , ' LIT , 16# 2 , ' - , ' ;S ,
    ( actually this isn't postscript 'bind' because it only works on a single
    word, whereas postscript can bind a whole procedure at once)

HIGHLEVEL CR ' LIT , 16# D , ' EMIT , ' LIT , 16# A , ' EMIT , ' ;S ,

HIGHLEVEL DOCOMMAND ( execute command line tail if present)
    ' BUFFER , ' B/BUF , ' BL , ' FILL , ( have to clear it first...)
    ' LIT , 16# 80 , ' COUNT , ' BUFFER , ' SWAP , ' CMOVE ,
    ' BUFFER , ' >IN , ' ! , ' ;S , ( execute DOS command line args)

HIGHLEVEL HELLO
 " postForth v0.9" ' TYPE , ' CR , ' ;S , HELLO ( show banner)

HIGHLEVEL IF ( - addr) ' LIT , ' 0BRANCH , ' , , ( first compile a 0BRANCH)
    ' HERE , ( place address of branch offset on stack)
    ' 0 , ' , ,  ( compile a zero offset for now) ' ;S ,

HIGHLEVEL ENDIF ( addr -) ( Just resolves previous IF or ELSE)
    ' HERE , ' OVER , ' - , ' SWAP , ' ! , ' ;S ,

HIGHLEVEL ELSE ( addr - addr') ( Resolve IF, branch to common code)
    ' LIT , ' BRANCH , ' , , ' HERE , ' 0 , ' , , ' >R , ( save HERE)
    ' ENDIF , ' R> , ' ;S ,

HIGHLEVEL UNTIL ( addr -) ( BEGIN is HERE) ' LIT , ' 0BRANCH , ' , ,
    ' HERE , ' - , ' , , ' ;S ,

CREATE BEGIN ' HERE JMP, ( a faster way of aliasing, just tick and jump)

HIGHLEVEL .S ' SP@ , ' SP0 , ' = , IF " Stack empty" ' TYPE , ' CR , ELSE
    ' SP@ , ' SP0 , BEGIN ' LIT , 16# 2 , ' - ,
    ' DUP , ' @ , ' . , ( show stack items)
    ' 2DUP , ' = , UNTIL ' 2DROP , ' CR , ENDIF ' ;S , ( loop till done)

CONSTANT SP0 0 ,

HIGHLEVEL 2DUP ( n1 n2 - n1 n2 n1 n2) ' OVER , ' OVER , ' ;S ,

HIGHLEVEL 2DROP ( n1 n2 -) ' DROP , ' DROP , ' ;S ,

HIGHLEVEL JNG, ( ca -) ' LIT , 16# 7F , ' C, ,
    ' LIT , 16# 3 , ' C, , ( jg $+3)
    ' LIT , 16# E9 , ' C, ,
    ' @ , ' HERE , ' 1+ , ' 1+ , ' - , ' , , ( jmp addr)
    ' ;S ,

HIGHLEVEL JB, ( ca -) ' LIT , 16# 73 , ' C, ,
    ' LIT , 16# 3 , ' C, , ( jnb $+3)
    ' LIT , 16# E9 , ' C, ,
    ' @ , ' HERE , ' 1+ , ' 1+ , ' - , ' , , ( jmp addr)
    ' ;S ,

HIGHLEVEL JNB, ( ca -) ' LIT , 16# 72 , ' C, ,
    ' LIT , 16# 3 , ' C, , ( jb $+3)
    ' LIT , 16# E9 , ' C, ,
    ' @ , ' HERE , ' 1+ , ' 1+ , ' - , ' , , ( jmp addr)
    ' ;S ,

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,

HIGHLEVEL OPEN ( filename ( accesscode - handle | error)
    ' LIT , 16# 3 , ' AND , ' LIT , 16# 3D00 , ' + , ( AX register)
    ' PARSE , ' COUNT , ' DUP , ' >R , ( so we can 0-terminate it)
    ' SCRATCH , ' SWAP , ' CMOVE , ' 0 , ' R> , ' SCRATCH , ' + , ' C! ,
    ' 0 , ' 0 , ( into BX and CX) ' SCRATCH , ( into DX) ' INT21 , ' ;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 NOT ( n - ~n) 16# 58 C, 16# F7 C, 16# D0 C, 16# 50 C,
    ( pop ax; not ax; push ax)
    ' NEXT JMP,

CREATE INT21 ( ax bx cx dx - errorcode | 0) ( negate on error)
    16# 5A C, 16# 59 C, 16# 5B C, 16# 58 C, ( pop dx,cx,bx,ax)
    16# CD C, 16# 21 C, ( int 21)
    16# 50 C, ( push AX ;result or error code) ' NEG JB, ' NEXT JMP,

HIGHLEVEL <0 ( n - f) ' 0 , ' SWAP , ' > , ' ;S ,

HIGHLEVEL FCREATE ( filename ( attributes - handle | error) ( see OPEN above)
    ' LIT , 16# 7 , ' AND , ' >R , ' LIT , 16# 3C00 , ( service code into AX)
    ' 0 , ( BX ignored) ' R> , ( attributes into CX) ' PARSE , ' COUNT ,
    ' DUP , ' >R , ' SCRATCH , ' SWAP , ' CMOVE , ' 0 , ' R> , ' SCRATCH ,
    ' + , ' C! , ( string now 0-terminated) ' SCRATCH , ( into DX)
    ' INT21 , ' ;S ,

HIGHLEVEL CLOSEFILE ( handle - AX or error negated errorcode)
    ' LIT , 16# 3E00 , ' SWAP , ' 0 , ' 0 , ' INT21 , ' ;S ,

HIGHLEVEL READ ( handle bufsize buffer - bytes_read | negated_errorcode)
    ' >R , ' >R , ' LIT , 16# 3F00 , ' SWAP , ' R> , ' R> , ' INT21 , ' ;S ,

HIGHLEVEL WRITE ( handle #bytes buffer - bytes_written | negated_errorcode)
    ' >R , ' >R , ' LIT , 16# 4000 , ' SWAP , ' R> , ' R> , ' INT21 , ' ;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)

HIGHLEVEL SAVESYSTEM ( filename ( -))
    ' 0 , ' FCREATE , ' DUP , ' <0 , IF " SAVE aborted: " ' TYPE ,
    ' NEG , ' . , ' CR , ELSE ' DUP , ( we'll need the handle again later)
    ' HERE , ' LIT , 16# 100 , ' - , ( image size now calculated)
    ' LIT , 16# 100 , ' WRITE , ' BASE , ' @ , ' SWAP , ' DECIMAL ,
    ' . , " bytes written" ' TYPE , ' CR , ' BASE , ' ! , 
    ' CLOSEFILE , ' DROP ( ignore CLOSE status) , ENDIF ' ;S ,

HIGHLEVEL EXIT ( errorlevel -) ( Exit to DOS with ERRORLEVEL set)
    ' LIT , 16# FF , ' AND , ' LIT , 16# 4C00 , ' + , ' 0 , ' 0 , ' 0 ,
    ' INT21 , ' ;S ,

HIGHLEVEL 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,

HIGHLEVEL * ' 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 d@ ( - 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,

HIGHLEVEL Z= ( n - f) ' 0 , ' = , ' ;S ,

HIGHLEVEL ASC ( - n) ' PARSE , ' 1+ , ' C@ , ' LIT , ' LIT ,
    ( compile the CA of LIT) ' , , ' , , ' ;S ,

CREATE OR ( 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,

HIGHLEVEL DMP ( addr count -) BEGIN ' SWAP , ' DUP , ' @ , ' . , ' LIT ,
    16# 2 , ' + , ( advance addr) ' SWAP ,
    ' LIT , 16# 2 , ' - , ( decrement count)
    ' DUP , ' <0 , UNTIL ' ;S ,

HIGHLEVEL >EMIT ( c handle -) ' >R , ' SP@ , ' 1 , ' R> , ' >TYPE ,
    ' DROP , ' ;S ,

CREATE >TYPE  ( addr count handle -) ( send string to device)
    16# 5B C, 16# 59 C, 16# 5A C, 16# B4 C,
    16# 40 C, ( pop bx,cx,dx; mov ah,40h)
    16# CD C, 16# 21 C, ( mov bx,1; int 21h)
    16# E9 C, ' NEXT JMP,