Contents of file "f.a86"
;postForth.com - jcomeau@world.std.com - http://world.std.com/~jcomeau
;minimal postscript/Forth bootstrap
;
;Memory Map:
;0000 - 0002 JMP to coldstart routine
;0003 - 04FF (Approximately) core dictionary
;0500 - 67FF Extensions to dictionary
;6800 - 6FFF CAs calculated from hashes of the Forth words
;7000 - F000 32K buffer, for block I/O as well as TIB, followed by null byte
;F000 - F7FF Return Stack (RS) (first location contains null byte for EOB)
;F800 - FFFF Parameter Stack (PS)
;
;Word structure:
;Code word LIT:
;|0103|0104|0105|0106|0107|0108|0109|010A|010B|010C|010D|010E|010F|0110|
;| 03 | L | I | T | 03 | 0000 | 010C |LODSW;PUSH AX;JMP NEXT; |
;| Count and word 'LIT' |Back link|Code addr| PFA, runtime LIT code |
;
;Design goals:
;1. No more than 400 lines of source, to make it extremely easy to port
;2. Deferred binding, to make it more like postscript and to allow for
; top-down design of programs, especially the compiler itself.
;3. Only the essential words in assembly, meaning that this bootstrap code
; need not contain any traditional Forth words. As it turns out, it has many.
;4. No more than 1K compiled size.
;5. Each routine must fit in one DOS EDIT screen, 80*24.
;6. Self-documenting, making this file the only one necessary.
;7. Forth words callable in Assembly before the inner interpreter is running.
; This Forth switches to high level using CALL DOCOL+2; >CODE = back to code
;8. Optimized for porting ease first, runtime speed second, programming ease
; third, conformity with standards a distant fourth.
;
;Revision History:
; 8/19/97 could not get it to recognize CRLF as EOL when reading from a file,
; even after setting cooked mode. So I made the buffer size 4K instead of 1K.
; 9/14/97 Changed to 32K buffer, made buffersize variable for easier changes.
; 2000-03-11 now builds dict the right way by pushing all the NFAs on the
; stack first, then starting at 'LIT'. The words are easy to count now: 42
;debug=-1 ;change to zero, or comment out, when debugged.
;
main:
jmp cold+2 ;go to cold-start initialization
linkword=0 ;beginning (end) of dictionary depending on how you look at it...
;All words in this Forth are immediate, and it's stateless,
; so there's no need for any flag bits or "smudge".
hashbits=10 ;determines size of dict, (2**hashbits)*2 (for 16-bit entries)
dictsize=2 shl hashbits ;same as (2**hashbits)*2
bitmask=dictsize-1 ;logical-AND with a number to make it fit dictsize
stacksize=800h ;size for parameter and return stacks
buffersize=8000h ;size of screen/disk block
bufferoffset=10000h-(stacksize*2)-buffersize
create macro
newlink=$
##if #s2 lt 3 ;if not string, compile as byte
db #s2, #2, #s2 ;count, string, count
##else
db (#s2-2), #2, (#s2-2) ;don't count quotes
##endif ;#s2 lt 3
dw linkword
linkword=newlink
#1: dw $+2 ;primary CA
#em
;define how code words will be defined
variable macro ;variable definition
create #1,#2 ;flags don't apply here
call nextword+2 ;leaves address of variable on the stack
dw ;don't initialize variables
#rx3l ;unless specified
dw #x
#er
#em
constant macro ;constant definition
create #1,#2
call fetch+2 ;same code as DOCON, so why waste another word?
dw #3
#em
forth macro ;define a macro for high level words
#rx1l ;means "repeat for x=1 to last"
dw #x ;"define word x, where x is the next argument passed"
#er ;"end repeat loop"
#em ;"end macro"
highlevel macro ;colon definition
create #1,#2
call docol+2
#rx3l
forth #x
#er
#em
next macro
#rx1l ;pass any args on stack
push #x
#er
jmp nextword+2
#em
debug_mov macro ;any other instruction can be done the same way
##if debug
mov #1,#2
##endif
#em
debug_variable macro
##if debug
variable #1,#2,#3
##endif
#em
;
create lit, 'LIT'
lodsw ;get (IP)+
next ax ;place onto stack
create nextword, 'NEXT' ;also serves as DOVAR if CALLed
lodsw ;get CA and advance the pointer
mov bx,ax ;undo one level of indirection
jmp [bx] ;jump to the code procedure that begins every Forth word
create docol, 'DOCOL'
dec bp,bp ;make room on return stack
mov [bp],si ;save return address
pop si ;get CA of defined word, most often another DOCOL (!)
next ;here we go again
create unnest, ';S' ;high-level return
mov si,[bp] ;restore address of caller
inc bp,bp ;advance pointer
next
create execute, 'EXECUTE'
pop bx ;get address of operation to perform
jmp [bx] ;go do it
create tocode, '>CODE'
;( addr -)
mov bx,si ;get address of machine code inline with this highlevel word
mov si,[bp] ;restore address of caller, like ;S
inc bp,bp ;adjust return stack
jmp bx ;jump directly into code routine
create store, '!'
;( n addr -) ;store n at addr
pop bx,[bx] ;get addr into BX, store n at addr
next
create input, 'INPUT' ;similar to Forth EXPECT
mov cx,[bbuf+5] ;load count and addr from variables
mov dx,[buffer+5]
mov ah,3fh ;DOS service READ
xor bx,bx ;0 = Standard Input, STDIN
int 21h ;request DOS service
jc >c1 ;handle error
mov cx,ax ;see if we got anything
jcxz >c1 ;redirect if not
debug_mov w[span+5],cx ;if debugging, save number of input bytes
jmp >c2 ;skip to next Forth instruction
c1: mov bx,2 ;fromhandle=stderr
mov cx,0 ;tohandle=stdin
mov ah,46h ;forced REDIRECT service of DOS (closes tohandle first)
int 21h ;set input to console (same as STDERR, which can't be redirected)
c2: next
create count, 'COUNT'
;(cstring - addr count)
pop bx ;get address of counted string
xor ax,ax ;clear count
mov al,[bx] ;get count byte
inc bx ;point past it
next bx,ax ;store address, count
create hash, 'HASH' ;(cstring - hash linkaddr) ;hash a counted string
pop di ;get address of counted string
xor cx,cx ;clear register
xor dx,dx ;clear hash
mov cl,[di] ;get count first
jcxz >h3 ;skip hard part if so
inc di ;adjust pointer
h1: xor ax,ax ;clear MSBs
mov al,[di] ;get next char
inc di ;adjust pointer
shl dx,4 ;shift existing hash up 4
add dx,ax ;merge in current char: h = (h << 4) + *name++;
mov bx,dx ;copy for next operation: if (g = h & 0xf0000000) h ^= g >> 24;
and bx,0f000h ;shortened for 16-bit arithmetic
mov ax,bx ;copy g for later operation
jz >h2 ;skip if g is 0
shr bx,12 ;24 in 32-bit mode
xor dx,bx ;h ^= g >> 24;
h2: not ax ;h &= ~g;
and dx,ax ;h now new hash
loop h1 ;for each char in name
h3: push di,dx ;link address and hash onto stack
call docol+2 ;to high level
c2: forth duplicate,plus,lit,bitmask,mask,dict,fetch,plus,swap,oneplus,unnest
constant buffer, 'BUFFER', bufferoffset ;pointer to input buffer
variable bufptr, '>IN', bufferoffset ;offset into buffer, FIG=IN
variable dp, 'DP', eod ;current end of dictionary, HERE
variable latest, 'LATEST', enddict ;NFA of last word defined
debug_variable span, 'SPAN', 0 ;number of characters input
sp0=10000h ;beginning parameter stack pointer (PUSH subtracts 2 first)
rp0=10000h-stacksize ;beginning return stack pointer
constant bbuf, 'B/BUF', buffersize ;bytes per block and per screen (same)
constant blank, 'BL', ' ' ;blank, ASCII space character (32, or 20h)
constant z, '0', 0 ;0=stdin
constant one, '1', 1 ;1=stdout
create oneplus, '1+'
pop ax ;get arg to increment
inc ax ;do so, then back onto stack
next ax
create fill, 'FILL' ;do NOT make high level, needed by COLD
; of course that really doesn't matter as long as primary CAs are used
;(addr n b -)
pop ax,cx,di ;fill character, count, start address
rep stosb ;fill memory block with fill character
next
create parse, 'PARSE' ;similar to Forth WORD but doesn't need delimiter
;(- addr) ;returns address where counted word was stored
mov di,[bufptr+5] ;current pointer into buffer space, Forth IN or >IN
mov al,[blank+5] ;space and lower (NUL, TAB, CR, LF, etc) are delimiters
c1: scasb ;go until nondelimiter reached
jnb c1 ;loop while blank; depends on nonblank before DI wraps around
dec di ;point back to first nondelimiter
cmp di,bufferoffset+buffersize ;did we go past buffer?
jb >c2 ;skip if not
mov di,bufferoffset+buffersize ;else point to null just past buffer
c2: mov bx,di ;address of string
c3: scasb ;compare to blank
jb c3 ;loop if nonblank
dec di ;adjust for overshoot
mov [bufptr+5],di ;update >IN
sub di,bx ;calculate byte count...
mov ax,di ;into AX
mov di,[dp+5] ;get HERE location
stosb ;store count byte
xchg si,bx ;save Forth IP while we use SI to store the string
mov cx,ax ;copy count where it counts
rep movsb ;store the string
xchg si,bx ;restore IP before we get careless and mess it up
next [dp+5] ;return pointer to counted word
variable dict, 'DICT', bufferoffset-dictsize ;buffer for hashes
create cold, 'COLD'
mov sp,sp0 ;initialize parameter stack pointer
mov bp,rp0 ;initialize return stack pointer
call docol+2 ;high level for the next part
forth dict,fetch,lit,dictsize,z,fill ;init hash table
forth z,latest,fetch ;push 0 as end marker, start at end of dictionary
c1: forth duplicate,zbranch,>c2-$,duplicate,hash,swap,drop,fetch,branch,c1-$
c2: forth drop,tocode ;drop null, now start at 'lit' and build hashtable
c3: pop cx ;get pointer to next word in dictionary
jcxz >c4 ;quit when done
push cx ;put address on stack for Forth call
call docol+2 ;switch to high level
forth hash,tocode ;produces index and link to next word
pop di,bx ;link into DI, hash table address into BX
mov [bx],di ;store link address? nope...
add w[bx],4 ;adding 4 points to actual code which begins every word
jmp c3 ;loop till 0 found after the final word
c4: jmp quit+2 ;launch into query-interpret loop
create comma, ','
;(n - ) ;compile n at next available location and advance the pointer by 2
mov bx,[dp+5] ;next available location into BX
pop [bx] ;store n at HERE
inc bx,bx ;advance pointer
mov [dp+5],bx ;store pointer where it belongs
next
create ccomma, 'C,'
;(b - ) ; compile byte at next available location and advance pointer
pop ax ;get byte to compile
mov bx,[dp+5] ;get HERE
mov [bx],al ;store the byte
inc w[dp+5] ;update pointer
next
highlevel hexnumber, '16#' ;input hexadecimal number (as in postscript)
;( - n) ;only hexadecimal, 0-9, uppercase A-F
forth parse,tocode
pop bx ;pointer to number
mov cl,[bx] ;get count byte
xor ax,ax ;start off with zero
c1: inc bx ;point to next digit
mov dl,[bx] ;grab it
test dl,40h ;see if letter (assuming only 0-9, A-F)
jz >c2 ;skip if not
sub dl,7 ;make "A" = "9" + 1
c2: sub dl,'0' ;bring it to the correct value
shl ax,4 ;will only work on 386 or better
or al,dl ;merge in this digit
loop c1 ;until done
next ax ;place converted number on stack
highlevel tick, "'"
;( - n);take counted string and return number on stack
forth parse ;count the word and store at end of dictionary
forth hash,drop,unnest ;hash the word and drop the linkword
highlevel quit, 'QUIT'
c1: forth buffer,bbuf,oneplus,blank,fill,input ;clear buffer and get input
forth buffer,bufptr,store ;zero buffer pointer
forth interpret,branch,c1-$ ;interpret the command; loop forever
create swap, 'SWAP'
;( n1 n2 - n2 n1) ;swap top 2 stack items
pop ax,bx
next ax,bx
create plus, '+'
;( n1 n2 - n3) ;returns n3=n1+n2
pop bx,ax
add ax,bx
next ax
create minus, '-'
;( n1 n2 - n3) ;returns n3=n1-n2
pop bx,ax
sub ax,bx
next ax
create mask, '&'
;(n1 n2 - n3) ;returns n3=n1&n2
pop ax,bx
and ax,bx
next ax
highlevel interpret, 'INTERPRET' ;stateless, loops forever
c1: forth parse,hash,drop,execute,branch,c1-$ ;until null or ;S
create null, 0
jmp unnest+2
create duplicate, 'DUP'
;( n - n n) ;duplicate top stack item
pop ax
next ax,ax
create drop, 'DROP'
;( n -) ;eliminate top stack element
pop ax
next
create branch, 'BRANCH'
add si,[si] ;update Forth IP
next
create zbranch, '0BRANCH'
pop cx ;see if zero on top of stack
jcxz branch+2 ;if so, join common code with unconditional BRANCH
lodsw ;else skip the branch offset
next
create fetch, '@'
;( addr - n)
pop bx
next [bx]
create cfetch, 'C@'
;( addr - b)
pop bx
xor ax,ax ;clear MSBs
mov al,[bx] ;get byte at pointer
next ax
highlevel here, 'HERE', dp, fetch, unnest ;next compiler location
highlevel bcreate, '[CREATE]' ;create full header ( - oldCA)
forth here ;first get current dictionary pointer for LATEST !
forth parse,count,plus,dp,store ;counted string, first part of header
forth duplicate,count,ccomma,drop ;store final count byte
forth latest,fetch,comma ;back pointer to previous word
forth latest,store ;update latest to point to this word
forth latest,fetch,hash,drop,fetch ;previous CA if any, leave on stack
forth here,lit,2,plus,duplicate,comma ;first CA
forth latest,fetch,hash,drop,store,unnest ;2nd CA
eod=$
enddict=linkword ;last link in dictionary