runforth: ./forth hi.forth
cat hi.forth - | ./forth
+.PHONY=runseedforth
+runseedforth: seedForth seedForthDemo.seed
+ cat seedForthDemo.seed | ./seedForth
+
+
.PHONY=test
test: preForth.pre preForth-$(PLATFORM)-backend.pre load-$(PLATFORM)-preForth.fs
cat preForth-$(PLATFORM)-backend.pre simpleForth.pre | $(HOSTFORTH) load-$(PLATFORM)-preForth.fs
EXT=asm
endif
+seedForth-i386.asm: seedForth-i386.pre preForth
+ cat seedForth-i386.pre | ./preForth >seedForth-i386.asm
+
# preForth connected to stdin - output to preForth.asm
preForth.asm: preForth.pre preForth-$(PLATFORM)-backend.pre load-$(PLATFORM)-preForth.fs
cat preForth-$(PLATFORM)-rts.pre preForth-rts.pre preForth-$(PLATFORM)-backend.pre preForth.pre \
%.asm: %.simple simpleForth simpleForth-$(PLATFORM)-rts.simple simpleForth-rts.simple
cat simpleForth-$(PLATFORM)-rts.simple simpleForth-rts.simple $< | ./simpleForth >$@
+# ------------------------------------------------------------------------
+# seedForth
+# ------------------------------------------------------------------------
+seedForth.$(EXT): seedForth-$(PLATFORM).pre preForth
+ cat seedForth-$(PLATFORM).pre | ./preForth >seedForth.$(EXT)
+
+seedForth: seedForth.$(UNIXFLAVOUR)
+ cp seedForth.$(UNIXFLAVOUR) seedForth
+
+%.seed: %.seedsource seedForth-tokenizer.fs
+ gforth seedForth-tokenizer.fs $<
+
.PHONY=clean
clean:
- rm -f *.asm *.o *.fas *.s *.c *.Darwin *.Linux preForthdemo simpleForthDemo simpleForth preForth forth
+ rm -f *.asm *.o *.fas *.s *.c *.Darwin *.Linux preForthdemo simpleForthDemo simpleForth preForth forth seedForth seedForthDemo.seed
--- /dev/null
+\ seedForth - seed it, feed it, grow it - i386 (32 bit) ITC flavour uho 2018-04-13
+\ ----------------------------------------------------------------------------------
+\
+\ - registers:
+\ EAX, EDX general purpose
+\ ESI instruction pointer
+\ EBP return stack pointer
+\ ESP data stack pointer
+
+prelude
+;;; This is seedForth - a small, potentially interactive Forth, that dynamically
+;;; bootstraps from a minimal kernel.
+;;;
+;;; cat seedForth.seed - | ./seedForth
+;;;
+;;; .seed-files are in byte-tokenized source code format.
+;;;
+;;; Use the seedForth tokenizer to convert human readable source code to byte-token form.
+;
+
+prefix
+format ELF
+
+section '.bss' executable writable
+
+ DD 10000 dup(0)
+stck: DD 16 dup(0)
+
+ DD 10000 dup(0)
+rstck: DD 16 dup(0)
+
+_dp: DD _start ; dictionary pointer: points to next free location in memory
+ ; free memory starts at _start
+
+_hp: DD 0 ; head pointer: points to first unused head
+_head: DD 10000 dup (0)
+
+
+section '.text' executable writable align 4096
+
+public main
+extrn putchar
+extrn getchar
+extrn fflush
+extrn exit
+extrn mprotect
+
+macro next {
+ lodsd
+ jmp dword [eax]
+}
+
+origin:
+
+main: cld
+ mov esp, dword stck
+ mov ebp, dword rstck
+
+ ; make section writable
+ push ebp
+ mov ebp, esp
+ sub esp, 16
+ and esp, 0xfffffff0
+ mov dword [esp+8], 7 ; rwx
+ mov eax, memtop
+ sub eax, origin
+ mov dword [esp+4], eax
+ mov dword [esp], origin
+ call mprotect
+ mov esp, ebp
+ pop ebp
+ or eax, eax ; error?
+ jz main0
+ push ebp
+ mov ebp, esp
+ push eax
+ and esp, 0xfffffff0
+ ; call __error ; get error code on Mac OS
+ ; mov eax, [eax]
+ ; call __errno_location ; get error on Linux
+ ; mov eax, [eax]
+ mov [esp], eax
+ call exit
+
+main0: mov esi, main1
+ next
+
+main1: DD _cold
+ DD _bye
+
+_nest: lea ebp, [ebp-4]
+ mov [ebp], esi
+ lea esi, [eax+4]
+ next
+
+_dodoes: ; ( -- addr ) \ call me
+ lea ebp, [ebp-4] ; push IP
+ mov [ebp], esi
+ pop esi ; set IP to caller
+_dovar: ; ( -- addr )
+ lea eax,[eax+4] ; to parameter field
+ push eax
+ next
+
+_O = 0
+
+;
+
+
+code bye ( -- )
+ push ebp
+ mov ebp, esp
+ and esp, 0xfffffff0
+ mov eax, 0
+ mov [esp], eax
+ call exit
+;
+
+code emit ( c -- )
+ pop eax
+
+ push ebp
+ mov ebp, esp
+ push eax
+ and esp, 0xfffffff0
+
+ mov dword [esp], eax
+ call putchar
+
+ mov eax, 0
+ mov [esp], eax
+ call fflush ; flush all output streams
+
+ mov esp, ebp
+ pop ebp
+ next
+;
+
+code key ( -- c )
+ push ebp
+ mov ebp, esp
+ and esp, 0xfffffff0
+
+ call getchar
+ mov esp, ebp
+ pop ebp
+ cmp eax,-1
+ jnz key1
+ mov eax,4
+key1: push eax
+ next
+;
+
+code dup ( x -- x x )
+ pop eax
+ push eax
+ push eax
+ next
+;
+
+code swap ( x y -- y x )
+ pop edx
+ pop eax
+ push edx
+ push eax
+ next
+;
+
+code drop ( x -- )
+ pop eax
+ next
+;
+
+code 0< ( x -- flag )
+ pop eax
+ or eax, eax
+ mov eax, 0
+ jns zless1
+ dec eax
+zless1: push eax
+ next
+;
+
+code ?exit ( f -- )
+ pop eax
+ or eax, eax
+ jz qexit1
+ mov esi, [ebp]
+ lea ebp,[ebp+4]
+qexit1: next
+;
+
+code >r ( x -- ) ( R -- x )
+ pop ebx
+ lea ebp,[ebp-4]
+ mov [ebp], ebx
+ next
+;
+
+code r> ( R x -- ) ( -- x )
+ mov eax,[ebp]
+ lea ebp, [ebp+4]
+ push eax
+ next
+;
+
+code - ( x1 x2 -- x3 )
+ pop edx
+ pop eax
+ sub eax, edx
+ push eax
+ next
+;
+
+code unnest ( -- )
+ mov esi,[ebp]
+ lea ebp,[ebp+4]
+ next
+;
+
+code lit ( -- )
+ lodsd
+ push eax
+ next
+;
+
+code @ ( addr -- x )
+ pop eax
+ mov eax,[eax]
+ push eax
+ next
+;
+
+code c@ ( c-addr -- c )
+ pop edx
+ xor eax, eax
+ mov al,byte [edx]
+ push eax
+ next
+;
+
+code ! ( x addr -- )
+ pop edx
+ pop eax
+ mov dword [edx],eax
+ next
+;
+
+code c! ( c c-addr -- )
+ pop edx
+ pop eax
+ mov byte [edx], al
+ next
+;
+
+code execute ( xt -- ) \ native code: >r :
+ pop eax
+ jmp dword [eax]
+;
+
+code branch ( -- ) \ threaded code: r> @ >r ;
+ lodsd
+ mov esi,eax
+ next
+;
+
+code ?branch ( f -- ) \ threaded code: ?exit r> @ >r ;
+ pop eax
+ or eax,eax
+ jz _branchX
+ lea esi,[esi+4]
+ next
+;
+
+: negate ( n1 -- n2 )
+ 0 swap - ;
+
+: + ( x1 x2 -- x3 )
+ negate - ;
+
+: 0= ( x -- flag )
+ 0 swap ?exit drop -1 ;
+
+: ?dup ( x -- x x | 0 )
+ dup 0= ?exit dup ;
+
+: cells ( x1 -- x2 )
+ dup + dup + ;
+
+: +! ( x addr -- )
+ swap >r dup @ r> + swap ! ;
+
+: h@ ( i -- addr )
+ cells lit head + @ ;
+
+: h! ( x i -- )
+ cells lit head + ! ;
+
+: h, ( x -- )
+ lit hp @ h! 1 lit hp +! ;
+
+: here ( -- addr )
+ lit dp @ ;
+
+: allot ( n -- )
+ lit dp +! ;
+
+: , ( x -- )
+ here 1 cells allot ! ;
+
+: c, ( c -- )
+ here 1 allot c! ;
+
+: interpreter ( -- )
+ key h@ execute tail interpreter ;
+
+: compiler ( -- )
+ key ?dup 0= ?exit h@ , tail compiler ;
+
+: fun ( -- )
+ here h, lit nest , compiler ;
+
+
+: create ( -- )
+ here h, lit dovar , ;
+
+: ,call ( x -- )
+ 232 c, here >r 0 , here - r> ! ; \ call near 32bit
+
+: does ( -- )
+ r> lit hp @ 1 - h@ ! ; \ set code field of last defined word
+
+: does> ( -- )
+ lit does ,
+ lit dodoes ,call ;
+
+
+: cold ( -- )
+ 's' emit 'e' dup emit emit 'd' emit 10 emit
+ lit bye h, \ 0 00
+ lit emit h, \ 1 01
+ lit key h, \ 2 02
+ lit dup h, \ 3 03
+ lit swap h, \ 4 04
+ lit drop h, \ 5 05
+ lit 0< h, \ 6 06
+ lit ?exit h, \ 7 07
+ lit >r h, \ 8 08
+ lit r> h, \ 9 09
+ lit - h, \ 10 0A
+ lit unnest h, \ 11 0B
+ lit lit h, \ 12 0C
+ lit @ h, \ 13 0D
+ lit c@ h, \ 14 0E
+ lit ! h, \ 15 0F
+ lit c! h, \ 16 10
+ lit execute h, \ 17 11
+ lit branch h, \ 18 12
+ lit ?branch h, \ 19 13
+ lit negate h, \ 20 14
+ lit + h, \ 21 15
+ lit 0= h, \ 22 16
+ lit ?dup h, \ 23 17
+ lit cells h, \ 24 18
+ lit +! h, \ 25 19
+ lit h@ h, \ 26 1A
+ lit h, h, \ 27 1B
+ lit here h, \ 28 1C
+ lit allot h, \ 29 1D
+ lit , h, \ 30 1E
+ lit c, h, \ 31 1F
+ lit fun h, \ 32 20
+ lit interpreter h, \ 33 21
+ lit compiler h, \ 34 22
+ lit create h, \ 35 23
+ lit does> h, \ 36 24
+ lit cold h, \ 37 25
+ tail interpreter ;
+
+pre
+ _start: DB 43
+ DD 10000 dup (0)
+ memtop: DD 0
+;
--- /dev/null
+\ seedForth tokenizer (byte-tokenized source code)
+
+\ load on on top of gforth uho 2018-04-13
+
+\ -----------------------------
+
+WARNINGS OFF
+
+VARIABLE OUT
+
+: PROGRAM ( <name> -- )
+ BL WORD COUNT R/W CREATE-FILE THROW OUT ! ;
+
+: SUBMIT ( c -- )
+ PAD C! PAD 1 OUT @ WRITE-FILE THROW ;
+
+: END ( -- )
+ .S CR 0 SUBMIT OUT @ CLOSE-FILE THROW BYE ;
+
+
+Variable #FUNS 0 #FUNS !
+: FUN: ( <name> -- )
+ CREATE #FUNS @ , 1 #FUNS +!
+ DOES> @ SUBMIT ;
+
+FUN: bye FUN: emit FUN: key FUN: dup \ 00 01 02 03
+FUN: swap FUN: drop FUN: 0< FUN: ?exit \ 04 05 06 07
+FUN: >r FUN: r> FUN: - FUN: unnest \ 08 09 0A 0B
+FUN: lit FUN: @ FUN: c@ FUN: ! \ 0C 0D 0E 0F
+FUN: c! FUN: execute FUN: branch FUN: ?branch \ 10 11 12 13
+FUN: negate FUN: + FUN: 0= FUN: ?dup \ 14 15 16 17
+FUN: cells FUN: +! FUN: h@ FUN: h, \ 18 19 1A 1B
+FUN: here FUN: allot FUN: , FUN: c, \ 1C 1D 1E 1F
+FUN: fun FUN: interpreter FUN: compiler FUN: create \ 20 21 22 23
+FUN: does> FUN: cold \ 24 25
+
+: [ ( -- ) 0 SUBMIT ;
+: ] ( -- ) compiler ;
+
+: ': ( <name> -- ) FUN: fun ;
+: ;' ( -- ) unnest [ ;
+
+: # ( x -- ) key SUBMIT ; \ x is placed in the token file as a single byte, as defined by key/SUBMIT
+: #, ( x -- ) lit [ # , ] ; \ x is placed in memory as a cell-sized quantity (32/64 bit), as defined by comma
+
+\ Control structure macros
+
+: AHEAD ( -- addr ) branch [ here 0 # , ] ;
+: IF ( -- addr ) ?branch [ here 0 # , ] ;
+: THEN ( addr -- ) [ here swap ! ] ;
+: ELSE ( addr1 -- addr2 ) branch [ here 0 # , swap ] THEN ;
+
+: BEGIN ( -- addr ) [ here ] ;
+: AGAIN ( addr -- ) branch [ , ] ;
+: UNTIL ( addr -- ) ?branch [ , ] ;
+: WHILE ( addr1 -- addr2 addr1 ) IF [ swap ] ;
+: REPEAT ( addr -- ) AGAIN THEN ;
--- /dev/null
+\ seedForth demo program source
+\
+\ tokenize with
+\
+\ gforth seedForth-tokinzer.fs seedForthDemo.seedsource
+\
+\ then pipe into seedForth:
+\
+\ cat seedForthDemo.seed | ./seedForth
+\
+
+program seedForthDemo.seed
+
+'o' # 'k' # \ push stack marker. Used eventually below.
+
+': ?ok ( o k -- o k ) 10 #, emit >r dup emit r> dup emit ;'
+
+?ok
+
+10 # emit '*' # dup emit emit \ interpret numbers and words
+
+': 3* dup dup + + ;' \ defintions
+': 1- 1 #, - ;' \ compile number and words
+
+\ output utilities
+': cr ( -- ) 10 #, emit ;'
+': space ( -- ) 32 #, emit ;'
+': .digit ( n -- ) '0' #, + emit ;'
+
+': star ( -- ) '*' #, emit ;'
+
+': stars ( n -- )
+ ?dup IF BEGIN star 1- ?dup 0= UNTIL THEN ;' \ standard Forth control structures
+
+': dash ( -- ) '-' #, emit ;'
+
+': dashes ( n -- ) BEGIN ?dup WHILE dash 1- REPEAT ;'
+
+': --- ( -- ) cr 80 #, dashes ;'
+
+': space ( -- ) 32 #, emit ;'
+
+': spaces ( n -- )
+ BEGIN ?dup 0= ?exit space 1- AGAIN ;' \ another loop variation
+
+---
+
+': countdown ( n -- )
+ ?dup 0= ?exit dup cr .digit 1- countdown ;' \ recursion
+
+cr '2' # emit '*' # emit '3' # emit '=' # emit 2 # 3* .digit \ interpret new definitions
+
+9 # countdown
+
+---
+
+': another-count-down ( n -- )
+ BEGIN dup WHILE dup cr .digit 1- REPEAT drop ;' \ standard Forth control structures
+
+5 # another-count-down
+
+---
+
+': yes? ( f -- )
+ IF 'Y' #, ELSE 'N' #, THEN emit ;' \ standard Forth conditionals
+
+cr 0 # yes? -1 # yes? 1 # yes?
+
+?ok \ display ok again (for error analysis)
+
+---
+
+\ utility words
+
+': 1+ ( x1 -- x2 ) 1 #, + ;'
+
+': over ( x1 x2 -- x1 x2 x1 ) >r dup r> swap ;'
+
+': 2drop ( x1 x2 -- ) drop drop ;'
+
+': nip ( x1 x2 -- x2 ) swap drop ;'
+
+\ ': c, ( c -- ) here 1 #, allot c! ;'
+
+': /string ( x1 x2 x3 -- x4 x5 ) swap over - >r + r> ;'
+
+': count ( addr -- c-addr u ) dup 1+ swap c@ ;'
+
+': type ( c-addr u -- )
+ BEGIN dup WHILE over c@ emit 1 #, /string REPEAT 2drop ;'
+
+here 5 # c, 'H' # c, 'e' # c, 'l' # dup c, c, 'o' # c,
+
+cr count type
+
+\ more utility words
+
+': < ( n1 n2 -- f ) - 0< ;'
+': > ( n1 n2 -- f ) swap < ;'
+': = ( x1 x2 -- f ) - 0= ;'
+
+\ hex number output
+
+': .hexdigit ( n -- ) dup 9 #, > IF lit [ 'A' # 10 # - , ] ELSE '0' #, THEN + emit ;'
+
+': 2* ( x1 -- x2 ) dup + ;'
+
+
+\ if we don't have u2/ but only 2* and 0< we need to implement u2/ with a loop. Candidate for primitive
+': u2/ ( x1 -- x2 )
+ 0 #, 8 #, CELLS 1- BEGIN ?dup WHILE >r 2* over 0< IF 1+ THEN >r 2* r> r> 1- REPEAT nip ;'
+
+': odd? ( x1 -- f ) dup u2/ 2* = 0= ;'
+
+': 2/mod ( x1 -- x2 r ) \ swapped results
+ dup u2/ swap odd? negate ;'
+
+': 16/mod ( x -- x r ) \ swapped results
+ 2/mod >r 2/mod >r 2/mod >r 2/mod 2* r> + 2* r> + 2* r> + ;'
+
+': #### ( x -- )
+ 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r
+ .hexdigit r> .hexdigit r> .hexdigit r> .hexdigit r> .hexdigit
+ r> .hexdigit r> .hexdigit r> .hexdigit space ;'
+
+': (.) ( x -- )
+ ?dup IF 16/mod >r (.) r> .hexdigit THEN ;'
+
+': u. ( x -- )
+ ?dup IF (.) ELSE '0' #, emit THEN space ;'
+
+': . ( n -- ) dup 0< IF '-' #, emit negate THEN u. ;'
+
+cr 100 # negate . \ display negative number
+
+cr here u. \ display larger number
+cr
+
+?ok
+
+---
+
+\ create and defining words
+
+fun: V create 4 # , \ new token for tokenizer and new variable like definition
+
+cr V @ u. \ get value: 4
+
+?ok
+
+---
+
+\ We must split defining words into two parts.
+\ 1) Build up the new word with function index in seedForth
+\ 2) Let the tokenizer create its symbol table entry (then invoke 1)
+
+': _value ( x -- ) create , [ does> ] @ ;' \ a seedForth defining word 1) \ execute does> as it is a compiling word
+: Value ( <name> x -- ) fun: _value ; \ macro 2)
+
+
+': _variable ( x -- ) create 0 #, , [ does> ] ;' \ a seedForth defining word
+: Variable ( <name> -- ) fun: _variable ; \ macro
+
+fun: V1 5 # _value
+cr V1 u. \ use value: 5
+6 # Value v4 v4 u. \ values are initialized from stack: 6
+
+
+fun: V2 _variable
+7 # V2 +! V2 @ u. 8 # V2 ! V2 @ u. \ fetch and store value: 7 8
+
+
+': doconst ( x -- ) [ does> ] @ ;' \ a does> w/o creat path sets behavour
+: Constant ( <name> x -- ) fun: create , doconst ; \ macro
+
+fun: nine create
+ 9 # , \ parameter field
+ doconst \ set behaviour of last word
+
+nine . \ display constant: 9
+
+0 # Constant zero zero . \ constants are similar to values here: 0
+
+?ok
+---
+
+
+\ structured data
+
+': _field ( addr -- addr' ) create over , + [ does> ] @ + ;'
+: Field ( <name> offset size -- offset' ) fun: _field ;
+
+\ define structure
+0 #
+
+1 # cells Field >name
+2 # cells Field >date
+
+Value #person
+
+fun: p1 create #person allot
+
+
+
+cr p1 u. \ start of structure
+
+p1 >name u. \ address calculation
+
+p1 >date u. \ address calculation
+
+cr #person u. \ size of structure
+
+?ok
+---
+
+\ Defered words
+
+': dodefer ( -- ) [ does> ] @ execute ;'
+: Defer ( <name> -- ) fun: create ] star [ dodefer ; \ macro, star is default behaviour
+
+': >body ( xt -- body ) 1 #, cells + ;'
+
+': ' ( -- x ) key h@ ;'
+
+': is ( xt -- ) ' >body ! ;'
+
+
+Defer d1
+
+cr d1 d1 d1 \ display stars
+
+cr ' dash dup . execute \ get execution token of definition
+
+' dash is d1 \ set behaviour of deferred word
+
+cr d1 d1 d1 \ now display dashes
+
+?ok
+
+cr 80 # stars
+
+
+?ok
+cr
+
+2drop
+
+
+end
public / preForth.git / commitdiff