Contents of file "f.a86"

; - -
;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:
;| 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.
    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
create macro
    ##if #s2 lt 3 ;if not string, compile as byte
    db #s2, #2, #s2 ;count, string, count
    db (#s2-2), #2, (#s2-2) ;don't count quotes
    ##endif ;#s2 lt 3
    dw  linkword
#1: dw $+2 ;primary CA
;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
constant macro ;constant definition
    create #1,#2
    call fetch+2 ;same code as DOCON, so why waste another word?
    dw  #3
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
      forth #x
next macro
    #rx1l ;pass any args on stack
    push #x
    jmp nextword+2
debug_mov macro ;any other instruction can be done the same way
    ##if debug
    mov #1,#2
debug_variable macro
    ##if debug
    variable #1,#2,#3
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
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
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
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
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
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
create branch, 'BRANCH'
    add si,[si] ;update Forth IP
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
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
enddict=linkword ;last link in dictionary