Contents of file "f.s"

;#  postFORTH - minimal postscript/FORTH bootstrap
;#  Copyright (C) 1999 John Comeau <jcomeau@world.std.com>
;#
;#  This program is free software; you can redistribute it and/or modify
;#  it under the terms of the GNU General Public License as published by
;#  the Free Software Foundation; either version 2 of the License, or
;#  (at your option) any later version.
;#
;#  This program is distributed in the hope that it will be useful,
;#  but WITHOUT ANY WARRANTY; without even the implied warranty of
;#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;#  GNU General Public License for more details.
;#
;#  You should have received a copy of the GNU General Public License
;#  along with this program; if not, write to the Free Software
;#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
;#
;#Virtual Memory Map:
;#00000000 - 08048000 Reserved
;#08048000 - 08048074 ELF header information
;#08048074 - 0804A000 (Approximately) core dictionary
;#next 4 values dependent on bss_size; they're about right for 0x80000
;#0804A000 - 080816E4 Extensions to dictionary
;#080816E4 - 080C16E4 CAs calculated from hashes of the Forth words
;#080C16E4 - 080C96E8 32K buffer, for block I/O and TIB, followed by null byte
;#080C96E8 - BFFFF604 (Approximately) Reserved (until kernel-assigned stack)
;#BFFFED04 - BFFFF604 Return Stack
;#BFFFF604 - BFFFFE04 Parameter Stack
;#BFFFFE04 - C0000000 Args, environment, other info passed in by Kernel
;#C0000000 - FFFFFFFF Reserved
;#
;#Word structure:
;#Code word LIT starts at 0x8048074:
;# 03  4C  49  54  03  00  00  00  00  81  80  04  08  AD  50  EB  0E
;#  3   L   I   T   3    00000000        08048081      LODSW;PUSH AX;JMP NEXT
;# Count and word LIT;   Back Link;   Code Address     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 (DOS version).
;#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 coldstart complete.
;# This Forth switches to high level using CALL DOCOL+4; >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'.
;# Count words using the following:
;# grep '^\(create\|constant\|highlevel\|variable\)' f.s | wc
;# 2000-09-29 counted 45, 2 more than I thought!
;#debug=-1 ;#change to zero, or comment out, when debugged.
;#
cellsize=4 ;# 2 for DOS, 4 for linux
const=(cellsize*2)+1 ;# 5 for DOS, 9 for linux
;#
    .section .text, "awx", @progbits ;#the 'w' seems to be ignored by ld...
    .global _start
    .equ _start, cold+cellsize ;# get rid of legacy 'jmp' from FIG-forth
;#All words in this Forth are immediate, and it's stateless,
;# so there's no need for any flag bits or "smudge".
hashbits=15 ;#determines size of dict, (cellsize**hashbits)*2
dictsize=cellsize << hashbits ;#same as (cellsize**hashbits)*2
bitmask=dictsize-1 ;#logical-AND with a number to make it fit dictsize
stacksize=0x800 ;#size for parameter and return stacks
buffersize=0x8000 ;#size of screen/disk block
bss_size = 0x30000 ;#size of data section, must match fixup in Makefile
;#if using Linux stack, leave 0xff00 at end of input buffer for PARSE
buffer=bss_size-buffersize-cellsize ;# add to _edata
9: ;# just so macro doesn't fail on LIT
.macro create label, word
    backlink_\label=9b
    backlink_lit=0 ;# first word has 0 for backlink
9:  .byte 1f-0f
0:  .ascii "\word"
1:  .byte .-0b
    .long backlink_\label
\label: .long .+cellsize ;#primary CA
    .endm
;#define how code words will be defined
.macro variable label, word, value ;#variable definition
    create \label,\word
    call nextword+cellsize ;#leaves address of variable on the stack
    .long \value
    .endm
.macro constant label, word, value ;#constant definition
    create \label, \word
    call fetch+cellsize ;#same code as DOCON, so why waste another word?
    .long \value
    .endm
.macro highlevel label, word ;#colon definition
    create \label, \word
    call docol+cellsize
    .endm
.macro next
    jmp nextword+cellsize
    .endm
;#
create lit, "LIT"
    lodsl ;#get (IP)+
    push %eax
    next
create nextword, "NEXT" ;#also serves as DOVAR if CALLed
    lodsl ;#get CA and advance the pointer
    jmp *(%eax) ;#jump to the code procedure that begins every Forth word
create docol, "DOCOL"
    sub $cellsize,%ebp ;# make room on return stack
    mov %esi,(%ebp) ;#save return address
    pop %esi ;#get CA of defined word, most often another DOCOL (!)
    next ;#here we go again
create unnest, "\x3bS" ;#high-level return (compiles to ;S aka semis)
    mov (%ebp),%esi ;#restore address of caller
    add $cellsize,%ebp ;#advance pointer
    next
create execute, "EXECUTE"
    pop %ebx ;#get address of operation to perform
    jmp *(%ebx) ;#go do it
create tocode, ">CODE"
;#( addr -)
    mov %esi,%ebx ;#get address of machine code inline with this highlevel word
    mov (%ebp),%esi ;#restore address of caller, like ;S
    add $cellsize,%ebp ;#adjust return stack
    jmp *%ebx ;#jump directly into code routine
create store, "!"
;#( n addr -) ;#store n at addr
    pop %ebx
    popl (%ebx) ;#get addr into BX, store n at addr
    next
create input, "INPUT" ;#similar to Forth EXPECT
    mov (bbuf+const),%edx ;#load count and addr from variables
    mov (buf+const),%ecx
    mov $0x3,%eax ;#sys_READ
    xor %ebx,%ebx ;#0 = Standard Input, STDIN
    int $0x80 ;#syscall
    cmpl $0xfffff001, %eax
    jae 1f ;#handle error
    or %eax,%eax ;#see if we got anything
    jz 1f ;#exit if not
    jmp 2f ;#skip to next Forth instruction
1:  mov %eax,%ebx ;#exit code
    mov $1,%eax ;#_exit syscall
    int $0x80 ;#exit
2:  next
create count, "COUNT"
;#(cstring - addr count)
    pop %ebx ;#get address of counted string
    xor %eax,%eax ;#clear count
    mov (%ebx),%al ;#get count byte
    inc %ebx ;#point past it
    push %ebx ;#store address
    push %eax
    next ;#store count
highlevel index, "INDEX" ;#(cstring - index linkaddr) (index into hashtable)
    .long duplicate,count,hash,duplicate,plus,duplicate,plus
    .long lit,bitmask,mask,dict,fetch,plus,swap,count,plus,oneplus,unnest
;#hash function uses Andy Lowry's algorithm from Kermit book p.257
create hash, "HASH" ;#(addr count - hash) (hash a counted string)
    pop %ecx ;#get count
    pop %ebx ;#get address of counted string
    xchg %ebx,%esi ;#move it where we can use it best
    xor %edi,%edi ;#clear hash accumulator
    or %ecx,%ecx ;#can't safely use 16-bit instructions jcxz
    jz 2f ;#skip hard part if nothing there
    push %ebp ;#save return stack pointer
    mov $010201,%ebp ;#use it for multiplier
1:  xor %eax,%eax ;#clear MSBs
    lodsb ;#get next char
    push %eax ;#save it
    xor %edi,%eax ;# crc ^ c
    and $017,%eax ;# q = (crc ^ c) & 017;
    mul %ebp ;# q * 010201
    shr $4,%edi ;# crc >> 4
    xor %eax,%edi ;# crc = (crc >> 4) ^ (q * 010201);
    pop %eax ;#get c back
    shr $4,%eax ;#high nybble this time
    xor %edi,%eax ;# crc ^ (crc >> 4)
    and $017,%eax ;# q = (crc ^ (c >> 4)) & 017;
    mul %ebp ;# q * 010201
    shr $4,%edi ;# crc >> 4
    xor %eax,%edi ;# crc = (crc >> 4) ^ (q * 010201);
    loop 1b
    pop %ebp ;#restore return stack pointer
2:  push %edi
    xchg %ebx,%esi
    jmp nextword+cellsize
constant buf, "IN", _edata+buffer ;#pointer to input buffer
variable bufptr, ">IN", _edata+buffer ;#offset into buffer, FIG=IN
variable dp, "DP", eod ;#current end of dictionary, HERE
variable latest, "LATEST", enddict ;#NFA of last word defined
variable sp0, "SP0", 0 ;#beginning parameter stack pointer
variable rp0, "RP0", 0 ;#return stack pointer
constant bbuf, "B/BUF", buffersize ;#bytes per block and per screen (same)
constant cell, "CELL", cellsize ;#bytes per word (cell)
constant blank, "S", '  ;#blank, ASCII space character (32, or 20h, forth BL)
constant z, "0", 0 ;#0=stdin
constant one, "1", 1 ;#1=stdout
create oneplus, "1+"
    pop %eax ;#get arg to increment
    inc %eax ;#do so, then back onto stack
    push %eax
    next
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 %eax ;# fill character
    pop %ecx ;# count
    pop %edi ;# 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 (bufptr+const),%edi ;#current pointer into buffer space, Forth IN or >IN
    mov (blank+const),%al ;# <= space (NUL, TAB, CR, LF, etc) are delimiters
1:  scasb ;#go until nondelimiter reached
    jnb 1b ;#loop while blank; depends on nonblank before DI wraps around
    dec %edi ;#point back to first nondelimiter
    cmp $_edata+buffer+buffersize,%edi ;#did we go past buffer?
    jb 2f ;#skip if not
    mov $_edata+buffer+buffersize,%edi ;#point to null just past buffer
2:  mov %edi,%ebx ;#address of string
3:  scasb ;#compare to blank
    jb 3b ;#loop if nonblank
    dec %edi ;#adjust for overshoot
    mov %edi,(bufptr+const) ;#update >IN
    sub %ebx,%edi ;#calculate byte count...
    mov %edi,%eax ;#into AX
    mov (dp+const),%edi ;#get HERE location
    stosb ;#store count byte
    xchg %esi,%ebx ;#save Forth IP while we use SI to store the string
    mov %eax,%ecx ;#copy count where it counts
    rep
    movsb ;#store the string
    xchg %esi,%ebx ;#restore IP before we get careless and mess it up
    pushl (dp+const) ;#pointer to counted word
    next
variable dict, "DICT", _edata+buffer-dictsize ;#buffer for hashes
create cold, "COLD"
    mov (sp0+const),%eax ;#check if SP0 already initialized
    or %eax,%eax ;#check for 0
    jnz 1f ;#skip if already initialized
    mov %esp,(sp0+const) ;#save initial SP
    mov %esp,%ebp ;#copy into RS pointer
    sub $stacksize,%ebp ;#make return stack a safe(?) distance lower
    mov %ebp,(rp0+const) ;#save initial return stack pointer
1:  mov (sp0+const),%esp ;#set our own stack pointer
    mov (rp0+const),%ebp ;#set return stack pointer
    movl $0xff00,(__bss_start+bss_size-cellsize) ;#init end of input buffer
    call docol+cellsize ;#high level for the next part
    .long dict,fetch,lit,dictsize,z,fill ;#init hash table
    .long z,latest,fetch ;#push 0 as end marker, start at end of dictionary
2:  .long duplicate,zbranch,3f-.,duplicate,index,swap,drop,fetch,branch,2b-.
3:  .long drop ;#get rid of null from LIT's backlink
4:  .long duplicate,zbranch,5f-. ;#done if reached null
    .long index,lit,2*cellsize,plus,swap,store ;#pointer to code in hashtable
    .long branch,4b-. ;#loop until null reached
5:  .long drop,quit ;#drop the null, launch into query-interpret loop
;# downside to this approach: leaves COLD on return stack
;# upside: now you can redirect QUIT to make a turnkey system
create comma, ","
;#(n - ) ;#compile n at next available location and advance the pointer
    mov (dp+const),%ebx ;#next available location into BX
    pop (%ebx) ;#store n at HERE
    add $cellsize,%ebx ;#advance pointer
    mov %ebx,(dp+const) ;#store pointer where it belongs
    next
create ccomma, "C,"
;#(b - ) ;# compile byte at next available location and advance pointer
    pop %eax ;#get byte to compile
    movl (dp+const),%ebx ;#get HERE
    mov %al,(%ebx) ;#store the byte
    incl (dp+const) ;#update pointer
    next
highlevel hexnumber, "16#" ;#input hexadecimal number (as in postscript)
;#( - n) ;#only hexadecimal, 0-9, uppercase A-F
    .long parse,tocode
    pop %ebx ;#pointer to number
    mov (%ebx),%cl ;#get count byte
    xor %eax,%eax  ;#start off with zero
1:  inc %ebx  ;#point to next digit
    mov (%ebx),%dl ;#grab it
    test $0x40,%dl ;#see if letter (assuming only 0-9, A-F)
    jz 2f ;#skip if not
    sub $7,%dl ;#make "A" = "9" + 1
2:  sub $'0,%dl ;#bring it to the correct value
    shl $4,%eax ;#will only work on 386 or better
    or  %dl,%al ;#merge in this digit
    loop 1b ;#until done
    push %eax
    next ;#place converted number on stack
highlevel tick, "'"
;#( - n) ;#take counted string and return number on stack
    .long parse ;#count the word and store at end of dictionary
    .long index,drop,unnest ;#hash the word and drop the linkword
highlevel quit, "QUIT"
1:  .long buf,bbuf,blank,fill ;#clear buffer
    .long buf,bufptr,store ;#zero buffer pointer
    .long input,interpret,branch,1b-. ;#get and process commands; loop forever
create swap, "SWAP"
;#( n1 n2 - n2 n1) ;#swap top 2 stack items
    pop %eax
    pop %ebx
    push %eax
    push %ebx
    next
create plus, "+"
;#( n1 n2 - n3) ;#returns n3=n1+n2
    pop %ebx
    pop %eax
    add %ebx,%eax
    push %eax
    next
create minus, "-"
;#( n1 n2 - n3) ;#returns n3=n1-n2
    pop %ebx
    pop %eax
    sub %ebx,%eax
    push %eax
    next
create mask, "&"
;#(n1 n2 - n3) ;#returns n3=n1&n2
    pop %eax
    pop %ebx
    and %ebx,%eax
    push %eax
    next
highlevel interpret, "INTERPRET" ;#stateless, loops forever
1:  .long parse,index,drop,execute,branch,1b-. ;#until null or ;S
create null, "\0"
    jmp unnest+cellsize
create duplicate, "DUP"
;#( n - n n) ;#duplicate top stack item
    pop %eax
    push %eax
    push %eax
    next
create drop, "DROP"
;#( n -) ;#eliminate top stack element
    pop %eax
    next
create branch, "BRANCH"
    add (%esi),%esi ;#update Forth IP
    next
create zbranch, "0BRANCH"
    pop %eax ;#see if zero on top of stack
    or %eax,%eax
    jz branch+cellsize ;#if so, join common code with unconditional BRANCH
    lodsl ;#else skip the branch offset
    next
create fetch, "@"
;#( addr - n)
    pop %ebx
    pushl (%ebx)
    next
create cfetch, "C@"
;#( addr - b)
    pop %ebx
    xor %eax,%eax ;#clear MSBs
    mov (%ebx),%al ;#get byte at pointer
    push %eax
    next
highlevel here, "HERE"
	.long dp, fetch, unnest ;#next compiler location
highlevel bcreate, "[CREATE]" ;#create full header ( - oldCA)
    .long here ;#first get current dictionary pointer for LATEST !
    .long parse,count,plus,dp,store ;#counted string, first part of header
    .long duplicate,count,ccomma,drop ;#store final count byte
    .long latest,fetch,comma ;#back pointer to previous word
    .long latest,store ;#update latest to point to this word
    .long latest,fetch,index,drop,fetch ;#previous CA if any, leave on stack
    .long here,lit,cellsize,plus,duplicate,comma ;#first CA
    .long latest,fetch,index,drop,store,unnest ;#2nd CA
eod=.
enddict=9b ;#last link in dictionary