diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e1a4c55 --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +*.asm +*.o +*.seed +/preForth/crc10.forth +/preForth/preForth +/preForth/seedForth +/preForth/__temp__.fs diff --git a/preForth/Makefile b/preForth/Makefile index e50cd04..6cff6b4 100644 --- a/preForth/Makefile +++ b/preForth/Makefile @@ -9,14 +9,19 @@ HOSTFORTH=gforth # ------------------------------------------------------------------------ .PHONY=all -all: preForth seedForth seedForthDemo.seed seedForthInteractive.seed +all: \ +preForth \ +seedForth \ +seedForthDemo.seed \ +seedForthBoot.seed \ +seedForthInteractive.seed .PHONY=test test: runseedforthdemo runseedforthinteractive .PHONY=runseedforthdemo runseedforthdemo: seedForth seedForthDemo.seed - cat seedForthDemo.seed | ./seedForth + ./seedForth seedForthDemo.seed .PHONY=runseedfortinteractive runseedforthinteractive: seedForth seedForthInteractive.seed @@ -25,52 +30,66 @@ runseedforthinteractive: seedForth seedForthInteractive.seed UNIXFLAVOUR=$(shell uname -s) EXT=asm -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-i386-backend.pre load-i386-preForth.fs - cat preForth-i386-rts.pre preForth-rts.pre preForth-i386-backend.pre preForth.pre \ - | $(HOSTFORTH) load-i386-preForth.fs >preForth.asm - -preForth: preForth.$(UNIXFLAVOUR) - cp preForth.$(UNIXFLAVOUR) preForth - -%.asm: %.pre preForth preForth-i386-rts.pre preForth-rts.pre - cat preForth-i386-rts.pre preForth-rts.pre $< | ./preForth >$@ - -%: %.$(UNIXFLAVOUR) - cp $< $@ - +preForth.asm: \ +preForth-i386-rts.pre \ +preForth-rts.pre \ +preForth-i386-backend.pre \ +preForth.pre \ +load-i386-preForth.fs + cat \ +preForth-i386-rts.pre \ +preForth-rts.pre \ +preForth-i386-backend.pre \ +preForth.pre \ +|$(HOSTFORTH) load-i386-preForth.fs >preForth.asm + +%.asm: %.pre preForth-i386-rts.pre preForth-rts.pre preForth + ./preForth preForth-i386-rts.pre preForth-rts.pre $< >$@ + +ifeq ($(UNIXFLAVOUR),Linux) # assemble and link executable on linux -%.Linux: %.asm +%: %.asm fasm $< $@.o LDEMULATION=elf_i386 ld -arch i386 -o $@ \ - -dynamic-linker /lib32/ld-linux.so.2 \ - /usr/lib/i386-linux-gnu/crt1.o /usr/lib/i386-linux-gnu/crti.o \ - $@.o \ - -lc /usr/lib/i386-linux-gnu/crtn.o +-dynamic-linker /lib32/ld-linux.so.2 \ +/usr/lib/i386-linux-gnu/crt1.o /usr/lib/i386-linux-gnu/crti.o \ +$@.o \ +-lc /usr/lib/i386-linux-gnu/crtn.o # rm $@.o - +else +ifeq ($(UNIXFLAVOUR),Darwin) # assemble and link executable on MacOS -%.Darwin: %.asm +%: %.asm fasm $< $@.o objconv -fmacho32 -nu $@.o $@_m.o ld -arch i386 -macosx_version_min 10.6 -o $@ \ - $@_m.o /Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/lib/crt1.o /usr/lib/libc.dylib +$@_m.o /Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/lib/crt1.o \ +/usr/lib/libc.dylib # rm $@.o $@_m.o +endif +endif # run preForth on its own source code to perform a bootstrap # should produce identical results -bootstrap: preForth preForth-i386-backend.pre preForth.pre preForth.$(EXT) - cat preForth-i386-rts.pre preForth-rts.pre preForth-i386-backend.pre preForth.pre\ - | ./preForth >preForth1.$(EXT) +bootstrap: \ +preForth-i386-rts.pre \ +preForth-rts.pre \ +preForth-i386-backend.pre \ +preForth.pre \ +preForth \ +preForth.$(EXT) + ./preForth \ +preForth-i386-rts.pre \ +preForth-rts.pre \ +preForth-i386-backend.pre \ +preForth.pre \ +>preForth1.$(EXT) cmp preForth.$(EXT) preForth1.$(EXT) # preForth connected to stdin - output to stdout .PHONY=visible-bootstrap visible-bootstrap: preForth preForth-i386-backend.pre preForth.pre - cat preForth-i386-backend.pre preForth.pre | ./preForth + ./preForth preForth-i386-backend.pre preForth.pre # ------------------------------------------------------------------------ # Docker support (for Linux version) @@ -89,16 +108,48 @@ rundocker: docker-image # ------------------------------------------------------------------------ # seedForth # ------------------------------------------------------------------------ -seedForth.$(EXT): seedForth-i386.pre preForth - cat seedForth-i386.pre | ./preForth >seedForth.$(EXT) - -seedForth: seedForth.$(UNIXFLAVOUR) - cp seedForth.$(UNIXFLAVOUR) seedForth - -%.seed: %.seedsource seedForth-tokenizer.fs - gforth seedForth-tokenizer.fs $< - +seedForth.$(EXT): \ +seedForth-i386-header.pre \ +preForth-i386-rts.pre \ +seedForth-i386.pre \ +seedForth.pre \ +preForth + ./preForth \ +seedForth-i386-header.pre \ +preForth-i386-rts.pre \ +seedForth-i386.pre \ +seedForth.pre \ +>seedForth.$(EXT) + +# a little ugly, because gforth insists upon echoing anything read from +# stdin, and also does not allow parsing words to cross a file boundary, +# so we will concatenate the tokenizer and source into a *.fs file first +seedForthDemo.seed: crc10.forth seedForth-tokenizer.fs seedForthDemo.seedsource + cat $^ >__temp__.fs + gforth __temp__.fs -e bye >$@ + rm __temp__.fs + +seedForthBoot.seed: \ +crc10.forth \ +seedForth-tokenizer.fs \ +seedForthRuntime.seedsource \ +seedForthBoot.seedsource + cat $^ >__temp__.fs + gforth __temp__.fs -e bye >$@ + rm __temp__.fs + +seedForthInteractive.seed: \ +crc10.forth \ +seedForth-tokenizer.fs \ +seedForthRuntime.seedsource \ +seedForthInteractive.seedsource + cat $^ >__temp__.fs + gforth __temp__.fs -e bye >$@ + rm __temp__.fs + +crc10.forth: crc10_gen.forth + gforth $^ -e bye >$@ .PHONY=clean clean: - rm -f *.asm *.o *.fas *.s *.c *.Darwin *.Linux preForthdemo preForth forth seedForth seedForthDemo.seed seedForthInteractive.seed + rm -f *.asm *.o *.seed preForthdemo preForth seedForth __temp__.fs diff --git a/preForth/crc10_gen.forth b/preForth/crc10_gen.forth new file mode 100644 index 0000000..11b94eb --- /dev/null +++ b/preForth/crc10_gen.forth @@ -0,0 +1,50 @@ +\ run this as follows: +\ ./seedForth seedForthBoot.seed runtime.forth crc10_gen.forth >crc10.forth + +817 Constant poly \ CRC-10/ATM, truncated polynomial 0x233, bit reversed 0x331 + +\ we don't want MS-DOS style line endings in the generated CRC table file +: lf 10 emit ; + +: gen + ." Create crc10_tab" lf + 256 0 ?DO + I 8 0 ?DO + \ split into LSB and the remaining bits + \ in seedForth: 2 u/mod swap + \ in gForth: 2 /mod swap + dup 1 rshift swap 1 and + + IF poly xor THEN + LOOP + . ',' emit + I 7 and 7 = IF lf ELSE space THEN + LOOP + lf + ." : crc10 ( addr len crc -- crc )" lf + ." swap 0 ?DO ( addr crc )" lf + ." \ retrieve next character" lf + ." over I + c@" lf + lf + ." \ xor into low bits of crc" lf + ." xor" lf + lf + ." \ separate into table index and remaining bits" lf + ." \ 256 u/mod swap" lf + ." dup 8 rshift swap 255 and" lf + lf + ." \ look up new bits from table" lf + ." cells crc10_tab + @" lf + lf + ." \ combine with remaining (shifted right) bits" lf + ." xor" lf + ." LOOP" lf + ." nip" lf + ." ;" lf + lf + ." \ testing:" lf + ." \ Create hello 104 c, 101 c, 108 c, 108 c, 111 c," lf + ." \ hello 5 1023 crc10 . ;" lf +; + +gen diff --git a/preForth/hi.forth b/preForth/hi.forth index 4cd1091..6515c6c 100644 --- a/preForth/hi.forth +++ b/preForth/hi.forth @@ -1,15 +1,5 @@ -0 echo ! -0 input-echo ! - cr .( ⓪ ) -: ( - ')' parse 2drop ; immediate - -: \ - source nip >in ! ; immediate - - \ save and empty (need HP) single wordlist only no string header reclaim \ HEAD, the start of seedForth header table is not required. \ DP is not required as it can be read via HERE and set via ALLOT (see DP!) @@ -31,71 +21,13 @@ cr .( ⓪ ) \ t{ 3 -> }t \ wrong number of results \ t{ 3 4 + -> 8 }t \ incorrect result -: AHEAD ( -- c:orig ) - postpone branch here 0 , ; immediate - -: IF ( -- c:orig ) - postpone ?branch here 0 , ; immediate - -: THEN ( c:orig -- ) - here swap ! ; immediate - -: ELSE ( c:orig1 -- c:orig2 ) - postpone AHEAD swap postpone THEN ; immediate - -: BEGIN ( -- c:dest ) - here ; immediate - -: WHILE ( c: orig -- c:dest c:orig ) - postpone IF swap ; immediate - -: AGAIN ( c:orig -- ) - postpone branch , ; immediate - -: UNTIL ( c:orig -- ) - postpone ?branch , ; immediate - -: REPEAT ( c:orig c:dest -- ) - postpone AGAIN postpone THEN ; immediate - -\ are these necessary? -\ you can use the phrase dup x = IF drop instead of x case? IF or x OF -: case? ( n1 n2 -- true | n1 false ) - over = dup IF nip THEN ; - -: OF ( n1 n2 -- n1 | ) - postpone case? postpone IF ; immediate - cr .( ① ) cr -: :noname ( -- xt ) - new ] ; - -: Variable ( ) - Create 0 , ; - -: Constant ( x -- ) - Create , Does> @ ; - -0 Constant false -false invert Constant true - - : on ( addr -- ) true swap ! ; : off ( addr -- ) false swap ! ; -: fill ( c-addr u x -- ) - >r BEGIN ( c-addr u ) - dup - WHILE ( c-addr u ) - r@ third c! - 1 /string - REPEAT ( c-addr u ) - 2drop r> drop -; - : erase ( c-addr u -- ) 0 fill ; : blank ( c-addr u -- ) bl fill ; @@ -167,18 +99,6 @@ t{ 1 2 3 4 5 6 2rot -> 3 4 5 6 1 2 }t end-tests -: lshift ( x u -- ) BEGIN ?dup WHILE swap 2* swap 1- REPEAT ; - -\ 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- \ for every bit - BEGIN ( x q n ) - ?dup - WHILE ( x q n ) - >r 2* over 0< IF 1+ THEN >r 2* r> r> 1- - REPEAT ( x q n ) - nip ; - begin-tests t{ -1 u2/ dup 1+ u< -> -1 }t @@ -186,8 +106,6 @@ t{ -1 u2/ 10 + dup 10 + u< -> -1 }t end-tests -: rshift ( x u -- ) BEGIN ?dup WHILE swap u2/ swap 1- REPEAT ; - : s>d ( n -- d ) dup 0< ; t{ 1 3 lshift -> 8 }t @@ -254,9 +172,6 @@ cr .( ② ) \ : test s" xlerb" evaluate ; -: * ( n1 n2 -- ) - 2dup xor 0< >r abs swap abs um* drop r> IF negate THEN ; - : fac ( n -- ) recursive dup 0= IF drop 1 exit THEN dup 1- fac * ; @@ -280,8 +195,6 @@ end-tests : sqr ( u -- u^2 ) dup * ; -: u/ ( u1 u2 -- u3 ) >r 0 r> um/mod nip ; - : sqrt ( u^2 -- u ) dup 0= ?exit dup >r dup @@ -398,18 +311,6 @@ begin-tests end-tests -: FOR ( n -- ) - postpone BEGIN - postpone >r ; immediate - -: NEXT ( -- ) - postpone r> - postpone 1- - postpone dup - postpone 0< - postpone UNTIL - postpone drop ; immediate - : cntdwn 65535 FOR r@ . NEXT ; : ² sqr ; @@ -452,8 +353,6 @@ Variable voc-link 0 voc-link ! ' .voc ' .wordlist backpatch -: recurse ( -- ) last @ _xt @ compile, ; immediate - : cntd ( n -- ) ?dup 0= ?exit dup . 1- recurse '.' emit ; \ division / /mod fm/mod sm/rem mod @@ -810,28 +709,6 @@ cr .( Interactive decompiler: Use single letter commands n d l c b s ) cr cr dump-line REPEAT 2drop ; -\ conditional compilation - -| : next-token ( -- c-addr u ) - BEGIN - parse-name dup 0= - WHILE ( c-addr u ) - 2drop refill 0= -39 and throw - REPEAT ( c-addr u ) ; - -| : ([ELSE]) ( level c-addr u -- level' ) - 2dup s" [IF]" compare 0= IF 2drop 1+ exit THEN - 2dup s" [ELSE]" compare 0= IF 2drop 1- dup IF 1+ THEN exit THEN - s" [THEN]" compare 0= IF 1- THEN ; - -: [ELSE] ( -- ) - 1 BEGIN ( level ) next-token ([ELSE]) ?dup 0= UNTIL ; immediate - -: [IF] ( f -- ) ?exit postpone [ELSE] ; immediate - -: [THEN] ; immediate - - 1 [IF] cr .( ok: if line, ) .( ok: next line) [ELSE] cr .( fail: else line, ) @@ -846,44 +723,8 @@ cr .( Interactive decompiler: Use single letter commands n d l c b s ) cr cr .( ok: afterwords ) -: abort ( -- ) -1 throw ; - -| : (abort") ( f c-addr u -- ) rot IF errormsg 2! -2 throw THEN 2drop ; - -: abort" ( f -- ) - postpone s" - postpone (abort") ; immediate - \ : abort"test ( -- ) dup abort" abort" ; -: chars ; immediate - -: char+ 1+ ; - -' exit Alias EXIT - -: bounds ( addr count -- limit addr) over + swap ; - -: DO ( to from -- ) - postpone swap - postpone BEGIN - postpone >r postpone >r ; immediate - -: LOOP ( -- ) - postpone r> - postpone 1+ - postpone r> - postpone 2dup postpone = postpone UNTIL - postpone 2drop ; immediate - -: I ( -- ) - postpone r@ ; immediate - -\ : ?DO ( to from -- ) -\ postpone 2dup -\ postpone - -\ postpone IF postpone DO ; immediate - begin-tests t{ : dotest 10 0 DO I LOOP ; dotest -> 0 1 2 3 4 5 6 7 8 9 }t diff --git a/preForth/preForth-i386-backend.pre b/preForth/preForth-i386-backend.pre index f218fbb..6881741 100644 --- a/preForth/preForth-i386-backend.pre +++ b/preForth/preForth-i386-backend.pre @@ -23,7 +23,7 @@ 'Q' swap '?' case? ?exit nip 'R' swap '"' case? ?exit nip \ 'S' swap '!' case? ?exit nip - 'T' swap '*' case? ?exit nip + 'T' swap '*' case? ?exit nip 'U' swap '(' case? ?exit nip 'V' swap '|' case? ?exit nip 'W' swap ',' case? ?exit nip @@ -42,22 +42,13 @@ \ output words \ ------------ \ Output is done by emit. -\ We define convenience words of the form ."xxx" to output xxx and >"xxx" to output xxx on a new line indented by a tab. +\ We define convenience words of the form ."xxx" to output xxx (maybe tabbed) : ."dd" ( -- ) - 'D' emit 'D' emit space ; - -: >"dd" ( -- ) - cr tab ."dd" ; + tab 'd' emit 'd' emit tab ; : ."db" ( -- ) - 'D' emit 'B' emit space ; - -: >"db" ( -- ) - cr tab ."db" ; - -: >"ds" ( -- ) - cr tab 'D' emit 'S' emit space ; + tab 'd' emit 'b' emit tab ; : ."nest" ( -- ) 'n' 'e' 's' 't' 4 alter show ; @@ -74,55 +65,50 @@ \ ,string compiles the topmost string as a sequence of numeric DB values. : ,string ( S -- ) - \ ."ds" show ; ?dup 0= ?exit - dup roll >"db" u. \ 1st char + dup roll ."db" u. cr \ 1st char 1- ,string ; \ reproduce a verbatim line : ,line ( x1 ...cn n -- ) show ; -\ compile a reference to an invoked word +\ compile a reference to an invoked word : ,word ( S -- ) - ."dd" alter show ; - -\ compile a reference to an invoked word on a new line -: ,>word ( S -- ) - >"dd" alter show ; + ."dd" alter show cr ; \ compile reference to nest primitive : ,nest ( -- ) - ."dd" ."nest" ; + ."dd" ."nest" cr ; \ compile reference to unnest primitive : ,unnest ( -- ) - >"dd" ."unnest" - cr ; + ."dd" ."unnest" cr cr ; \ compile signed number : ,n ( n -- ) - >"dd" . ; + ."dd" . cr ; \ compile unsigned number : ,u ( u -- ) - >"dd" u. ; + ."dd" u. cr ; \ compile literal : ,_lit ( S -- ) - >"dd" ."lit" ,>word ; + ."dd" ."lit" cr ,word ; \ compile literal : ,lit ( x -- ) - >"dd" ."lit" ,n ; + ."dd" ."lit" cr ,n ; \ output string as comment : ,comment ( S -- ) - cr tab ';' emit space show ; + tab ';' emit space show cr ; \ create a new symbolic label +\ if label is 6 characters or less, stay on same line for following code : label ( S -- ) - cr alter show ':' emit tab ; + alter dup >r show ':' emit r> 7 - 0< ?exit cr ; \ body calculates the name of the body from a token : body ( S1 -- S2 ) @@ -138,7 +124,7 @@ : ,end-code ( -- ) cr ; - + \ ----------------------------------- \ tail call optimization tail word ; -> [ ' word >body ] literal >r ; @@ -148,19 +134,20 @@ \ ,tail compiles a tail call : ,tail ( S -- ) body ,_lit - '>' 'r' 2 ,>word ; - -: ."done" ( -- ) - ';' emit space 'd' emit 'o' emit 'n' emit 'e' emit ; + '>' 'r' 2 ,word ; -: ."last:" ( -- ) - ';' emit space 'l' emit 'a' emit 's' emit 't' emit ':' emit space ; +\ : ."done" ( -- ) +\ ';' emit space 'd' emit 'o' emit 'n' emit 'e' emit ; +\ +\ : ."last:" ( -- ) +\ ';' emit space 'l' emit 'a' emit 's' emit 't' emit ':' emit space ; : ,end ( S -- ) - cr ."last:" alter show - cr ."done" cr ; + \ cr ."last:" alter show + \ cr ."done" cr + ; -\ create a new header with given name S2 and flags - do nothing -: header ( S1 S2 flags -- S3 S2 ) - drop ; +\ \ create a new header with given name S2 and flags - do nothing +\ : header ( S1 S2 flags -- S3 S2 ) +\ drop ; diff --git a/preForth/preForth-i386-rts.pre b/preForth/preForth-i386-rts.pre index 09f5efd..9fed2a9 100644 --- a/preForth/preForth-i386-rts.pre +++ b/preForth/preForth-i386-rts.pre @@ -7,169 +7,392 @@ \ EBP return stack pointer \ ESP data stack pointer -prelude +pre ;;; This is a preForth generated file using preForth-i386-backend. ;;; Only modify it, if you know what you are doing. - -; -prefix -format ELF +DATA_STACK_SIZE = 40000 +RETURN_STACK_SIZE = 40000 + +O_RDONLY = 0 +STDIN_FILENO = 0 +STDOUT_FILENO = 1 +STDERR_FILENO = 2 -section '.bss' writeable executable +EXIT_SUCCESS = 0 +EXIT_FAILURE = 1 - DD 10000 dup (0) -stck: DD 16 dup(0) - - DD 10000 dup(0) -rstck: DD 16 dup(0) +EOT_CHAR = 4 +format ELF -section '.text' executable writeable -public main -extrn putchar -extrn getchar -extrn fflush +section '.text' executable + +public main +extrn close extrn exit - +extrn open +extrn read +extrn strcmp +extrn strlen +extrn write + macro next { - lodsd - jmp dword [eax] + lodsd + jmp dword [eax] } +main: cld + + ; implement the functionality of "cat" for reading "key" input + ; files listed on command line will be read in order, "-" is stdin + ; if there are no command line arguments, supply a default of "-" + mov eax,[esp+4] ; argc + mov ecx,[esp+8] ; argv + cmp eax,2 + jb no_arguments ; if no arguments, use pre-filled defaults + mov [argc],eax + mov [argv],ecx +no_arguments: + call open_fd_in + + mov esp,data_stack + DATA_STACK_SIZE + mov ebp,return_stack + RETURN_STACK_SIZE + mov esi,main1 + next + +open_fd_in: + push esi + push ebp + mov ebp,esp + and esp,0xfffffff0 + sub esp,16 + + mov eax,[argn] + mov ecx,[argv] + mov esi,[ecx+eax*4] ; esi = argv[argn] + + mov [esp],esi + mov dword [esp+4],dash_c_str + call strcmp ; eax = strcmp(esi, "-") + test eax,eax + mov eax,STDIN_FILENO + jz open_fd_in_ok ; if "-", do not open and use STDIN_FILENO + + mov [esp],esi + mov dword [esp+4],O_RDONLY + call open ; eax = open(esi, O_RDONLY) + cmp eax,-1 + jnz open_fd_in_ok ; if open successful, use returned fd + + mov dword [esp],STDERR_FILENO + mov dword [esp+4],message_cant_open + mov dword [esp+8],message_cant_open_end - message_cant_open + call write ; write(STDERR_FILENO, "can't open: ", 12) + + mov dword [esp],esi + call strlen ; eax = strlen(esi) + + mov dword [esp],STDERR_FILENO + mov [esp+4],esi + mov [esp+8],eax + call write ; write(STDERR_FILENO, esi, strlen(esi)) + + mov dword [esp],STDERR_FILENO + mov dword [esp+4],message_newline + mov dword [esp+8],message_newline_end - message_newline + call write ; write(STDERR_FILENO, "\n", 1) + + mov dword [esp],EXIT_FAILURE + call exit ; exit(EXIT_FAILURE) + +open_fd_in_ok: + mov [fd_in],eax -main: cld - mov esp, dword stck - mov ebp, dword rstck - mov esi, main1 - next + mov esp,ebp + pop ebp + pop esi + ret -main1: DD _cold - DD _bye - - -_nest: lea ebp, [ebp-4] - mov [ebp], esi - lea esi, [eax+4] - next +close_fd_in: + push ebp + mov ebp,esp + and esp,0xfffffff0 + sub esp,16 + + mov eax,[fd_in] + test eax,eax ; cmp eax,STDIN_FILENO + jz close_fd_in_ok + + mov [esp],eax + call close + +close_fd_in_ok: + mov esp,ebp + pop ebp + ret + +main1: dd _cold + dd _bye + +_nest: lea ebp,[ebp-4] + mov [ebp],esi + lea esi,[eax+4] + next -_O = 0 - ; code bye ( -- ) - push ebp - mov ebp, esp - and esp, 0xfffffff0 - mov eax, 0 - mov [esp], eax - call exit -; - + and esp,0xfffffff0 + sub esp,16 + + mov dword [esp],EXIT_SUCCESS + call exit ; exit(EXIT_SUCCESS) +; + code emit ( c -- ) - pop eax + pop eax ; eax = character to emit + + push ebp + mov ebp,esp + and esp,0xfffffff0 + sub esp,16 + + mov [esp+12],al ; char ch_out = character to emit + + mov dword [esp],STDOUT_FILENO + lea eax,[esp+12] + mov [esp+4],eax + mov dword [esp+8],1 + call write ; eax = write(STDOUT_FILENO, &ch_out, 1) + cmp eax,-1 + jnz emit_ok + + mov dword [esp],STDERR_FILENO + mov dword [esp+4],message_cant_write + mov dword [esp+8],message_cant_write_end - message_cant_write + call write ; write(STDERR_FILENO, "can't write\n", 12) + + mov dword [esp],EXIT_FAILURE + call exit ; exit(EXIT_FAILURE) + +emit_ok: + mov esp,ebp + pop ebp + next +; - push ebp - mov ebp, esp - push eax - and esp, 0xfffffff0 +code eemit ( c -- ) + pop eax ; eax = character to emit - mov dword [esp], eax - call putchar + push ebp + mov ebp,esp + and esp,0xfffffff0 + sub esp,16 - mov eax, 0 - mov [esp], eax - call fflush ; flush all output streams + mov [esp+12],al ; char ch_out = character to emit - mov esp, ebp - pop ebp - next + mov dword [esp],STDERR_FILENO + lea eax,[esp+12] + mov [esp+4],eax + mov dword [esp+8],1 + call write ; eax = write(STDERR_FILENO, &ch_out, 1) + cmp eax,-1 + jnz eemit_ok + + mov dword [esp],STDERR_FILENO + mov dword [esp+4],message_cant_write + mov dword [esp+8],message_cant_write_end - message_cant_write + call write ; write(STDERR_FILENO, "can't write\n", 12) + + mov dword [esp],EXIT_FAILURE + call exit ; exit(EXIT_FAILURE) + +eemit_ok: + 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 + push ebp + mov ebp,esp + and esp,0xfffffff0 + sub esp,16 + + mov dword [esp+12],EOT_CHAR ; int ch_in = EOT_CHAR (litle endian) + + ; if argn >= argc then no file is open, so return EOT_CHAR + mov eax,[argn] + cmp eax,[argc] + jae key_done + +key_read: + mov eax,[fd_in] + mov [esp],eax + lea eax,[esp+12] + mov [esp+4],eax + mov dword [esp+8],1 + call read ; eax = read(fd_in, &ch_in, 1) + cmp eax,-1 + jnz key_ok + + mov dword [esp],STDERR_FILENO + mov dword [esp+4],message_cant_read + mov dword [esp+8],message_cant_read_end - message_cant_read + call write ; write(STDERR_FILENO, "can't read\n", 11) + + mov dword [esp],EXIT_FAILURE + call exit ; exit(EXIT_FAILURE) + +key_ok: + ; if key was read successfully, send to application + test eax,eax + jnz key_done + + ; eof + call close_fd_in + + ; if arguments now exhausted, sent EOT to application + mov eax,[argn] + inc eax + mov [argn],eax + cmp eax,[argc] + jae key_done + + ; open next input file, and then re-attempt the read + call open_fd_in + jmp key_read + +key_done: + mov eax,[esp+12] ; eax = ch_in + + mov esp,ebp + pop ebp + + push eax + next ; code dup ( x -- x x ) - pop eax - push eax - push eax - next + pop eax + push eax + push eax + next ; code swap ( x y -- y x ) - pop edx - pop eax - push edx - push eax - next + pop edx + pop eax + push edx + push eax + next ; code drop ( x -- ) - pop eax - next + pop eax + next ; code 0< ( x -- flag ) - pop eax - or eax, eax - mov eax, 0 - jns zless1 - dec eax -zless1: push eax - next + pop eax + sar eax,31 + push eax + next ; -code ?exit ( f -- ) - pop eax - or eax, eax - jz qexit1 - mov esi, [ebp] - lea ebp,[ebp+4] -qexit1: next +code ?exit ( f -- ) \ high level: IF exit THEN + 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 + 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 + mov eax,[ebp] + lea ebp,[ebp+4] + push eax + next ; code - ( x1 x2 -- x3 ) - pop edx - pop eax - sub eax, edx - push eax - next + pop edx + pop eax + sub eax,edx + push eax + next ; code unnest ( -- ) - mov esi,[ebp] - lea ebp,[ebp+4] - next + mov esi,[ebp] + lea ebp,[ebp+4] + next ; code lit ( -- ) - lodsd - push eax - next + lodsd + push eax + next +; + +\ we want the text section to be first and bss last (for linkers that output +\ sections in definition order), so it would be good to have the bss section +\ be output by the ",end" hook, but at present we cannot call "pre" from a +\ defined word, so we make do by switching to bss and then back to text again +pre +section '.data' writeable align 16 + +message_cant_open: + db 'can''t open: ' +message_cant_open_end: + +message_newline: + db 0xa +message_newline_end: + +message_cant_read: + db 'can''t read',0xa +message_cant_read_end: + +message_cant_write: + db 'can''t write',0xa +message_cant_write_end: + +dash_c_str: + db '-',0 + + align 4 + +default_argv: + dd 0 ; argv[0] + dd dash_c_str +default_argv_end: + +; default command line arguments, overwritten if any passed in +argc: dd (default_argv_end - default_argv) / 4 +argv: dd default_argv + +; argument number being processed, fd_in is valid if argn < argc +argn: dd 1 + +section '.bss' writeable align 16 + +fd_in: dd 0 + +data_stack: + db DATA_STACK_SIZE dup (0) +return_stack: + db RETURN_STACK_SIZE dup (0) + +section '.text' executable + ; diff --git a/preForth/preForth.pre b/preForth/preForth.pre index ee9f710..751fb0d 100644 --- a/preForth/preForth.pre +++ b/preForth/preForth.pre @@ -38,7 +38,7 @@ \ \ compiler words: \ ,line ,comment ,codefield ,end -\ ,lit ,>word ,nest ,unnest ,tail +\ ,lit ,word ,nest ,unnest ,tail \ \ header creation: \ header label bodylabel @@ -130,7 +130,7 @@ : code ( -- ) token _dup ,comment - 0 header + \ 0 header ,code line _drop pre ,end-code ; \ Colon definitions - the preForth compiler @@ -238,7 +238,7 @@ \ ?word detects and handles words by compiling them as reference. : ?word ( S -- 0 | S ) - dup 0= ?exit ,>word 0 ; + dup 0= ?exit ,word 0 ; \ Compiler loop \ ------------- @@ -262,7 +262,7 @@ : :' ( -- ) token _dup ,comment - 0 header + \ 0 header (: ; \ ----------- diff --git a/preForth/runtime.forth b/preForth/runtime.forth new file mode 100644 index 0000000..8c9af88 --- /dev/null +++ b/preForth/runtime.forth @@ -0,0 +1,168 @@ +: ( + ')' parse 2drop ; immediate + +: \ + source nip >in ! ; immediate + +: AHEAD ( -- c:orig ) + postpone branch here 0 , ; immediate + +: IF ( -- c:orig ) + postpone ?branch here 0 , ; immediate + +: THEN ( c:orig -- ) + here swap ! ; immediate + +: ELSE ( c:orig1 -- c:orig2 ) + postpone AHEAD swap postpone THEN ; immediate + +: BEGIN ( -- c:dest ) + here ; immediate + +: WHILE ( c: orig -- c:dest c:orig ) + postpone IF swap ; immediate + +: AGAIN ( c:orig -- ) + postpone branch , ; immediate + +: UNTIL ( c:orig -- ) + postpone ?branch , ; immediate + +: REPEAT ( c:orig c:dest -- ) + postpone AGAIN postpone THEN ; immediate + +\ are these necessary? +\ you can use the phrase dup x = IF drop instead of x case? IF or x OF +: case? ( n1 n2 -- true | n1 false ) + over = dup IF nip THEN ; + +: OF ( n1 n2 -- n1 | ) + postpone case? postpone IF ; immediate + +: :noname ( -- xt ) + new ] ; + +: Variable ( ) + Create 0 , ; + +: Constant ( x -- ) + Create , Does> @ ; + +0 Constant false +false invert Constant true + +: fill ( c-addr u x -- ) + >r BEGIN ( c-addr u ) + dup + WHILE ( c-addr u ) + r@ third c! + 1 /string + REPEAT ( c-addr u ) + 2drop r> drop +; + +: lshift ( x u -- ) BEGIN ?dup WHILE swap 2* swap 1- REPEAT ; + +\ 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- \ for every bit + BEGIN ( x q n ) + ?dup + WHILE ( x q n ) + >r 2* over 0< IF 1+ THEN >r 2* r> r> 1- + REPEAT ( x q n ) + nip ; + +: rshift ( x u -- ) BEGIN ?dup WHILE swap u2/ swap 1- REPEAT ; + +: * ( n1 n2 -- ) + 2dup xor 0< >r abs swap abs um* drop r> IF negate THEN ; + +: u/ ( n1 n2 -- quot ) 0 swap um/mod nip ; + +: u/mod ( n1 n2 -- rem quot ) 0 swap um/mod ; + +: umod ( n1 n2 -- rem ) 0 swap um/mod drop ; + +: FOR ( n -- ) + postpone BEGIN + postpone >r ; immediate + +: NEXT ( -- ) + postpone r> + postpone 1- + postpone dup + postpone 0< + postpone UNTIL + postpone drop ; immediate + +: recurse ( -- ) last @ _xt @ compile, ; immediate + +\ conditional compilation + +| : next-token ( -- c-addr u ) + BEGIN + parse-name dup 0= + WHILE ( c-addr u ) + 2drop refill 0= -39 and throw + REPEAT ( c-addr u ) ; + +| : ([ELSE]) ( level c-addr u -- level' ) + 2dup s" [IF]" compare 0= IF 2drop 1+ exit THEN + 2dup s" [ELSE]" compare 0= IF 2drop 1- dup IF 1+ THEN exit THEN + s" [THEN]" compare 0= IF 1- THEN ; + +: [ELSE] ( -- ) + 1 BEGIN ( level ) next-token ([ELSE]) ?dup 0= UNTIL ; immediate + +: [IF] ( f -- ) ?exit postpone [ELSE] ; immediate + +: [THEN] ; immediate + +: abort ( -- ) -1 throw ; + +: chars ; immediate + +: char+ 1+ ; + +' exit Alias EXIT + +: bounds ( addr count -- limit addr) over + swap ; + +| : (abort") ( f c-addr u -- ) rot IF errormsg 2! -2 throw THEN 2drop ; + +: abort" ( f -- ) + postpone s" + postpone (abort") ; immediate + +: DO ( to from -- ) + 0 \ open a dummy IF block for the backpatching test in LOOP + postpone swap + postpone BEGIN + postpone >r postpone >r ; immediate + +: ?DO ( to from -- ) + postpone 2dup + postpone - + postpone IF + postpone swap + postpone BEGIN + postpone >r postpone >r ; immediate + +: LOOP ( -- ) + postpone r> + postpone 1+ + postpone r> + postpone 2dup postpone = postpone UNTIL + postpone 2drop + \ this backpatches IF block for ?DO or does nothing for DO + ?dup IF postpone THEN THEN ; immediate + +: I ( -- ) + postpone r@ ; immediate + +\ Nick +: UNLOOP ( -- ) + postpone r> + postpone r> + postpone 2drop ; immediate diff --git a/preForth/seed b/preForth/seed index 52ff983..4deb5df 100755 --- a/preForth/seed +++ b/preForth/seed @@ -1,6 +1,4 @@ #!/bin/bash - stty raw -echo -cat seedForthInteractive.seed hi.forth - | ./seedForth +./seedForth seedForthInteractive.seed runtime.forth hi.forth - stty sane - diff --git a/preForth/seedForth-i386-header.pre b/preForth/seedForth-i386-header.pre new file mode 100644 index 0000000..bddc8e3 --- /dev/null +++ b/preForth/seedForth-i386-header.pre @@ -0,0 +1,24 @@ +\ seedForth: machine dependent header portion + +\ this contains only definitions we want at the top of the file +\ it is then followed by preForth-i386-rts.pre (primitive asm words) +\ and then by seedForth-i386.pre (additional primitive asm words) +\ and then by seedForth.pre (high level words and the interpreter) + +pre +;;; 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. + +HEAD_SIZE = 40000 +MEM_SIZE = 400000 + +POLLIN = 1 + +; diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index 7f603df..5666857 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -1,545 +1,228 @@ -\ 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) +\ seedForth: machine dependent portion - 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 +\ interpreter and basic asm primitives are taken from preForth-i386-rts.pre, +\ and then this file defines additional primitives (arithmetic, memory, etc) -__hp: DD 0 ; head pointer: index of 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 -extrn ioctl +pre +extrn poll extrn usleep - -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: -_enter: lea ebp, [ebp-4] - mov [ebp], esi - lea esi, [eax+4] - next + +_enter = _nest _dodoes: ; ( -- addr ) - lea ebp, [ebp-4] ; push IP - mov [ebp], esi - mov esi,[eax-4] ; set IP + lea ebp,[ebp-4] ; push IP + mov [ebp],esi + mov esi,[eax-4] ; set IP _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 ; eof: return Ctrl-D -key1: push eax - next + lea eax,[eax+4] ; to parameter field + push eax + next ; code key? ( -- f ) - push ebp - mov ebp, esp - and esp, 0xfffffff0 - sub esp, 32 - - mov dword [esp], 0 - mov dword [esp+4], 1074030207 ; FIONREAD - lea dword eax, [esp+24] - mov dword [esp+8], eax - - call ioctl - mov dword eax, [esp+24] - - mov esp, ebp - pop ebp - - cmp eax, 0 - jz keyq1 - mov eax, -1 -keyq1: 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 - sar eax,31 - push eax - next -; - -code ?exit ( f -- ) \ high level: IF exit THEN - 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 + push ebp + mov ebp,esp + and esp,0xfffffff0 + sub esp,32 + + ; if all arguments exhausted, return ready + ; this allows application to collect the EOT character + mov eax,[argn] + cmp eax,[argc] + jae keyq_ready + + mov eax,[fd_in] + mov dword [esp+12],eax + mov dword [esp+16],POLLIN ; struct pollfd fd = {fd_in, POLLIN, 0} + + lea eax,[esp+12] + mov [esp],eax + mov dword [esp+4],1 + mov dword [esp+8],0 + call poll ; eax = poll(&fd, 1, 0) + cmp eax,-1 + jnz keyq_ok + + mov dword [esp],STDERR_FILENO + mov dword [esp+4],message_cant_poll + mov dword [esp+8],message_cant_poll_end - message_cant_poll + call write ; write(STDERR_FILENO, "can't write\n", 11) + + mov dword [esp],EXIT_FAILURE + call exit ; exit(EXIT_FAILURE) + +keyq_ok: + sub eax,eax + test word [esp+18],POLLIN ; fd.revents & POLLIN + jz keyq_done +keyq_ready: + mov eax,-1 +keyq_done: + + mov esp,ebp + pop ebp + + push eax + next ; code or ( x1 x2 -- x3 ) - pop edx - pop eax - or eax, edx - push eax - next + pop edx + pop eax + or eax,edx + push eax + next ; code and ( x1 x2 -- x3 ) - pop edx - pop eax - and eax, edx - push eax - next -; - -pre -_unnest: -; -code exit ( -- ) - mov esi,[ebp] - lea ebp,[ebp+4] - next + pop edx + pop eax + and eax,edx + push eax + next ; -code lit ( -- ) - lodsd - push eax - next +pre +_exit = _unnest ; code @ ( addr -- x ) - pop eax - mov eax,[eax] - push eax - next + 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 + pop edx + xor eax,eax + mov al,byte [edx] + push eax + next ; code ! ( x addr -- ) - pop edx - pop eax - mov dword [edx],eax - next + pop edx + pop eax + mov dword [edx],eax + next ; code c! ( c c-addr -- ) - pop edx - pop eax - mov byte [edx], al - next + pop edx + pop eax + mov byte [edx],al + next ; \ code invoke ( addr -- ) \ native code: >r ; -code execute ( addr -- ) \ this version uses token numbers as execution tokens and finds their code address via the headers table - pop edx - mov dword eax, [_head+edx*4] - jmp dword [eax] +code execute ( addr -- ) \ this version uses token numbers as execution tokens and finds their code address via the headers table + pop edx + mov dword eax,[_head+edx*4] + jmp dword [eax] ; code branch ( -- ) \ threaded code: r> @ >r ; - lodsd - mov esi,eax - next + 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 + pop eax + or eax,eax + jz _branchX + lea esi,[esi+4] + next ; code depth ( -- n ) - mov eax, stck - sub eax, esp - sar eax,2 - push eax - next + mov eax,data_stack + DATA_STACK_SIZE + sub eax,esp + sar eax,2 + push eax + next ; code sp@ ( -- x ) - push esp - next + push esp + next ; code sp! ( x -- ) - pop esp - next + pop esp + next ; code rp@ ( -- x ) - push ebp - next + push ebp + next ; code rp! ( x -- ) - pop ebp - next + pop ebp + next ; code um* ( u1 u2 -- ud ) - pop edx - pop eax - mul edx - push eax - push edx - next + pop edx + pop eax + mul edx + push eax + push edx + next ; code um/mod ( ud u1 -- u2 u3 ) - pop ebx - pop edx - pop eax - div ebx - push edx - push eax - next + pop ebx + pop edx + pop eax + div ebx + push edx + push eax + next ; code usleep ( c -- ) - pop eax + pop eax ; eax = microseconds to sleep - push ebp - mov ebp, esp - push eax - and esp, 0xfffffff0 + push ebp + mov ebp,esp + and esp,0xfffffff0 + sub esp,16 - mov dword [esp], eax - call usleep + mov [esp],eax + call usleep - mov esp, ebp - pop ebp - next + mov esp,ebp + pop ebp + next ; +\ we want the text section to be first and bss last (for linkers that output +\ sections in definition order), so it would be good to have the bss section +\ be output by the ",end" hook, but at present we cannot call "pre" from a +\ defined word, so we make do by switching to bss and then back to text again +pre +section '.data' writeable align 16 -: 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 ; - -: 2* ( x1 -- x2 ) - dup + ; - -: cells ( x1 -- x2 ) - 2* 2* ; - -: +! ( x addr -- ) - swap >r dup @ r> + swap ! ; - -: hp ( -- addr ) - lit _hp ; - -: h@ ( i -- addr ) - cells lit head + @ ; - -: h! ( x i -- ) - cells lit head + ! ; - -: h, ( x -- ) - hp @ h! 1 hp +! ; - -: here ( -- addr ) - lit dp @ ; - -: allot ( n -- ) - lit dp +! ; - -: , ( x -- ) - here 1 cells allot ! ; - -: c, ( c -- ) - here 1 allot c! ; - -: compile, ( x -- ) - h@ , ; - -\ token are in the range 0 .. 767: -\ 0, 3 .. 255 are single byte tokens -\ 256 .. 511 are double byte tokens of the form 01 xx -\ 511 .. 767 are double byte tokens of the form 02 xx -: token ( -- x ) - key dup 0= ?exit \ 0 -> single byte token - dup 3 - 0< 0= ?exit \ not 1 2 -> single byte token - key couple ; \ double byte token - -: interpreter ( -- ) - token execute tail interpreter ; \ executing exit will leave this loop - -: num ( -- x ) - tail interpreter ; - -: ?lit ( xt -- xt | ) - dup h@ lit num - ?exit drop \ not num token: exit i.e. normal compile action - lit lit , num , \ generate lit x num call puts x on stack - r> drop tail compiler ; - -: compiler ( -- ) - token ?dup 0= ?exit ?lit - compile, tail compiler ; - -: new ( -- xt ) - hp @ here h, lit enter , ; - -: fun ( -- ) - new drop compiler ; +message_cant_poll: + db 'can''t poll',0xa +message_cant_poll_end: -: couple ( hi lo -- hilo ) - >r 2* 2* 2* 2* 2* 2* 2* 2* r> + ; +section '.bss' writeable align 16 -: $lit ( -- addr u ) - r> dup 1 + dup >r swap c@ dup r> + >r ; + ; dictionary pointer: points to next free location in memory +_dp: dd _mem -: create ( -- xt ) - 0 , \ dummy does> field - hp @ here h, lit dovar , ; + ; head pointer: index of first unused head +__hp: dd 0 +_head: dd HEAD_SIZE dup (0) -: does> ( xt -- ) \ set code field of last defined word - r> swap h@ dup >r 1 cells - ! lit dodoes r> ! -; + ; free memory starts at _mem +_mem: db MEM_SIZE dup (0) +_memtop: -: unused ( -- u ) - lit memtop here - ; - -: cold ( -- ) - \ 's' emit 'e' dup emit emit 'd' emit 10 emit - lit bye h, \ 0 00 code - 0 h, \ 1 01 prefix - 0 h, \ 2 02 prefix - lit emit h, \ 3 03 code - lit key h, \ 4 04 code - lit dup h, \ 5 05 code - lit swap h, \ 6 06 code - lit drop h, \ 7 07 code - lit 0< h, \ 8 08 code - lit ?exit h, \ 9 09 code - lit >r h, \ 10 0A code - lit r> h, \ 11 0B code - lit - h, \ 12 0C code - lit exit h, \ 13 0D code - lit lit h, \ 14 0E code - lit @ h, \ 15 0F code - lit c@ h, \ 16 10 code - lit ! h, \ 17 11 code - lit c! h, \ 18 12 code - lit execute h, \ 19 13 code - lit branch h, \ 20 14 code - lit ?branch h, \ 21 15 code - lit negate h, \ 22 16 - lit + h, \ 23 17 - lit 0= h, \ 24 18 - lit ?dup h, \ 25 19 - lit cells h, \ 26 1A - lit +! h, \ 27 1B - lit h@ h, \ 28 1C - lit h, h, \ 29 1D - lit here h, \ 30 1E - lit allot h, \ 31 1F - lit , h, \ 32 20 - lit c, h, \ 33 21 - lit fun h, \ 34 22 - lit interpreter h, \ 35 23 - lit compiler h, \ 36 24 - lit create h, \ 37 25 - lit does> h, \ 38 26 - lit cold h, \ 39 27 - lit depth h, \ 40 28 code - lit compile, h, \ 41 29 - lit new h, \ 42 2A - lit couple h, \ 43 2B - lit and h, \ 44 2C code - lit or h, \ 45 2D code - lit sp@ h, \ 46 2E code - lit sp! h, \ 47 2F code - lit rp@ h, \ 48 30 code - lit rp! h, \ 49 31 code - lit $lit h, \ 50 32 - lit num h, \ 51 33 - lit um* h, \ 52 34 code - lit um/mod h, \ 53 35 code - lit unused h, \ 54 36 - lit key? h, \ 55 37 - lit token h, \ 56 38 - lit usleep h, \ 57 39 code - lit hp h, \ 58 40 - interpreter bye ; +section '.text' executable -pre - _start: DB 43 - DD 100000 dup (0) - _memtop: DD 0 ; diff --git a/preForth/seedForth-tokenizer b/preForth/seedForth-tokenizer new file mode 100755 index 0000000..420ff59 --- /dev/null +++ b/preForth/seedForth-tokenizer @@ -0,0 +1,2 @@ +#!/bin/sh +./seedForth seedForthBoot.seed runtime.forth crc10.forth seedForth-tokenizer.fs - diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs index 3cbd559..6ac5ed6 100644 --- a/preForth/seedForth-tokenizer.fs +++ b/preForth/seedForth-tokenizer.fs @@ -1,69 +1,122 @@ \ Another seedForth tokenizer 2019-10-18 -: fnv1a ( c-addr u -- x ) - 2166136261 >r - BEGIN dup WHILE over c@ r> xor 16777619 um* drop $FFFFFFFF and >r 1 /string REPEAT 2drop r> ; - -15 Constant #hashbits -1 #hashbits lshift Constant #hashsize - -#hashbits 16 < [IF] - - #hashsize 1 - Constant tinymask - : fold ( x1 -- x2 ) dup #hashbits rshift xor tinymask and ; - -[ELSE] \ #hashbits has 16 bits or more - - #hashsize 1 - Constant mask - : fold ( x1 -- x2 ) dup #hashbits rshift swap mask and xor ; - -[THEN] - -Create tokens #hashsize cells allot tokens #hashsize cells 0 fill - -: 'token ( c-addr u -- addr ) - fnv1a fold cells tokens + ; - -: token@ ( c-addr u -- x ) 'token @ ; +\ seedForth does not support hex so put some useful constants in decimal +255 Constant xFF +1023 Constant x3FF +1024 Constant x400 +65261 Constant xFEED + +\ exceptions +100 Constant except_hash_table_full + +\ hash table entry structure +0 Constant _hash_table_xt +1 cells Constant _hash_table_name_addr +2 cells Constant _hash_table_name_len +3 cells Constant #hash_table + +\ the sizing below accommodates up to 1K word definitions +\ (the same as the number of tokens available to seedForth) +x3FF Constant hash_table_mask +x400 Constant hash_table_size +Create hash_table +hash_table_size #hash_table * dup allot hash_table swap 0 fill + +: hash_table_index ( entry -- addr ) + #hash_table * hash_table + ; + +: hash_table_find ( name_addr name_len -- entry_addr found ) + \ calculate CRC10 of the symbol name + \ initial value is same as hash table mask (all 1s) + 2dup hash_table_mask crc10 + \ hash_table_mask and + + \ using the CRC10 as the starting entry, look circularly + \ for either a null entry (not found) or a matching entry + hash_table_size 0 ?DO ( name_addr name_len entry ) + dup >r hash_table_index >r ( name_addr name_len R: entry entry_addr ) + + \ check for null entry + r@ _hash_table_xt + @ 0= IF + 2drop r> r> drop false UNLOOP exit + THEN + + \ check for matching entry + 2dup + r@ _hash_table_name_addr + @ + r@ _hash_table_name_len + @ + compare 0= IF + 2drop r> r> drop true UNLOOP exit + THEN + + \ go to next entry, circularly + r> drop + r> 1+ hash_table_mask and + LOOP + + \ not found, and no room for new entry + except_hash_table_full throw +; -: ?token ( c-addr u -- x ) - 2dup 'token dup @ - IF - >r cr type ." collides with another token " - cr source type cr r> @ name-see abort - THEN nip nip ; +: token@ ( c-addr u -- x ) + \ get entry address and flag for found/empty + hash_table_find -VARIABLE OUTFILE + \ if found, return value of _xt, otherwise 0 + IF _hash_table_xt + @ ELSE drop 0 THEN +; -: submit ( c -- ) - PAD C! PAD 1 OUTFILE @ WRITE-FILE THROW ; +: ?token ( c-addr u -- x ) + \ get entry address and flag for found/empty + 2dup hash_table_find + + \ if empty, copy symbol name and fill in entry + 0= IF + >r + here r@ _hash_table_name_addr + ! + dup r@ _hash_table_name_len + ! + here swap dup allot cmove + r> + ELSE + nip nip + THEN + + \ return address of _xt for caller to fill in + _hash_table_xt + +; -: submit-token ( x -- ) - dup 255 > IF dup 8 rshift SUBMIT THEN SUBMIT ; +\ VARIABLE OUTFILE -: ( -- c-addr u ) bl word count ; +\ : submit ( c -- ) +\ PAD C! PAD 1 OUTFILE @ WRITE-FILE THROW ; +\ +\ : submit-token ( x -- ) +\ dup 255 > IF dup 8 rshift SUBMIT THEN SUBMIT ; +: emit-token ( x -- ) + dup xFF > IF dup 8 rshift emit THEN emit ; Variable #tokens 0 #tokens ! : Token ( -- ) :noname - #tokens @ postpone LITERAL postpone SUBMIT-TOKEN postpone ; - - cr #tokens @ 3 .r space 2dup type \ tell user about used tokens + #tokens @ postpone Literal postpone emit-token postpone ; \ SUBMIT-TOKEN postpone ; + parse-name + \ cr #tokens @ 3 .r space 2dup type \ tell user about used tokens ?token ! 1 #tokens +! ; : Macro ( -- ) - ?token :noname $FEED ; + parse-name ?token :noname xFEED ; : end-macro ( 'hash colon-sys -- ) - $FEED - Abort" end-macro without corresponding Macro" + xFEED - abort" end-macro without corresponding Macro" postpone ; ( 'hash xt ) swap ! ; immediate : seed ( i*x -- j*x ) - token@ dup 0= Abort" is undefined" postpone LITERAL postpone EXECUTE ; immediate + parse-name token@ dup 0= abort" is undefined" postpone Literal postpone execute ; immediate -( 0 $00 ) Token bye Token prefix1 Token prefix2 Token emit -( 4 $04 ) Token key Token dup Token swap Token drop +( 0 $00 ) Token bye +4 #tokens ! +( 4 $04 ) Token eot Token dup Token swap Token drop ( 8 $08 ) Token 0< Token ?exit Token >r Token r> ( 12 $0C ) Token - Token exit Token lit Token @ ( 16 $10 ) Token c@ Token ! Token c! Token execute @@ -76,56 +129,67 @@ Variable #tokens 0 #tokens ! ( 44 $2C ) Token and Token or Token sp@ Token sp! ( 48 $30 ) Token rp@ Token rp! Token $lit Token num ( 52 $34 ) Token um* Token um/mod Token unused Token key? -( 56 $38 ) Token token Token usleep Token hp +( 56 $38 ) Token token Token usleep Token hp Token key +( 60 $3C ) Token emit Token eemit \ generate token sequences for numbers : seed-byte ( c -- ) - seed key SUBMIT ; + seed key emit ; \ SUBMIT ; : seed-number ( x -- ) \ x is placed in the token file. Handle also negative and large numbers dup 0< IF 0 seed-byte negate recurse seed - EXIT THEN - dup $FF > IF dup 8 rshift recurse $FF and seed-byte seed couple EXIT THEN + dup xFF > IF dup 8 rshift recurse xFF and seed-byte seed couple EXIT THEN seed-byte ; : char-lit? ( c-addr u -- x flag ) 3 - IF drop 0 false EXIT THEN - dup c@ [char] ' - IF drop 0 false EXIT THEN - dup 2 chars + c@ [char] ' - IF drop 0 false EXIT THEN + dup c@ ''' - IF drop 0 false EXIT THEN + dup 2 chars + c@ ''' - IF drop 0 false EXIT THEN char+ c@ true ; : process-digit? ( x c -- x' flag ) '0' - dup 10 u< IF swap 10 * + true EXIT THEN drop false ; -: number? ( c-addr u -- x flag ) - dup 0= IF 2drop 0 false EXIT THEN - over c@ '-' = dup >r IF 1 /string THEN +: process-number? ( c-addr u -- x flag ) + dup 0= IF 2drop 0 false EXIT THEN + over c@ '-' = dup >r IF 1 /string THEN >r >r 0 r> r> bounds ?DO ( x ) - I c@ process-digit? 0= IF unloop r> drop false EXIT THEN ( x d ) + I c@ process-digit? 0= IF UNLOOP r> drop false EXIT THEN ( x d ) LOOP r> IF negate THEN true ; : seed-name ( c-addr u -- ) - 2dup token@ dup IF nip nip execute EXIT THEN drop - 2dup char-lit? IF nip nip seed num seed-number seed exit EXIT THEN drop - 2dup number? IF nip nip seed num seed-number seed exit EXIT THEN drop - cr type ." not found" abort ; + 2dup token@ dup IF nip nip execute EXIT THEN drop + 2dup char-lit? IF nip nip seed num seed-number seed exit EXIT THEN drop + 2dup process-number? IF nip nip seed num seed-number seed exit EXIT THEN drop + cr type ." not found" abort ; : seed-line ( -- ) - BEGIN dup WHILE seed-name REPEAT 2drop ; + BEGIN parse-name dup WHILE seed-name REPEAT 2drop ; : seed-file ( -- ) BEGIN refill WHILE seed-line REPEAT ; -: PROGRAM ( -- ) - R/W CREATE-FILE THROW OUTFILE ! - seed-file ; - -Macro END ( -- ) - .S CR 0 SUBMIT OUTFILE @ CLOSE-FILE THROW BYE end-macro - -Macro [ ( -- ) seed bye end-macro \ bye +\ : PROGRAM ( -- ) +\ parse-name R/W CREATE-FILE THROW OUTFILE ! +\ seed-file ; + +\ Macro END ( -- ) +\ .S CR 0 SUBMIT OUTFILE @ CLOSE-FILE THROW BYE end-macro + +\ eot is overloaded to either: +\ - return from compilation state to interpretive state +\ (used for compiling ; and various control flow constructs) +\ - quit the interpreter if invoked in interpretive state +\ (can overloading because control flow is not allowed here) +\ this means that if the token stream runs out and starts to return +\ EOT characters, we will first terminate any word definition that +\ was in progress, then we'll do an automatic bye (in the old way, +\ there was an automatic bye token appended to seed file, but this +\ was annoying because seedForthInteractive had to read and drop it) +Macro [ ( -- ) seed eot end-macro \ eot Macro ] ( -- ) seed compiler end-macro \ compiler Macro : ( -- ) seed fun Token end-macro @@ -150,7 +214,7 @@ Macro ; ( -- ) seed exit seed [ end-macro REPEAT 2drop ; -Macro ," ( ccc" -- ) [char] " parse seed-string end-macro +Macro ," ( ccc" -- ) '"' parse seed-string end-macro : $, ( c-addr u -- ) seed $lit @@ -160,15 +224,15 @@ Macro ," ( ccc" -- ) [char] " parse seed-string end-macro ; Macro $name ( -- ) - seed-stack-string + parse-name seed-stack-string end-macro Macro $( \ ( ccc) -- ) - [char] ) parse seed-stack-string + ')' parse seed-stack-string end-macro Macro s" ( ccc" -- ) \ only in compile mode - [char] " parse $, + '"' parse $, end-macro @@ -176,8 +240,8 @@ end-macro : forward ( -- ) seed [ seed here - 0 seed-number seed , - seed ] + 0 seed-number seed , + seed ] ; : back ( -- ) @@ -188,11 +252,11 @@ end-macro Macro AHEAD ( -- addr ) - seed branch forward + seed branch forward end-macro Macro IF ( -- addr ) - seed ?branch forward + seed ?branch forward end-macro @@ -251,7 +315,7 @@ Macro Definer ( -- ) postpone Token #tokens @ 1 #tokens +! postpone Literal - postpone SUBMIT-TOKEN + postpone emit-token \ SUBMIT-TOKEN seed fun postpone end-macro end-macro @@ -277,4 +341,9 @@ end-macro Macro restore-#tokens postpone #tokens postpone ! -end-macro \ No newline at end of file +end-macro + +seed-file +\ user code has to be concatenated here +\ it cannot be in a separate file when running via gforth +\ it cannot have a partial last line when running via seedForth diff --git a/preForth/seedForth.pre b/preForth/seedForth.pre new file mode 100644 index 0000000..dd5aaee --- /dev/null +++ b/preForth/seedForth.pre @@ -0,0 +1,176 @@ +\ seedForth: less machine dependent portion + +: 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 ; + +: 2* ( x1 -- x2 ) + dup + ; + +: cells ( x1 -- x2 ) + 2* 2* ; + +: +! ( x addr -- ) + swap >r dup @ r> + swap ! ; + +: hp ( -- addr ) + lit _hp ; + +: h@ ( i -- addr ) + cells lit head + @ ; + +: h! ( x i -- ) + cells lit head + ! ; + +: h, ( x -- ) + hp @ h! 1 hp +! ; + +: here ( -- addr ) + lit dp @ ; + +: allot ( n -- ) + lit dp +! ; + +: , ( x -- ) + here 1 cells allot ! ; + +: c, ( c -- ) + here 1 allot c! ; + +: compile, ( x -- ) + h@ , ; + +\ token are in the range 0 .. 1023: +\ 0, 4 .. 255 are single byte tokens +\ 256 .. 511 are double byte tokens of the form 01 xx +\ 511 .. 767 are double byte tokens of the form 02 xx +\ 768 .. 1023 are double byte tokens of the form 03 xx +: token ( -- x ) + key dup 0= ?exit \ 0 -> single byte token + dup 4 - 0< 0= ?exit \ not 1 2 3 -> single byte token + key couple ; \ double byte token + +: interpreter ( -- ) + token execute tail interpreter ; \ executing exit will leave this loop + +: num ( -- x ) + tail interpreter ; + +: ?lit ( xt -- xt | ) + dup h@ lit num - ?exit drop \ not num token: exit i.e. normal compile action + lit lit , num , \ generate lit x num call puts x on stack + r> drop tail compiler ; + +: eot ( -- ) + bye ; \ interpretive semantics: input exhausted, automatic bye + +: ?eot ( xt -- xt | ) + dup h@ lit eot - ?exit drop \ not eot token: exit i.e. normal compile action + r> drop ; \ compilation semantics: return to interpretive state + +: compiler ( -- ) + token + + \ Nick: old way of detecting bye token directly prevented compiling it + \ ?dup 0= ?exit + ?eot + + ?lit + compile, tail compiler ; + +: new ( -- xt ) + hp @ here h, lit enter , ; + +: fun ( -- ) + new drop compiler ; + +: couple ( hi lo -- hilo ) + >r 2* 2* 2* 2* 2* 2* 2* 2* r> + ; + +: $lit ( -- addr u ) + r> dup 1 + dup >r swap c@ dup r> + >r ; + +: create ( -- xt ) + 0 , \ dummy does> field + hp @ here h, lit dovar , ; + +: does> ( xt -- ) \ set code field of last defined word + r> swap h@ dup >r 1 cells - ! lit dodoes r> ! +; + +: unused ( -- u ) + lit memtop here - ; + +: cold ( -- ) + \ 's' emit 'e' dup emit emit 'd' emit 10 emit + lit bye h, \ 0 00 code + 0 h, \ 1 01 prefix + 0 h, \ 2 02 prefix + 0 h, \ 3 03 prefix + lit eot h, \ 4 04 code + lit dup h, \ 5 05 code + lit swap h, \ 6 06 code + lit drop h, \ 7 07 code + lit 0< h, \ 8 08 code + lit ?exit h, \ 9 09 code + lit >r h, \ 10 0A code + lit r> h, \ 11 0B code + lit - h, \ 12 0C code + lit exit h, \ 13 0D code + lit lit h, \ 14 0E code + lit @ h, \ 15 0F code + lit c@ h, \ 16 10 code + lit ! h, \ 17 11 code + lit c! h, \ 18 12 code + lit execute h, \ 19 13 code + lit branch h, \ 20 14 code + lit ?branch h, \ 21 15 code + lit negate h, \ 22 16 + lit + h, \ 23 17 + lit 0= h, \ 24 18 + lit ?dup h, \ 25 19 + lit cells h, \ 26 1A + lit +! h, \ 27 1B + lit h@ h, \ 28 1C + lit h, h, \ 29 1D + lit here h, \ 30 1E + lit allot h, \ 31 1F + lit , h, \ 32 20 + lit c, h, \ 33 21 + lit fun h, \ 34 22 + lit interpreter h, \ 35 23 + lit compiler h, \ 36 24 + lit create h, \ 37 25 + lit does> h, \ 38 26 + lit cold h, \ 39 27 + lit depth h, \ 40 28 code + lit compile, h, \ 41 29 + lit new h, \ 42 2A + lit couple h, \ 43 2B + lit and h, \ 44 2C code + lit or h, \ 45 2D code + lit sp@ h, \ 46 2E code + lit sp! h, \ 47 2F code + lit rp@ h, \ 48 30 code + lit rp! h, \ 49 31 code + lit $lit h, \ 50 32 + lit num h, \ 51 33 + lit um* h, \ 52 34 code + lit um/mod h, \ 53 35 code + lit unused h, \ 54 36 + lit key? h, \ 55 37 + lit token h, \ 56 38 + lit usleep h, \ 57 39 code + lit hp h, \ 58 40 + lit key h, \ 59 41 code + lit emit h, \ 60 42 code + lit eemit h, \ 61 43 code + interpreter bye ; diff --git a/preForth/seedForthBoot.seedsource b/preForth/seedForthBoot.seedsource new file mode 100644 index 0000000..145815c --- /dev/null +++ b/preForth/seedForthBoot.seedsource @@ -0,0 +1,3 @@ +\ seedForth interactive system +\ this file boots for running textual forth program (no banner, prompt, echo) +boot diff --git a/preForth/seedForthDemo.seedsource b/preForth/seedForthDemo.seedsource index 4e2ddad..2efb7d6 100644 --- a/preForth/seedForthDemo.seedsource +++ b/preForth/seedForthDemo.seedsource @@ -9,8 +9,6 @@ \ cat seedForthDemo.seed | ./seedForth \ -PROGRAM seedForthDemo.seed - Definer Variable create ( x ) drop 0 , ; \ Missing primitives @@ -291,7 +289,7 @@ Variable #tib over dup c@ upc swap c! 1 /string REPEAT ( c-addr u ) 2drop ; -: hi ( -- ) key drop \ discard END / bye token +: hi ( -- ) \ key drop \ discard END / bye token BEGIN cr s" > " type query cr .s @@ -401,6 +399,4 @@ t{ 60 5 a ! 0 a @ 1 a @ 2 a @ 3 a @ 4 a @ 5 a @ -> 10 20 30 40 50 60 }t \ cr 'd' emit 'o' emit 'n' emit 'e' emit cr \ hi -END - - +bye diff --git a/preForth/seedForthInteractive.seedsource b/preForth/seedForthInteractive.seedsource index 089137f..935ed18 100644 --- a/preForth/seedForthInteractive.seedsource +++ b/preForth/seedForthInteractive.seedsource @@ -1,241 +1,15 @@ \ seedForth interactive system -\ -\ tokenize with -\ -\ gforth seedForth-tokinzer.fs seedForthInteractive.seedsource -\ -\ then pipe into seedForth: -\ -\ cat seedForthInteractive.seed | ./seedForth -\ +\ this file boots for interactive use (with banner, prompt, echo) -PROGRAM seedForthInteractive.seed - -\ Defining words -Definer Create ( -- ) create ( x ) drop ; -Definer Variable ( -- ) create ( x ) drop 0 , ; -Definer Constant ( x -- ) create ( x ) >r , r> does> @ ; - -Macro Literal - seed lit - seed [ - seed , - seed ] -end-macro - -\ Missing primitives -: over ( x1 x2 -- x1 x2 x1 ) - >r dup r> swap ; - -: rot ( a b c -- b c a ) - >r swap r> swap ; - -: -rot ( a b c -- c a b ) - swap >r swap r> ; - -: under+ ( x1 x2 x3 -- x1+x3 x2 ) - rot + swap ; - -: tuck ( x1 x2 -- x2 x1 x2 ) - swap over ; - -: /string ( x1 x2 x3 -- x4 x5 ) - swap over - >r + r> ; - -: 2drop ( x1 x2 -- ) - drop drop ; - -: 2dup ( x1 x2 -- x1 x2 x1 x2 ) - over over ; - -: 2swap ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) - >r -rot r> -rot ; - -: 2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) - >r >r 2dup r> r> 2swap ; - -: 1+ ( x1 -- x2 ) - 1 + ; - -: 2+ ( x1 -- x2 ) - 2 + ; - -: 1- ( x1 -- x2 ) - 1 - ; - -: invert ( x1 x2 -- x3 ) - negate 1- ; - -: nip ( x1 x2 -- x2 ) - swap drop ; - -: count ( addr -- c-addr u ) - dup 1+ swap c@ ; - -: xor ( x1 x2 -- x3 ) - 2dup or >r invert swap invert or r> and ; - -: u< ( u1 u2 -- f ) - 2dup xor 0< IF nip 0< exit THEN - 0< ; - -: < ( n1 n2 -- f ) - 2dup xor 0< IF drop 0< exit THEN - 0< ; - -: > ( n1 n2 -- f ) - swap < ; - -: = ( x1 x2 -- f ) - - 0= ; - -: 0<> ( x -- f ) - 0= 0= ; - -: 2* ( x1 -- x2 ) \ already in kernel - dup + ; - -: cell+ ( addr1 -- addr2 ) - 1 cells + ; - -: cell- ( addr1 -- addr2 ) - -1 cells + ; - -: 2@ ( addr -- x1 x2 ) - dup cell+ @ swap @ ; - -: 2! ( x1 x2 addr -- ) - swap over ! cell+ ! ; - -Definer Field ( offset size -- offset' ) - create >r over , + r> does> @ + ; - -\ output -32 Constant bl - -: cr ( -- ) - 10 emit 13 emit ; - -: type ( c-addr u -- ) - BEGIN dup WHILE over c@ emit 1 /string REPEAT 2drop ; - -: space ( -- ) - bl emit ; - -: spaces ( n -- ) - BEGIN ?dup WHILE space 1 - REPEAT ; - -Macro ." ( ccc" -- ) - seed s" - seed type -end-macro - -: .digit ( n -- ) - '0' + emit ; - -: third ( x1 x2 x3 -- x1 x2 x3 x1 ) - >r over r> swap ; - -: min ( n1 n2 -- n3 ) - 2dup > IF swap THEN drop ; - -: max ( n1 n2 -- n3 ) - 2dup < IF swap THEN drop ; - -: r@ ( -- x ) - r> r> dup >r swap >r ; - -: abs ( n -- +n ) - dup 0< IF negate THEN ; - -: cmove ( c-addr1 c-addr2 u -- ) - BEGIN - ?dup - WHILE - >r - over c@ over c! - 1+ swap 1+ swap - r> 1- - REPEAT - 2drop ; - -: move cmove ; - -: place ( c-addr1 u c-addr2 -- ) - 2dup >r >r 1+ swap cmove r> r> c! ; - -\ Exception handling - -Variable frame ( -- addr ) - -: catch ( i*x xt -- j*x 0 | i*x err ) - frame @ >r sp@ >r rp@ frame ! execute - r> drop r> frame ! 0 ; - -: throw ( i*x 0 | i*x err -- j*x err ) - ?dup 0= ?exit frame @ rp! r> swap >r sp! drop - r> r> frame ! ; - -\ tests: see later when ' is defined - -\ save and empty - -Create savearea 0 , 0 , \ { hp | dp } - -: (save) ( -- ) - here hp @ savearea 2! ; - -Macro save ( -- ) - seed (save) - save-#tokens -end-macro - -: (empty) ( -- ) - savearea 2@ hp ! here - allot ( aka dp! ) ; - -Macro empty ( -- ) - seed (empty) - restore-#tokens -end-macro +\ catch and throw tests: see later when ' is defined +\ save and empty tests save : three 3 ; empty - -\ Tester -: empty-stack ( i*x -- ) - BEGIN depth 0< WHILE 0 REPEAT - BEGIN depth WHILE drop REPEAT ; - -Variable actual-depth ( actual-results ) 20 cells allot - -: nth-result ( n -- addr ) - cells actual-depth + ; - -: error ( i*x c-addr u -- ) - cr type empty-stack ; - -: t{ ( i*x -- ) - '.' emit empty-stack ; - -: -> ( -- ) - depth actual-depth ! - BEGIN depth WHILE depth nth-result ! REPEAT ; - -: }t ( i*x -- ) - depth actual-depth @ - IF s" wrong number of results" error exit THEN - BEGIN depth WHILE depth nth-result @ - IF s" incorrect result" error exit THEN REPEAT ; - -Macro begin-tests - seed save -end-macro - -Macro end-tests - seed empty -end-macro - - begin-tests \ Test basics t{ 10 '*' + -> 52 }t @@ -300,11 +74,7 @@ t{ 1000 -10 < -> 0 }t end-tests -: minint ( -- n ) - 1 BEGIN dup 2* dup WHILE nip REPEAT drop ; - -minint 1- Constant maxint - +\ minint and maxint tests begin-tests t{ minint negate -> minint }t @@ -318,55 +88,6 @@ t{ 0 -1 u< -> -1 }t end-tests -: skip ( c-addr1 u1 c -- c-addr2 u2 ) - BEGIN - over - WHILE - >r over c@ r> swap over = - WHILE - >r 1 /string r> - REPEAT THEN drop ; - -: scan ( c-addr u1 c -- c-addr2 u2 ) - BEGIN - over - WHILE - >r over c@ r> swap over - - WHILE - >r 1 /string r> - REPEAT THEN drop ; - -: (u. ( u1 -- ) - ?dup IF 0 10 um/mod (u. .digit THEN ; - -\ display unsigned number -: u. ( u -- ) - dup (u. 0= IF '0' emit THEN space ; - -\ display signed number -: . ( n -- ) - dup 0< IF '-' emit negate THEN u. ; - -: .s ( i*x -- i*x ) - depth 0= ?exit >r .s r> dup . ; - - -\ Deferred words - -: ' ( -- x ) token ; - -: uninitialized ( -- ) - cr s" uninitialized execution vector" type -1 throw ; - -Definer Defer ( -- ) - create >r [ ' uninitialized ] Literal , r> does> @ execute ; - -: >body ( xt -- body ) - h@ 1 cells + ; - -: is ( xt -- ) \ only interactive - ' >body ! ; - \ catch and throw tests begin-tests @@ -379,774 +100,7 @@ t{ 5 9 ' err99 catch nip -> 5 99 }t end-tests -\ String comparison -: compare ( c-addr1 u1 c-addr2 u2 -- n ) - rot - BEGIN \ ( c-addr1 c-addr2 u2 u1 ) - over - WHILE \ ( c-addr1 c-addr2 u2 u1 ) - dup - WHILE \ ( c-addr1 c-addr2 u2 u1 ) - >r >r over c@ over c@ - ?dup IF 0< 2* 1+ ( -1 | 1 ) nip nip r> drop r> drop exit THEN - 1+ swap 1+ swap - r> 1- r> 1- - REPEAT \ ( c-addr1 c-addr2 u2>0 0 ) - -1 - ELSE \ ( c-addr1 c-addr2 0 u1 ) - dup 0= IF 0 ELSE 1 THEN - THEN >r 2drop 2drop r> ; - - -\ dynamic memory -\ ------------------------------------- -Variable anchor - -50 Constant waste - -minint Constant #free \ sign bit -maxint Constant #max - -: size ( mem -- size ) 1 cells - @ #max and ; - -: addr&size ( mem -- mem size ) dup size ; - -: above ( mem -- >mem ) addr&size + 2 cells + ; - -: use ( mem size -- ) - dup >r swap 2dup 1 cells - ! r> #max and + ! ; - -: release ( mem size -- ) #free or use ; - -: fits? ( size -- mem | false ) >r anchor @ - BEGIN addr&size r@ u< 0= - IF r> drop exit THEN - @ dup anchor @ = - UNTIL 0= r> drop ; - -: link ( mem >mem r 2dup cell+ ! over ! r> 2dup ! swap cell+ ! ; - -: @links ( mem -- ) dup @ swap cell+ @ ; - -: setanchor ( mem -- mem ) - dup anchor @ = IF dup @ anchor ! THEN ; - -: unlink ( mem -- ) setanchor @links 2dup ! swap cell+ ! ; - -: allocate ( size -- mem ior ) - 3 cells max dup >r fits? ?dup 0= IF r> -8 exit THEN ( "dictionary overflow" ) - addr&size r@ - dup waste u< - IF drop dup @ over unlink over addr&size use - ELSE 2 cells - over r@ use - over above dup rot release - 2dup swap @links link THEN - r> drop anchor ! 0 ; - -: free ( mem -- ior ) - addr&size over 2 cells - @ dup 0< - IF #max and 2 cells + rot over - rot rot + - ELSE drop over anchor @ dup cell+ @ link THEN - 2dup + cell+ dup @ dup 0< - IF #max and swap cell+ unlink + 2 cells + release 0 exit THEN - 2drop release 0 ; - -: resize ( mem newsize -- mem' ior ) - over swap over size 2dup > - IF ( mem mem size newsize ) swap allocate ?dup IF >r drop 2drop r> exit THEN - dup >r swap move free r> swap exit THEN - 2drop drop ; - -: empty-memory ( addr size -- ) - >r cell+ dup anchor ! dup 2 cells use dup 2dup link - dup above swap over dup link - dup r> 7 cells - release above 1 cells - 0 swap ! ; - -: init ( -- ) - here 10000 ( chars ) dup allot empty-memory ; - -init - -: alloc ( u -- addr ) - allocate throw ; - -: dispose ( addr -- ) - free throw ; - - -: ?memory ( -- ) anchor @ - cr ." ->: " BEGIN cr dup u. ." : " addr&size u. @ dup anchor @ = UNTIL - cr ." <-: " BEGIN cr dup u. ." : " addr&size u. cell+ @ dup anchor @ = UNTIL - drop ; - -\ Some general memory allocation words - -\ : alloc ( u -- addr ) -\ here swap allot ; - -\ : dispose ( addr -- ) -\ drop ; - -\ for the input stream a struct could be defined that generally handles terminal input, evaluate, file input and others. - -Create tib 80 allot - -Create 'source here 0 , tib , \ ' source is normally ^tib #tib is set to c-addr u for evaluate -Constant #tib - -Defer getkey ' key is getkey - -Variable input-echo -1 input-echo ! - -: accept ( c-addr u1 -- u2 ) - >r - 0 BEGIN ( c-addr u2 ) ( R: u1 ) - getkey dup 10 = over 13 = or 0= - WHILE ( c-addr u2 key ) - dup 8 = over 127 = or - IF drop dup 0 > - IF 1- 8 emit bl emit 8 emit ELSE 7 emit THEN ELSE - input-echo @ IF dup emit THEN >r 2dup + r> swap c! 1+ r@ min THEN - REPEAT ( c-addr u2 key r:u1 ) - drop r> drop nip - \ input-echo @ IF cr THEN - input-echo @ IF space THEN -; - -: query ( -- ) - tib 80 accept #tib ! ; - - - -\ Header - -0 -1 cells Field _link -1 Field _flags -1 cells Field _xt -0 Field _name - -Constant #header - - -Variable last - -: "header ( c-addr u -- addr ) - \ 2dup lowercase - dup #header + 1+ alloc >r ( c-addr u r:addr ) - 0 r@ _link ! - 0 r@ _flags c! - 0 r@ _xt ! - r@ _name place - r> ; - - -Variable current - -: link-header ( addr -- ) - current @ @ swap _link dup last ! dup current @ ! ! ; - -: @flags ( -- x ) - last @ _flags c@ ; - -: !flags ( x -- ) - last @ _flags c! ; - - -Definer Header-flag ( x -- ) - create >r , r> does> ( -- ) @ @flags or !flags ; - -Definer Header-flag? ( x -- ) - create >r , r> does> ( addr -- f ) @ swap _flags @ and 0<> ; - -128 dup Header-flag immediate Header-flag? immediate? - 64 dup Header-flag headerless Header-flag? headerless? - -: pad ( -- addr ) - here 100 + ; - - -: wordlist ( -- wid ) here 0 , ; - -Create search-order 0 , 10 cells allot - -: get-order ( -- wid0 wid1 wid2 ... widn n ) - search-order dup @ dup >r cells + r@ - BEGIN ( addr n ) - dup - WHILE ( addr n ) - >r dup >r @ r> cell- r> 1- - REPEAT ( wid0 wid1 wid2 ... widn addr 0 ) - 2drop r> ; - -: set-order ( wid0 wid1 wid2 ... widn n ) - dup search-order ! - search-order cell+ swap - BEGIN ( wid0 wid1 ... widn addr n ) - dup - WHILE ( wid0 wid1 ... widn addr n ) - >r swap over ! cell+ r> 1- - REPEAT ( addr 0 ) - 2drop ; - -: get-current ( -- wid ) current @ ; -: set-current ( wid -- ) current ! ; - -: context ( -- addr ) search-order cell+ ; - -wordlist Constant forth-wordlist - -: Forth ( -- ) get-order nip forth-wordlist swap set-order ; -: also ( -- ) get-order over swap 1+ set-order ; -: previous ( -- ) get-order nip 1- set-order ; -: only ( -- ) forth-wordlist 1 set-order ; -: definitions ( -- ) get-order over set-current set-order ; -\ : OnlyForth ( -- ) only Forth also definitions ; - -only Forth also definitions - -: .wordlist ( wid -- ) - dup forth-wordlist = IF drop ." Forth " exit THEN - u. ; - -: order ( -- ) - search-order dup cell+ swap @ - BEGIN ( addr n ) - dup - WHILE ( addr n ) - >r dup @ .wordlist - cell+ r> 1- - REPEAT ( addr n ) - 2drop - space current @ .wordlist ; - -: words ( -- ) 0 >r - context @ @ - BEGIN ?dup WHILE dup dup headerless? IF '|' emit THEN _name count type space @ r> 1+ >r REPEAT - r> space . ." words" ; - -: hide ( -- ) - last @ @ current @ ! ; - -: reveal ( -- ) - last @ current @ ! ; - -reveal - -: !chars ( S addr -- addr' ) - over 0= IF nip exit THEN - rot >r swap 1- swap !chars - r> over c! 1+ ; - -: !str ( S addr -- ) - 2dup c! 1+ !chars drop ; - -Macro has-header ( -- ) - seed $name - seed pad - seed !str - seed pad - seed count - seed "header - seed dup - seed link-header - seed _xt - seed ! -end-macro - - -' bye has-header bye \ 0 00 -' emit has-header emit \ 1 01 -' key has-header key \ 2 02 -' dup has-header dup \ 3 03 -' swap has-header swap \ 4 04 -' drop has-header drop \ 5 05 -' 0< has-header 0< \ 6 06 -' ?exit has-header ?exit \ 7 07 -' >r has-header >r \ 8 08 -' r> has-header r> \ 9 09 -' - has-header - \ 10 0A -' exit has-header exit \ 11 0B -' lit has-header lit \ 12 0C -' @ has-header @ \ 13 0D -' c@ has-header c@ \ 14 0E -' ! has-header ! \ 15 0F -' c! has-header c! \ 16 10 -' execute has-header execute \ 17 11 -' branch has-header branch \ 18 12 -' ?branch has-header ?branch \ 19 13 -' negate has-header negate \ 20 14 -' + has-header + \ 21 15 -' 0= has-header 0= \ 22 16 -' ?dup has-header ?dup \ 23 17 -' cells has-header cells \ 24 18 -' +! has-header +! \ 25 19 -' h@ has-header h@ \ 26 1A -' h, has-header h, \ 27 1B -' here has-header here \ 28 1C -' allot has-header allot \ 29 1D -' , has-header , \ 30 1E -' c, has-header c, \ 31 1F -' fun has-header fun \ 32 20 -' interpreter has-header interpreter \ 33 21 -' compiler has-header compiler \ 34 22 -' create has-header create \ 35 23 -' does> has-header does> \ 36 24 -' cold has-header cold \ 37 25 -' depth has-header depth \ 38 26 -' compile, has-header compile, \ 39 26 -' new has-header new \ 40 28 -' couple has-header couple \ 41 29 -' and has-header and \ 42 2A -' or has-header or \ 43 2B -' catch has-header catch \ 44 2C -' throw has-header throw \ 45 2D -' sp@ has-header sp@ \ 46 2E -' sp! has-header sp! \ 47 2F -' rp@ has-header rp@ \ 48 30 -' rp! has-header rp! \ 49 31 -' $lit has-header $lit \ 50 32 -' num has-header num \ 51 33 -' um* has-header um* -' um/mod has-header um/mod -' unused has-header unused -' key? has-header key? -\ ' token has-header token -' usleep has-header usleep -' hp has-header hp - -' over has-header over -' rot has-header rot -' -rot has-header -rot -' /string has-header /string -' type has-header type -' 2drop has-header 2drop -' 2dup has-header 2dup -' 2swap has-header 2swap -' 2over has-header 2over -' xor has-header xor -' max has-header max -' min has-header min -' minint has-header minint -' maxint has-header maxint -' dispose has-header dispose -' alloc has-header alloc - - -' cr has-header cr -' .s has-header .s -' t{ has-header t{ -' -> has-header -> -' }t has-header }t - -' bl has-header bl -' space has-header space -' spaces has-header spaces - -' 1+ has-header 1+ -' 2+ has-header 2+ -' 1- has-header 1- -' invert has-header invert -' nip has-header nip -' u< has-header u< -' < has-header < -' > has-header > -' = has-header = -' count has-header count -' 2* has-header 2* - -' abs has-header abs -' r@ has-header r@ -' third has-header third -' cmove has-header cmove -' cell+ has-header cell+ -' cell- has-header cell- -' place has-header place -' compare has-header compare -' 2@ has-header 2@ -' 2! has-header 2! - -' skip has-header skip -' scan has-header scan -' . has-header . -' u. has-header u. -' words has-header words -' context has-header context -' immediate has-header immediate -' reveal has-header reveal -' hide has-header hide -' pad has-header pad -' >body has-header >body - -' allocate has-header allocate -' free has-header free -' ?memory has-header ?memory - -' headerless has-header headerless -' headerless? has-header headerless? - -' set-current has-header set-current -' get-current has-header get-current -' set-order has-header set-order -' get-order has-header get-order -' wordlist has-header wordlist -' only has-header only -' also has-header also -' previous has-header previous -' order has-header order -' forth-wordlist has-header forth-wordlist -' Forth has-header Forth -' definitions has-header definitions -' only has-header only -\ ' OnlyForth has-header OnlyForth -' .wordlist has-header .wordlist -' getkey has-header getkey -' frame has-header frame - -' "header has-header "header -' link-header has-header link-header -' _xt has-header _xt - - -Macro :noname - seed new - seed compiler -end-macro - -: compile ( -- ) - r> dup cell+ >r @ , ; - - -Variable >in ( -- addr ) - -' >in has-header >in - -: source ( -- c-addr u ) 'source 2@ ; - -' source has-header source - -: parse ( c -- c-addr u ) - >r source >in @ /string - 2dup r> dup >r scan - 2dup r> skip nip source nip swap - >in ! - nip - ; - -: parse-name ( -- c-addr u ) - source >in @ /string - bl skip 2dup bl scan source nip 2dup swap - 1+ min >in ! nip - ; - -' parse has-header parse -' parse-name has-header parse-name - -Variable heads -1 heads ! - -: | ( -- ) 1 heads ! ; - -: head? ( -- f ) - heads @ dup IF -1 heads ! -1 = exit THEN ; - - -: (Create) ( -- ) - parse-name "header dup link-header create swap _xt ! reveal - head? ?exit headerless -; - -' (Create) has-header Create - -: last-xt ( -- xt ) - last @ _xt @ ; - -: (Does>) ( -- ) - [ ' last-xt ] Literal compile, - [ ' does> ] Literal compile, ; - -' (Does>) has-header Does> immediate -' last has-header last -' _xt has-header _xt -' _name has-header _name - -: (Literal) ( x -- ) - lit [ ' lit , ] compile, , ; - -' (Literal) has-header Literal immediate - -: (s") ( ccc" -- ) - [ ' $lit ] Literal compile, - '"' parse here over 1+ allot place ; - -' (s") has-header s" immediate - -: (.") ( ccc" -- ) - (s") - [ ' type ] Literal compile, ; - -' (.") has-header ." immediate - -: dot-paren - ')' parse type ; - -' dot-paren has-header .( immediate - -: match ( c-addr1 u1 header -- f ) - _name count compare 0= ; - -: find-name-in ( c-addr u link -- header|0 ) - \ >r 2dup lowercase r> - BEGIN ( c-addr u link ) - dup - WHILE ( c-addr u link ) - >r 2dup r> dup >r - match IF 2drop r> exit THEN - r> @ - REPEAT - nip nip ; - -' find-name-in has-header find-name-in - -: find-name ( c-addr u -- header|0 ) - search-order dup cell+ swap @ - BEGIN ( c-addr u addr n ) - dup - WHILE ( c-addr u addr n ) - >r >r - 2dup r@ @ find-name-in ?dup IF nip nip r> drop r> drop exit THEN - r> cell+ r> 1- - REPEAT ( c-addr u addr n ) - 2drop 2drop 0 ; - -' find-name has-header find-name - -: find-xt-in ( xt wid -- header | 0 ) - BEGIN - dup - WHILE ( xt wid ) - 2dup _xt @ = IF nip exit THEN - _link @ - REPEAT ( xt wid ) - 2drop 0 ; - -: >name ( xt -- name | 0 ) - get-order over >r set-order r> find-xt-in dup IF _name THEN ; - -' >name has-header >name - -: find-addr-in ( xt wid -- header | 0 ) - BEGIN - dup - WHILE ( xt wid ) - 2dup _xt @ h@ = IF nip exit THEN - _link @ - REPEAT ( xt wid ) - 2drop 0 ; - -: addr>name ( xt -- name | 0 ) - get-order over >r set-order r> find-addr-in dup IF _name THEN ; - -' addr>name has-header addr>name - - - -: Alias ( xt -- ) - parse-name "header dup link-header _xt ! ; - -' Alias has-header Alias - -: (postpone) ( -- ) - parse-name find-name dup 0= -13 and throw - dup immediate? IF - _xt @ compile, - ELSE - [ ' lit ] Literal compile, _xt @ , [ ' compile, ] Literal compile, - THEN -; - -' (postpone) has-header postpone immediate -' immediate? has-header immediate? - -: tick ( -- xt ) - parse-name find-name dup IF _xt @ exit THEN -13 throw ; - -' tick has-header ' - -: ([']) ( -- xt ) - tick [ ' lit ] Literal compile, , ; - -' ([']) has-header ['] immediate - - -: digit? ( c -- f ) - dup '0' < IF drop 0 exit THEN '9' > 0= ; - -: ?# ( c-addr u -- x 0 0 | c-addr u ) - dup 0= ?exit - over c@ '-' = dup >r IF 1 /string THEN - 2dup 0 >r - BEGIN - dup - WHILE - over c@ dup digit? 0= IF drop r> drop r> drop 2drop exit THEN - '0' - r> 10 um* drop + >r - 1 /string - REPEAT - 2drop 2drop r> r> IF negate THEN 0 0 ; - -: ,# ( c-addr u -- 0 0 | c-addr u ) - dup 0= ?exit - ?# dup ?exit - lit [ ' lit , ] compile, rot , ; - -: ?'x' ( c-addr u -- x 0 0 | c-addr u ) - dup 0= ?exit - dup 3 = - IF over c@ ''' - ?exit - over 2 + c@ ''' - ?exit - drop 1+ c@ 0 0 THEN ; - -: ,'x' ( c-addr u -- 0 0 | c-addr u ) - dup 0= ?exit - ?'x' dup ?exit - lit [ ' lit , ] compile, rot , ; - -: ?word ( c-addr1 u1 | i*x c-addr2 u2 ) - dup 0= ?exit - 2dup find-name ?dup IF - nip nip _xt @ execute 0 0 - THEN -; - -: (interpreters ( c-addr1 u1 | i*x c-addr2 u2 ) - ?word - ?# - ?'x' - over IF space type ( '?' emit ) space -13 throw THEN -; - -: ,word ( c-addr1 u1 | i*x c-addr2 u2 ) - dup 0= ?exit - 2dup find-name ?dup - IF - nip nip dup immediate? IF _xt @ execute ELSE _xt @ compile, THEN 0 0 - THEN -; - -: (compilers ( c-addr u1 | i*x c-addr2 u2 ) - ,word - ,# - ,'x' - over IF space type '?' emit space -13 throw THEN -; - -Variable compilers ' (compilers compilers ! -Variable interpreters ' (interpreters interpreters ! -Variable handlers interpreters @ handlers ! - -: (]) ( -- ) - compilers @ handlers ! ; - -: ([) - interpreters @ handlers ! ; - -: Header ( -- addr ) - parse-name "header dup link-header reveal - head? ?exit headerless ; - -: (:) ( -- ) - Header new swap _xt ! hide (]) ; - -: (;) ( -- ) - lit [ ' exit , ] compile, reveal ([) ; - -' (]) has-header ] -' ([) has-header [ immediate -' (;) has-header ; immediate -' (:) has-header : -' | has-header | -' heads has-header heads - -: interpret ( -- ) - BEGIN ( ) - parse-name dup - WHILE ( c-addr u ) - handlers @ execute 2drop - REPEAT - 2drop ; - -: evaluate ( c-addr u -- ) - 'source 2@ >r >r 'source 2! - >in @ >r 0 >in ! - \ ['] interpret catch - [ ' interpret ] Literal catch - r> >in ! - r> r> 'source 2! - throw -; - -' evaluate has-header evaluate - -: refill ( -- f ) - 'source cell+ @ tib = IF query 0 >in ! -1 exit THEN - 0 ; - -' refill has-header refill - - -Variable echo -1 echo ! -' echo has-header echo - -' input-echo has-header input-echo - -\ ANSI terminal colors - -: esc ( -- ) 27 emit ; ' esc has-header esc -: bold ( -- ) esc ." [1m" ; -: normal ( -- ) esc ." [0m" ; ' normal has-header normal -: reverse ( -- ) esc ." [7m" ; ' reverse has-header reverse -\ : black ( -- ) esc ." [30m" ; -: red ( -- ) esc ." [31m" ; -: green ( -- ) esc ." [32m" ; -\ : yellow ( -- ) esc ." [33m" ; -: blue ( -- ) esc ." [34m" ; -\ : bright-blue ( -- ) esc ." [94m" ; -: reset-colors ( -- ) esc ." [39;49m" ; -: cyan ( -- ) esc ." [96m" ; -: page ( -- ) esc ." [2J" esc ." [H" ; - -' blue has-header blue -' page has-header page - -: compiling? ( -- f ) - handlers @ compilers @ = ; - -' compiling? has-header compiling? - -Defer .status : noop ; ' noop is .status - -' noop has-header noop - -' .status has-header .status - -: prompt ( -- ) - echo @ IF - cr cyan bold .s normal reset-colors compiling? IF ']' ELSE '>' THEN emit space - THEN ; - -: .ok ( -- ) - echo @ IF space bold green ." ok 🙂" normal reset-colors THEN ; \ 🆗 - -: ?stack ( -- ) - depth 0< -4 and throw ; - -: restart ( -- ) - tib 0 'source 2! - ([) - BEGIN - .status prompt query 0 >in ! interpret ?stack .ok - 0 UNTIL ; - -: warm ( -- ) - \ [ ' [ compile, ] - empty-stack restart ; - - +\ interactive part 2 Constant major ( -- x ) 2 Constant minor ( -- x ) 0 Constant patch ( -- x ) @@ -1161,33 +115,6 @@ Defer .status : noop ; ' noop is .status cr ." ---------------------------" cr unused . ." bytes free" cr ; -Create errormsg 0 , 0 , - -' errormsg has-header errormsg - -: .error# ( n -- ) - dup -1 = IF drop ." abort" exit THEN - dup -2 = IF drop ." error: " - errormsg 2@ type 0 0 errormsg 2! exit THEN - dup -4 = IF drop ." stack underflow" exit THEN - dup -13 = IF drop ." not found" exit THEN - dup -16 = IF drop ." attempt to use zero-length string as a name" exit THEN - dup -39 = IF drop ." unexpected end of file" exit THEN - ." error " . ; - -: .error ( n -- ) - red bold .error# normal reset-colors ." 🤔 " ; - - -: boot ( -- ) - key drop \ skip 0 of boot program - .banner - BEGIN - [ ' warm ] Literal catch ?dup IF .error cr THEN - AGAIN ; - -' boot has-header boot - \ ---- try colored words with embedded ESC sequences Create colored-header here 0 c, here 27 c, '[' c, '3' c, '1' c, 'm' c, 'r' c, 'e' c, 'd' c, 'w' c, 'o' c, 'r' c, 'd' c, @@ -1202,8 +129,6 @@ cr t{ -> }t -0 echo ! -\ 0 input-echo ! reveal +.banner boot -END diff --git a/preForth/seedForthRuntime.seedsource b/preForth/seedForthRuntime.seedsource new file mode 100644 index 0000000..3706722 --- /dev/null +++ b/preForth/seedForthRuntime.seedsource @@ -0,0 +1,1095 @@ +\ seedForth interactive system +\ this file has routines needed to interpret or compile textual forth source + +\ Defining words +Definer Create ( -- ) create ( x ) drop ; +Definer Variable ( -- ) create ( x ) drop 0 , ; +Definer Constant ( x -- ) create ( x ) >r , r> does> @ ; + +Macro Literal + seed lit + seed [ + seed , + seed ] +end-macro + +\ Missing primitives +: over ( x1 x2 -- x1 x2 x1 ) + >r dup r> swap ; + +: rot ( a b c -- b c a ) + >r swap r> swap ; + +: -rot ( a b c -- c a b ) + swap >r swap r> ; + +: under+ ( x1 x2 x3 -- x1+x3 x2 ) + rot + swap ; + +: tuck ( x1 x2 -- x2 x1 x2 ) + swap over ; + +: /string ( x1 x2 x3 -- x4 x5 ) + swap over - >r + r> ; + +: 2drop ( x1 x2 -- ) + drop drop ; + +: 2dup ( x1 x2 -- x1 x2 x1 x2 ) + over over ; + +: 2swap ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) + >r -rot r> -rot ; + +: 2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) + >r >r 2dup r> r> 2swap ; + +: 1+ ( x1 -- x2 ) + 1 + ; + +: 2+ ( x1 -- x2 ) + 2 + ; + +: 1- ( x1 -- x2 ) + 1 - ; + +: invert ( x1 x2 -- x3 ) + negate 1- ; + +: nip ( x1 x2 -- x2 ) + swap drop ; + +: count ( addr -- c-addr u ) + dup 1+ swap c@ ; + +: xor ( x1 x2 -- x3 ) + 2dup or >r invert swap invert or r> and ; + +: u< ( u1 u2 -- f ) + 2dup xor 0< IF nip 0< exit THEN - 0< ; + +: < ( n1 n2 -- f ) + 2dup xor 0< IF drop 0< exit THEN - 0< ; + +: > ( n1 n2 -- f ) + swap < ; + +: = ( x1 x2 -- f ) + - 0= ; + +: 0<> ( x -- f ) + 0= 0= ; + +: 2* ( x1 -- x2 ) \ already in kernel + dup + ; + +: cell+ ( addr1 -- addr2 ) + 1 cells + ; + +: cell- ( addr1 -- addr2 ) + -1 cells + ; + +: 2@ ( addr -- x1 x2 ) + dup cell+ @ swap @ ; + +: 2! ( x1 x2 addr -- ) + swap over ! cell+ ! ; + +Definer Field ( offset size -- offset' ) + create >r over , + r> does> @ + ; + +\ output +32 Constant bl + +: cr ( -- ) + 10 emit 13 emit ; + +: type ( c-addr u -- ) + BEGIN dup WHILE over c@ emit 1 /string REPEAT 2drop ; + +: space ( -- ) + bl emit ; + +: spaces ( n -- ) + BEGIN ?dup WHILE space 1 - REPEAT ; + +Macro ." ( ccc" -- ) + seed s" + seed type +end-macro + +: .digit ( n -- ) + '0' + emit ; + +: third ( x1 x2 x3 -- x1 x2 x3 x1 ) + >r over r> swap ; + +: min ( n1 n2 -- n3 ) + 2dup > IF swap THEN drop ; + +: max ( n1 n2 -- n3 ) + 2dup < IF swap THEN drop ; + +: r@ ( -- x ) + r> r> dup >r swap >r ; + +: abs ( n -- +n ) + dup 0< IF negate THEN ; + +: cmove ( c-addr1 c-addr2 u -- ) + BEGIN + ?dup + WHILE + >r + over c@ over c! + 1+ swap 1+ swap + r> 1- + REPEAT + 2drop ; + +: move cmove ; + +: place ( c-addr1 u c-addr2 -- ) + 2dup >r >r 1+ swap cmove r> r> c! ; + +\ Exception handling + +Variable frame ( -- addr ) + +: catch ( i*x xt -- j*x 0 | i*x err ) + frame @ >r sp@ >r rp@ frame ! execute + r> drop r> frame ! 0 ; + +: throw ( i*x 0 | i*x err -- j*x err ) + ?dup 0= ?exit frame @ rp! r> swap >r sp! drop + r> r> frame ! ; + +\ save and empty + +Create savearea 0 , 0 , \ { hp | dp } + +: (save) ( -- ) + here hp @ savearea 2! ; + +Macro save ( -- ) + seed (save) + save-#tokens +end-macro + +: (empty) ( -- ) + savearea 2@ hp ! here - allot ( aka dp! ) ; + +Macro empty ( -- ) + seed (empty) + restore-#tokens +end-macro + +\ Tester +: empty-stack ( i*x -- ) + BEGIN depth 0< WHILE 0 REPEAT + BEGIN depth WHILE drop REPEAT ; + +Variable actual-depth ( actual-results ) 20 cells allot + +: nth-result ( n -- addr ) + cells actual-depth + ; + +: error ( i*x c-addr u -- ) + cr type empty-stack ; + +: t{ ( i*x -- ) + '.' emit empty-stack ; + +: -> ( -- ) + depth actual-depth ! + BEGIN depth WHILE depth nth-result ! REPEAT ; + +: }t ( i*x -- ) + depth actual-depth @ - IF s" wrong number of results" error exit THEN + BEGIN depth WHILE depth nth-result @ - IF s" incorrect result" error exit THEN REPEAT ; + +Macro begin-tests + seed save +end-macro + +Macro end-tests + seed empty +end-macro + +: minint ( -- n ) + 1 BEGIN dup 2* dup WHILE nip REPEAT drop ; + +minint 1- Constant maxint + +: skip ( c-addr1 u1 c -- c-addr2 u2 ) + BEGIN + over + WHILE + >r over c@ r> swap over = + WHILE + >r 1 /string r> + REPEAT THEN drop ; + +: scan ( c-addr u1 c -- c-addr2 u2 ) + BEGIN + over + WHILE + >r over c@ r> swap over - + WHILE + >r 1 /string r> + REPEAT THEN drop ; + +: (u. ( u1 -- ) + ?dup IF 0 10 um/mod (u. .digit THEN ; + +\ display unsigned number +: u. ( u -- ) + dup (u. 0= IF '0' emit THEN space ; + +\ display signed number +: . ( n -- ) + dup 0< IF '-' emit negate THEN u. ; + +: .s ( i*x -- i*x ) + depth 0= ?exit >r .s r> dup . ; + + +\ Deferred words + +: ' ( -- x ) token ; + +: uninitialized ( -- ) + cr s" uninitialized execution vector" type -1 throw ; + +Definer Defer ( -- ) + create >r [ ' uninitialized ] Literal , r> does> @ execute ; + +: >body ( xt -- body ) + h@ 1 cells + ; + +: is ( xt -- ) \ only interactive + ' >body ! ; + +\ String comparison +: compare ( c-addr1 u1 c-addr2 u2 -- n ) + rot + BEGIN \ ( c-addr1 c-addr2 u2 u1 ) + over + WHILE \ ( c-addr1 c-addr2 u2 u1 ) + dup + WHILE \ ( c-addr1 c-addr2 u2 u1 ) + >r >r over c@ over c@ - ?dup IF 0< 2* 1+ ( -1 | 1 ) nip nip r> drop r> drop exit THEN + 1+ swap 1+ swap + r> 1- r> 1- + REPEAT \ ( c-addr1 c-addr2 u2>0 0 ) + -1 + ELSE \ ( c-addr1 c-addr2 0 u1 ) + dup 0= IF 0 ELSE 1 THEN + THEN >r 2drop 2drop r> ; + + +\ dynamic memory +\ ------------------------------------- +Variable anchor + +50 Constant waste + +minint Constant #free \ sign bit +maxint Constant #max + +: size ( mem -- size ) 1 cells - @ #max and ; + +: addr&size ( mem -- mem size ) dup size ; + +: above ( mem -- >mem ) addr&size + 2 cells + ; + +: use ( mem size -- ) + dup >r swap 2dup 1 cells - ! r> #max and + ! ; + +: release ( mem size -- ) #free or use ; + +: fits? ( size -- mem | false ) >r anchor @ + BEGIN addr&size r@ u< 0= + IF r> drop exit THEN + @ dup anchor @ = + UNTIL 0= r> drop ; + +: link ( mem >mem r 2dup cell+ ! over ! r> 2dup ! swap cell+ ! ; + +: @links ( mem -- ) dup @ swap cell+ @ ; + +: setanchor ( mem -- mem ) + dup anchor @ = IF dup @ anchor ! THEN ; + +: unlink ( mem -- ) setanchor @links 2dup ! swap cell+ ! ; + +: allocate ( size -- mem ior ) + 3 cells max dup >r fits? ?dup 0= IF r> -8 exit THEN ( "dictionary overflow" ) + addr&size r@ - dup waste u< + IF drop dup @ over unlink over addr&size use + ELSE 2 cells - over r@ use + over above dup rot release + 2dup swap @links link THEN + r> drop anchor ! 0 ; + +: free ( mem -- ior ) + addr&size over 2 cells - @ dup 0< + IF #max and 2 cells + rot over - rot rot + + ELSE drop over anchor @ dup cell+ @ link THEN + 2dup + cell+ dup @ dup 0< + IF #max and swap cell+ unlink + 2 cells + release 0 exit THEN + 2drop release 0 ; + +: resize ( mem newsize -- mem' ior ) + over swap over size 2dup > + IF ( mem mem size newsize ) swap allocate ?dup IF >r drop 2drop r> exit THEN + dup >r swap move free r> swap exit THEN + 2drop drop ; + +: empty-memory ( addr size -- ) + >r cell+ dup anchor ! dup 2 cells use dup 2dup link + dup above swap over dup link + dup r> 7 cells - release above 1 cells - 0 swap ! ; + +: init ( -- ) + here 10000 ( chars ) dup allot empty-memory ; + +init + +: alloc ( u -- addr ) + allocate throw ; + +: dispose ( addr -- ) + free throw ; + + +: ?memory ( -- ) anchor @ + cr ." ->: " BEGIN cr dup u. ." : " addr&size u. @ dup anchor @ = UNTIL + cr ." <-: " BEGIN cr dup u. ." : " addr&size u. cell+ @ dup anchor @ = UNTIL + drop ; + +\ Some general memory allocation words + +\ : alloc ( u -- addr ) +\ here swap allot ; + +\ : dispose ( addr -- ) +\ drop ; + +\ for the input stream a struct could be defined that generally handles terminal input, evaluate, file input and others. + +Create tib 255 allot + +Create 'source here 0 , tib , \ ' source is normally ^tib #tib is set to c-addr u for evaluate +Constant #tib + +Defer getkey ' key is getkey + +\ after loading the *.seed runtime we will need to load further runtime as +\ textual forth source before being useable, so we will default to echo off +Variable input-echo 0 input-echo ! + +: accept ( c-addr u1 -- u2 ) + >r + 0 BEGIN ( c-addr u2 ) ( R: u1 ) + getkey dup 10 = over 13 = or 0= + WHILE ( c-addr u2 key ) + dup 8 = over 127 = or IF + drop dup 0 > IF + 1- 8 emit bl emit 8 emit + ELSE + 7 emit + THEN + ELSE + \ only char write to buffer and echo if there is room + over r@ < IF + >r 2dup + r@ swap c! 1+ r> + input-echo @ IF dup emit THEN + THEN + \ if char was EOT, quit after maybe writing to buffer + 4 = IF r> drop nip exit THEN + THEN + REPEAT ( c-addr u2 key r:u1 ) + drop r> drop nip + \ input-echo @ IF cr THEN + input-echo @ IF space THEN +; + +: query ( -- ) + tib 255 accept #tib ! ; + + + +\ Header + +0 +1 cells Field _link +1 Field _flags +1 cells Field _xt +0 Field _name + +Constant #header + + +Variable last + +: "header ( c-addr u -- addr ) + \ 2dup lowercase + dup #header + 1+ alloc >r ( c-addr u r:addr ) + 0 r@ _link ! + 0 r@ _flags c! + 0 r@ _xt ! + r@ _name place + r> ; + + +Variable current + +: link-header ( addr -- ) + current @ @ swap _link dup last ! dup current @ ! ! ; + +: @flags ( -- x ) + last @ _flags c@ ; + +: !flags ( x -- ) + last @ _flags c! ; + + +Definer Header-flag ( x -- ) + create >r , r> does> ( -- ) @ @flags or !flags ; + +Definer Header-flag? ( x -- ) + create >r , r> does> ( addr -- f ) @ swap _flags @ and 0<> ; + +128 dup Header-flag immediate Header-flag? immediate? + 64 dup Header-flag headerless Header-flag? headerless? + +: pad ( -- addr ) + here 100 + ; + + +: wordlist ( -- wid ) here 0 , ; + +Create search-order 0 , 10 cells allot + +: get-order ( -- wid0 wid1 wid2 ... widn n ) + search-order dup @ dup >r cells + r@ + BEGIN ( addr n ) + dup + WHILE ( addr n ) + >r dup >r @ r> cell- r> 1- + REPEAT ( wid0 wid1 wid2 ... widn addr 0 ) + 2drop r> ; + +: set-order ( wid0 wid1 wid2 ... widn n ) + dup search-order ! + search-order cell+ swap + BEGIN ( wid0 wid1 ... widn addr n ) + dup + WHILE ( wid0 wid1 ... widn addr n ) + >r swap over ! cell+ r> 1- + REPEAT ( addr 0 ) + 2drop ; + +: get-current ( -- wid ) current @ ; +: set-current ( wid -- ) current ! ; + +: context ( -- addr ) search-order cell+ ; + +wordlist Constant forth-wordlist + +: Forth ( -- ) get-order nip forth-wordlist swap set-order ; +: also ( -- ) get-order over swap 1+ set-order ; +: previous ( -- ) get-order nip 1- set-order ; +: only ( -- ) forth-wordlist 1 set-order ; +: definitions ( -- ) get-order over set-current set-order ; +\ : OnlyForth ( -- ) only Forth also definitions ; + +only Forth also definitions + +: .wordlist ( wid -- ) + dup forth-wordlist = IF drop ." Forth " exit THEN + u. ; + +: order ( -- ) + search-order dup cell+ swap @ + BEGIN ( addr n ) + dup + WHILE ( addr n ) + >r dup @ .wordlist + cell+ r> 1- + REPEAT ( addr n ) + 2drop + space current @ .wordlist ; + +: words ( -- ) 0 >r + context @ @ + BEGIN ?dup WHILE dup dup headerless? IF '|' emit THEN _name count type space @ r> 1+ >r REPEAT + r> space . ." words" ; + +: hide ( -- ) + last @ @ current @ ! ; + +: reveal ( -- ) + last @ current @ ! ; + +reveal + +: !chars ( S addr -- addr' ) + over 0= IF nip exit THEN + rot >r swap 1- swap !chars + r> over c! 1+ ; + +: !str ( S addr -- ) + 2dup c! 1+ !chars drop ; + +Macro has-header ( -- ) + seed $name + seed pad + seed !str + seed pad + seed count + seed "header + seed dup + seed link-header + seed _xt + seed ! +end-macro + + +' bye has-header bye +' dup has-header dup +' swap has-header swap +' drop has-header drop +' 0< has-header 0< +' ?exit has-header ?exit +' >r has-header >r +' r> has-header r> +' - has-header - +' exit has-header exit +' lit has-header lit +' @ has-header @ +' c@ has-header c@ +' ! has-header ! +' c! has-header c! +' execute has-header execute +' branch has-header branch +' ?branch has-header ?branch +' negate has-header negate +' + has-header + +' 0= has-header 0= +' ?dup has-header ?dup +' cells has-header cells +' +! has-header +! +' h@ has-header h@ +' h, has-header h, +' here has-header here +' allot has-header allot +' , has-header , +' c, has-header c, +' fun has-header fun +' interpreter has-header interpreter +' compiler has-header compiler +' create has-header create +' does> has-header does> +' cold has-header cold +' depth has-header depth +' compile, has-header compile, +' new has-header new +' couple has-header couple +' and has-header and +' or has-header or +' catch has-header catch +' throw has-header throw +' sp@ has-header sp@ +' sp! has-header sp! +' rp@ has-header rp@ +' rp! has-header rp! +' $lit has-header $lit +' num has-header num +' um* has-header um* +' um/mod has-header um/mod +' unused has-header unused +' key? has-header key? +\ ' token has-header token +' usleep has-header usleep +' hp has-header hp +' key has-header key +' emit has-header emit +' eemit has-header eemit + +' over has-header over +' rot has-header rot +' -rot has-header -rot +' /string has-header /string +' type has-header type +' 2drop has-header 2drop +' 2dup has-header 2dup +' 2swap has-header 2swap +' 2over has-header 2over +' xor has-header xor +' max has-header max +' min has-header min +' minint has-header minint +' maxint has-header maxint +' dispose has-header dispose +' alloc has-header alloc + + +' cr has-header cr +' .s has-header .s +' t{ has-header t{ +' -> has-header -> +' }t has-header }t + +' bl has-header bl +' space has-header space +' spaces has-header spaces + +' 1+ has-header 1+ +' 2+ has-header 2+ +' 1- has-header 1- +' invert has-header invert +' nip has-header nip +' u< has-header u< +' < has-header < +' > has-header > +' = has-header = +' count has-header count +' 2* has-header 2* + +' abs has-header abs +' r@ has-header r@ +' third has-header third +' cmove has-header cmove +' cell+ has-header cell+ +' cell- has-header cell- +' place has-header place +' compare has-header compare +' 2@ has-header 2@ +' 2! has-header 2! + +' skip has-header skip +' scan has-header scan +' . has-header . +' u. has-header u. +' words has-header words +' context has-header context +' immediate has-header immediate +' reveal has-header reveal +' hide has-header hide +' pad has-header pad +' >body has-header >body + +' allocate has-header allocate +' free has-header free +' ?memory has-header ?memory + +' headerless has-header headerless +' headerless? has-header headerless? + +' set-current has-header set-current +' get-current has-header get-current +' set-order has-header set-order +' get-order has-header get-order +' wordlist has-header wordlist +' only has-header only +' also has-header also +' previous has-header previous +' order has-header order +' forth-wordlist has-header forth-wordlist +' Forth has-header Forth +' definitions has-header definitions +' only has-header only +\ ' OnlyForth has-header OnlyForth +' .wordlist has-header .wordlist +' getkey has-header getkey +' frame has-header frame + +' "header has-header "header +' link-header has-header link-header +' _xt has-header _xt + + +Macro :noname + seed new + seed compiler +end-macro + +: compile ( -- ) + r> dup cell+ >r @ , ; + + +Variable >in ( -- addr ) + +' >in has-header >in + +: source ( -- c-addr u ) 'source 2@ ; + +' source has-header source + +: parse ( c -- c-addr u ) + >r source >in @ /string + 2dup r> dup >r scan + 2dup r> skip nip source nip swap - >in ! + nip - ; + +: parse-name ( -- c-addr u ) + source >in @ /string + bl skip 2dup bl scan source nip 2dup swap - 1+ min >in ! nip - ; + +' parse has-header parse +' parse-name has-header parse-name + +Variable heads -1 heads ! + +: | ( -- ) 1 heads ! ; + +: head? ( -- f ) + heads @ dup IF -1 heads ! -1 = exit THEN ; + + +: (Create) ( -- ) + parse-name "header dup link-header create swap _xt ! reveal + head? ?exit headerless +; + +' (Create) has-header Create + +: last-xt ( -- xt ) + last @ _xt @ ; + +: (Does>) ( -- ) + [ ' last-xt ] Literal compile, + [ ' does> ] Literal compile, ; + +' (Does>) has-header Does> immediate +' last has-header last +' _xt has-header _xt +' _name has-header _name + +: (Literal) ( x -- ) + lit [ ' lit , ] compile, , ; + +' (Literal) has-header Literal immediate + +: (s") ( ccc" -- ) + [ ' $lit ] Literal compile, + '"' parse here over 1+ allot place ; + +' (s") has-header s" immediate + +: (.") ( ccc" -- ) + (s") + [ ' type ] Literal compile, ; + +' (.") has-header ." immediate + +: dot-paren + ')' parse type ; + +' dot-paren has-header .( immediate + +: match ( c-addr1 u1 header -- f ) + _name count compare 0= ; + +: find-name-in ( c-addr u link -- header|0 ) + \ >r 2dup lowercase r> + BEGIN ( c-addr u link ) + dup + WHILE ( c-addr u link ) + >r 2dup r> dup >r + match IF 2drop r> exit THEN + r> @ + REPEAT + nip nip ; + +' find-name-in has-header find-name-in + +: find-name ( c-addr u -- header|0 ) + search-order dup cell+ swap @ + BEGIN ( c-addr u addr n ) + dup + WHILE ( c-addr u addr n ) + >r >r + 2dup r@ @ find-name-in ?dup IF nip nip r> drop r> drop exit THEN + r> cell+ r> 1- + REPEAT ( c-addr u addr n ) + 2drop 2drop 0 ; + +' find-name has-header find-name + +: find-xt-in ( xt wid -- header | 0 ) + BEGIN + dup + WHILE ( xt wid ) + 2dup _xt @ = IF nip exit THEN + _link @ + REPEAT ( xt wid ) + 2drop 0 ; + +: >name ( xt -- name | 0 ) + get-order over >r set-order r> find-xt-in dup IF _name THEN ; + +' >name has-header >name + +: find-addr-in ( xt wid -- header | 0 ) + BEGIN + dup + WHILE ( xt wid ) + 2dup _xt @ h@ = IF nip exit THEN + _link @ + REPEAT ( xt wid ) + 2drop 0 ; + +: addr>name ( xt -- name | 0 ) + get-order over >r set-order r> find-addr-in dup IF _name THEN ; + +' addr>name has-header addr>name + + + +: Alias ( xt -- ) + parse-name "header dup link-header _xt ! ; + +' Alias has-header Alias + +: (postpone) ( -- ) + parse-name find-name dup 0= -13 and throw + dup immediate? IF + _xt @ compile, + ELSE + [ ' lit ] Literal compile, _xt @ , [ ' compile, ] Literal compile, + THEN +; + +' (postpone) has-header postpone immediate +' immediate? has-header immediate? + +: tick ( -- xt ) + parse-name find-name dup IF _xt @ exit THEN -13 throw ; + +' tick has-header ' + +: ([']) ( -- xt ) + tick [ ' lit ] Literal compile, , ; + +' ([']) has-header ['] immediate + + +: digit? ( c -- f ) + dup '0' < IF drop 0 exit THEN '9' > 0= ; + +: ?# ( c-addr u -- x 0 0 | c-addr u ) + dup 0= ?exit + over c@ '-' = dup >r IF 1 /string THEN + 2dup 0 >r + BEGIN + dup + WHILE + over c@ dup digit? 0= IF drop r> drop r> drop 2drop exit THEN + '0' - r> 10 um* drop + >r + 1 /string + REPEAT + 2drop 2drop r> r> IF negate THEN 0 0 ; + +: ,# ( c-addr u -- 0 0 | c-addr u ) + dup 0= ?exit + ?# dup ?exit + lit [ ' lit , ] compile, rot , ; + +: ?'x' ( c-addr u -- x 0 0 | c-addr u ) + dup 0= ?exit + dup 3 = + IF over c@ ''' - ?exit + over 2 + c@ ''' - ?exit + drop 1+ c@ 0 0 THEN ; + +: ,'x' ( c-addr u -- 0 0 | c-addr u ) + dup 0= ?exit + ?'x' dup ?exit + lit [ ' lit , ] compile, rot , ; + +: ?word ( c-addr1 u1 | i*x c-addr2 u2 ) + dup 0= ?exit + 2dup find-name ?dup IF + nip nip _xt @ execute 0 0 + THEN +; + +: (interpreters ( c-addr1 u1 | i*x c-addr2 u2 ) + ?word + ?# + ?'x' + over IF space type ( '?' emit ) space -13 throw THEN +; + +: ,word ( c-addr1 u1 | i*x c-addr2 u2 ) + dup 0= ?exit + 2dup find-name ?dup + IF + nip nip dup immediate? IF _xt @ execute ELSE _xt @ compile, THEN 0 0 + THEN +; + +: (compilers ( c-addr u1 | i*x c-addr2 u2 ) + ,word + ,# + ,'x' + over IF space type '?' emit space -13 throw THEN +; + +Variable compilers ' (compilers compilers ! +Variable interpreters ' (interpreters interpreters ! +Variable handlers interpreters @ handlers ! + +: (]) ( -- ) + compilers @ handlers ! ; + +: ([) + interpreters @ handlers ! ; + +: Header ( -- addr ) + parse-name "header dup link-header reveal + head? ?exit headerless ; + +: (:) ( -- ) + Header new swap _xt ! hide (]) ; + +: (;) ( -- ) + lit [ ' exit , ] compile, reveal ([) ; + +' (]) has-header ] +' ([) has-header [ immediate +' (;) has-header ; immediate +' (:) has-header : +' | has-header | +' heads has-header heads + +: interpret ( -- ) + BEGIN ( ) + parse-name dup + WHILE ( c-addr u ) + handlers @ execute 2drop + REPEAT + 2drop ; + +: evaluate ( c-addr u -- ) + 'source 2@ >r >r 'source 2! + >in @ >r 0 >in ! + \ ['] interpret catch + [ ' interpret ] Literal catch + r> >in ! + r> r> 'source 2! + throw +; + +' evaluate has-header evaluate + +: refill ( -- f ) + 'source cell+ @ tib = IF + query 0 >in ! + + \ Nick: detect EOT (only works at the start of a line) + #tib @ IF tib c@ 4 = IF 0 #tib ! 0 exit THEN THEN + + -1 exit + THEN + 0 ; + +' refill has-header refill + +\ after loading the *.seed runtime we will need to load further runtime as +\ textual forth source before being useable, so we will default to echo off +Variable echo 0 echo ! +' echo has-header echo + +' input-echo has-header input-echo + +\ ANSI terminal colors + +: esc ( -- ) 27 emit ; ' esc has-header esc +: bold ( -- ) esc ." [1m" ; +: normal ( -- ) esc ." [0m" ; ' normal has-header normal +: reverse ( -- ) esc ." [7m" ; ' reverse has-header reverse +\ : black ( -- ) esc ." [30m" ; +: red ( -- ) esc ." [31m" ; +: green ( -- ) esc ." [32m" ; +\ : yellow ( -- ) esc ." [33m" ; +: blue ( -- ) esc ." [34m" ; +\ : bright-blue ( -- ) esc ." [94m" ; +: reset-colors ( -- ) esc ." [39;49m" ; +: cyan ( -- ) esc ." [96m" ; +: page ( -- ) esc ." [2J" esc ." [H" ; + +' blue has-header blue +' page has-header page + +: compiling? ( -- f ) + handlers @ compilers @ = ; + +' compiling? has-header compiling? + +Defer .status : noop ; ' noop is .status + +' noop has-header noop + +' .status has-header .status + +\ interactive part +: prompt ( -- ) + echo @ IF + cr cyan bold .s normal reset-colors compiling? IF ']' ELSE '>' THEN emit space + THEN ; + +: .ok ( -- ) + echo @ IF space bold green ." ok 🙂" normal reset-colors THEN ; \ 🆗 + +: ?stack ( -- ) + depth 0< -4 and throw ; + +: restart ( -- ) + tib 0 'source 2! + ([) + BEGIN + .status prompt + query 0 >in ! + + \ Nick: detect EOT (only works at the start of a line) + #tib @ IF tib c@ 4 = IF bye THEN THEN + + interpret ?stack .ok + 0 UNTIL ; + +: warm ( -- ) + \ [ ' [ compile, ] + empty-stack restart ; + +Create errormsg 0 , 0 , + +' errormsg has-header errormsg + +: .error# ( n -- ) + dup -1 = IF drop ." abort" exit THEN + dup -2 = IF drop ." error: " + errormsg 2@ type 0 0 errormsg 2! exit THEN + dup -4 = IF drop ." stack underflow" exit THEN + dup -13 = IF drop ." not found" exit THEN + dup -16 = IF drop ." attempt to use zero-length string as a name" exit THEN + dup -39 = IF drop ." unexpected end of file" exit THEN + ." error " . ; + +: .error ( n -- ) + red bold .error# normal reset-colors ." 🤔 " ; + +: boot ( -- ) + BEGIN + [ ' warm ] Literal catch ?dup IF .error cr THEN + AGAIN ; + +' boot has-header boot + +\ at this point append either: +\ seedForthInteractive.seedsource (boot system for interactive use) +\ seedForthBoot.seedsource (boot system for running textual forth program)