From df227c795a94b62c6788ee8c09630e8e8d065f75 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Fri, 22 Apr 2022 13:40:34 +1000 Subject: [PATCH 01/25] Add .gitignore, rationalize make clean, remove a gforth warning in tokenizer --- .gitignore | 9 +++++++++ preForth/Makefile | 2 +- preForth/seedForth-tokenizer.fs | 6 +++--- 3 files changed, 13 insertions(+), 4 deletions(-) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..7e0a06e --- /dev/null +++ b/.gitignore @@ -0,0 +1,9 @@ +*.Darwin +*.Linux +*.asm +*.o +*.seed +/preForth/preForthdemo +/preForth/preForth +/preForth/forth +/preForth/seedForth diff --git a/preForth/Makefile b/preForth/Makefile index e50cd04..7c72bad 100644 --- a/preForth/Makefile +++ b/preForth/Makefile @@ -101,4 +101,4 @@ seedForth: seedForth.$(UNIXFLAVOUR) .PHONY=clean clean: - rm -f *.asm *.o *.fas *.s *.c *.Darwin *.Linux preForthdemo preForth forth seedForth seedForthDemo.seed seedForthInteractive.seed + rm -f *.Darwin *.Linux *.asm *.o *.seed preForthdemo preForth seedForth diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs index 3cbd559..cc6160b 100644 --- a/preForth/seedForth-tokenizer.fs +++ b/preForth/seedForth-tokenizer.fs @@ -97,7 +97,7 @@ Variable #tokens 0 #tokens ! : process-digit? ( x c -- x' flag ) '0' - dup 10 u< IF swap 10 * + true EXIT THEN drop false ; -: number? ( c-addr u -- x flag ) +: 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 @@ -109,7 +109,7 @@ Variable #tokens 0 #tokens ! : 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 + 2dup process-number? IF nip nip seed num seed-number seed exit EXIT THEN drop cr type ." not found" abort ; : seed-line ( -- ) @@ -277,4 +277,4 @@ end-macro Macro restore-#tokens postpone #tokens postpone ! -end-macro \ No newline at end of file +end-macro From 56c4dcff3bfd1f6bc7f3bcb196bea9dc701cd53c Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Fri, 22 Apr 2022 14:32:33 +1000 Subject: [PATCH 02/25] Remove .$(UNIXFLAVOUR) extension and file copies in favour of ifeq (GNU make) --- .gitignore | 2 -- preForth/Makefile | 27 +++++++++++---------------- 2 files changed, 11 insertions(+), 18 deletions(-) diff --git a/.gitignore b/.gitignore index 7e0a06e..666eb1c 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,3 @@ -*.Darwin -*.Linux *.asm *.o *.seed diff --git a/preForth/Makefile b/preForth/Makefile index 7c72bad..95ec272 100644 --- a/preForth/Makefile +++ b/preForth/Makefile @@ -29,21 +29,16 @@ 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 +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 -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 $< $@ - +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 \ @@ -51,19 +46,22 @@ preForth: preForth.$(UNIXFLAVOUR) $@.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 # 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\ +bootstrap: preForth-i386-rts.pre preForth-rts.pre preForth-i386-backend.pre preForth.pre preForth preForth.$(EXT) + cat preForth-i386-rts.pre preForth-rts.pre preForth-i386-backend.pre preForth.pre \ | ./preForth >preForth1.$(EXT) cmp preForth.$(EXT) preForth1.$(EXT) @@ -92,13 +90,10 @@ rundocker: docker-image 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 $< .PHONY=clean clean: - rm -f *.Darwin *.Linux *.asm *.o *.seed preForthdemo preForth seedForth + rm -f *.asm *.o *.seed preForthdemo preForth seedForth From a2e4911bbed68bf9979fd2bb4ad308ae01bbff50 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Fri, 22 Apr 2022 13:47:16 +1000 Subject: [PATCH 03/25] Remove redundant stuff in the preForth-generated asm code --- preForth/preForth-i386-backend.pre | 21 +++++++++++---------- preForth/preForth-i386-rts.pre | 2 -- preForth/preForth.pre | 4 ++-- preForth/seedForth-i386.pre | 2 -- 4 files changed, 13 insertions(+), 16 deletions(-) diff --git a/preForth/preForth-i386-backend.pre b/preForth/preForth-i386-backend.pre index f218fbb..663bff5 100644 --- a/preForth/preForth-i386-backend.pre +++ b/preForth/preForth-i386-backend.pre @@ -150,17 +150,18 @@ body ,_lit '>' 'r' 2 ,>word ; -: ."done" ( -- ) - ';' emit space 'd' emit 'o' emit 'n' emit 'e' emit ; - -: ."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..2d276fb 100644 --- a/preForth/preForth-i386-rts.pre +++ b/preForth/preForth-i386-rts.pre @@ -53,8 +53,6 @@ _nest: lea ebp, [ebp-4] lea esi, [eax+4] next -_O = 0 - ; code bye ( -- ) diff --git a/preForth/preForth.pre b/preForth/preForth.pre index ee9f710..741d2dc 100644 --- a/preForth/preForth.pre +++ b/preForth/preForth.pre @@ -130,7 +130,7 @@ : code ( -- ) token _dup ,comment - 0 header + \ 0 header ,code line _drop pre ,end-code ; \ Colon definitions - the preForth compiler @@ -262,7 +262,7 @@ : :' ( -- ) token _dup ,comment - 0 header + \ 0 header (: ; \ ----------- diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index 7f603df..be4cc19 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -104,8 +104,6 @@ _dovar: ; ( -- addr ) push eax next -_O = 0 - ; From cb3ba98a04fd976e84e89f98672fedb503072b64 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Fri, 22 Apr 2022 14:27:56 +1000 Subject: [PATCH 04/25] Use tabs in preForth-i386-rts.pre and seedForth-i386.pre, improve consistency --- preForth/preForth-i386-rts.pre | 201 +++++++------- preForth/seedForth-i386.pre | 481 ++++++++++++++++----------------- 2 files changed, 335 insertions(+), 347 deletions(-) diff --git a/preForth/preForth-i386-rts.pre b/preForth/preForth-i386-rts.pre index 2d276fb..4d92b2c 100644 --- a/preForth/preForth-i386-rts.pre +++ b/preForth/preForth-i386-rts.pre @@ -7,167 +7,158 @@ \ 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 +format ELF + +section '.bss' executable writeable -section '.bss' writeable executable + DD 10000 dup(0) +stck: DD 16 dup(0) - DD 10000 dup (0) -stck: DD 16 dup(0) - - DD 10000 dup(0) -rstck: DD 16 dup(0) + DD 10000 dup(0) +rstck: DD 16 dup(0) section '.text' executable writeable -public main +public main extrn putchar extrn getchar extrn fflush extrn exit - + macro next { - lodsd - jmp dword [eax] + lodsd + jmp dword [eax] } +main: cld + mov esp,dword stck + mov ebp,dword rstck + mov esi,main1 + next -main: cld - mov esp, dword stck - mov ebp, dword rstck - mov esi, main1 - next - -main1: DD _cold - DD _bye - - -_nest: lea ebp, [ebp-4] - mov [ebp], esi - lea esi, [eax+4] - next +main1: DD _cold + DD _bye +_nest: lea ebp,[ebp-4] + mov [ebp],esi + lea esi,[eax+4] + next ; code bye ( -- ) - push ebp - mov ebp, esp - and esp, 0xfffffff0 - mov eax, 0 - mov [esp], eax - call exit + push ebp + mov ebp,esp + and esp,0xfffffff0 + mov eax,0 + mov [esp],eax + call exit ; - + code emit ( c -- ) - pop eax + pop eax - push ebp - mov ebp, esp - push eax - and esp, 0xfffffff0 + push ebp + mov ebp,esp + push eax + and esp,0xfffffff0 - mov dword [esp], eax - call putchar + mov dword [esp],eax + call putchar - mov eax, 0 - mov [esp], eax - call fflush ; flush all output streams + mov eax,0 + mov [esp],eax + call fflush ; flush all output streams - mov esp, ebp - pop ebp - next + 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 + + call getchar + mov esp,ebp + pop ebp + cmp eax,-1 + jnz key1 + mov eax,4 ; eof: return Ctrl-D +key1: 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 ; diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index be4cc19..199f623 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -7,8 +7,8 @@ \ EBP return stack pointer \ ESP data stack pointer -prelude -;;; This is seedForth - a small, potentially interactive Forth, that dynamically +pre +;;; This is seedForth - a small,potentially interactive Forth, that dynamically ;;; bootstraps from a minimal kernel. ;;; ;;; cat seedForth.seed - | ./seedForth @@ -16,28 +16,26 @@ prelude ;;; .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 +format ELF + +section '.bss' executable writeable -section '.bss' executable writable + DD 10000 dup(0) +stck: DD 16 dup(0) - DD 10000 dup(0) -stck: DD 16 dup(0) + DD 10000 dup(0) +rstck: DD 16 dup(0) - DD 10000 dup(0) -rstck: DD 16 dup(0) - -_dp: DD _start ; dictionary pointer: points to next free location in memory +_dp: DD _start ; dictionary pointer: points to next free location in memory ; free memory starts at _start -__hp: DD 0 ; head pointer: index of first unused head -_head: DD 10000 dup (0) +__hp: DD 0 ; head pointer: index of first unused head +_head: DD 10000 dup (0) -section '.text' executable writable align 4096 +section '.text' executable writeable align 4096 -public main +public main extrn putchar extrn getchar extrn fflush @@ -45,336 +43,334 @@ extrn exit extrn mprotect extrn ioctl extrn usleep - + macro next { - lodsd - jmp dword [eax] + 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 +main: cld + mov esp,dword stck + mov ebp,dword rstck + + ; make section writeable + 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: lea ebp,[ebp-4] + mov [ebp],esi + lea esi,[eax+4] + next _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 - + lea eax,[eax+4] ; to parameter field + push eax + next ; - code bye ( -- ) - push ebp - mov ebp, esp - and esp, 0xfffffff0 - mov eax, 0 - mov [esp], eax - call exit -; - + push ebp + mov ebp,esp + and esp,0xfffffff0 + mov eax,0 + mov [esp],eax + call exit +; + code emit ( c -- ) - pop eax + pop eax - push ebp - mov ebp, esp - push eax - and esp, 0xfffffff0 + push ebp + mov ebp,esp + push eax + and esp,0xfffffff0 - mov dword [esp], eax - call putchar + mov dword [esp],eax + call putchar - mov eax, 0 - mov [esp], eax - call fflush ; flush all output streams + mov eax,0 + mov [esp],eax + call fflush ; flush all output streams - mov esp, ebp - pop ebp - next + 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 + 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 ; code key? ( -- f ) - push ebp - mov ebp, esp - and esp, 0xfffffff0 - sub esp, 32 + 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 + 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] + call ioctl + mov dword eax,[esp+24] - mov esp, ebp - pop ebp + mov esp,ebp + pop ebp - cmp eax, 0 - jz keyq1 - mov eax, -1 -keyq1: push eax - next + cmp eax,0 + jz keyq1 + mov eax,-1 +keyq1: 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 - sar eax,31 - push eax - next + 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 + 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 or ( x1 x2 -- x3 ) - pop edx - pop eax - or eax, edx - push eax - next +code or ( x1 x2 -- x3 ) + 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 +code and ( x1 x2 -- x3 ) + pop edx + pop eax + and eax,edx + push eax + next ; -pre +pre _unnest: ; code exit ( -- ) - 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 ; 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,stck + 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 - push ebp - mov ebp, esp - push eax - and esp, 0xfffffff0 + push ebp + mov ebp,esp + push eax + and esp,0xfffffff0 - mov dword [esp], eax - call usleep + mov dword [esp],eax + call usleep - mov esp, ebp - pop ebp - next + mov esp,ebp + pop ebp + next ; @@ -426,7 +422,7 @@ code usleep ( c -- ) : compile, ( x -- ) h@ , ; -\ token are in the range 0 .. 767: +\ 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 @@ -438,16 +434,16 @@ code usleep ( c -- ) : interpreter ( -- ) token execute tail interpreter ; \ executing exit will leave this loop -: num ( -- x ) +: num ( -- x ) tail interpreter ; -: ?lit ( xt -- xt | ) +: ?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 + token ?dup 0= ?exit ?lit compile, tail compiler ; : new ( -- xt ) @@ -470,7 +466,7 @@ code usleep ( c -- ) r> swap h@ dup >r 1 cells - ! lit dodoes r> ! ; -: unused ( -- u ) +: unused ( -- u ) lit memtop here - ; : cold ( -- ) @@ -537,7 +533,8 @@ code usleep ( c -- ) interpreter bye ; pre - _start: DB 43 - DD 100000 dup (0) - _memtop: DD 0 +_start: DB 43 + DD 100000 dup (0) +_memtop: + DD 0 ; From fa4f0c26cfd143f54637eda86e6d421892f1317d Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sat, 23 Apr 2022 01:16:09 +1000 Subject: [PATCH 05/25] Rationalize how cr is emitted in generated preForth code, make DB/DD lowercase --- preForth/preForth-i386-backend.pre | 52 +++++++++++------------------- preForth/preForth-i386-rts.pre | 14 ++++---- preForth/preForth.pre | 4 +-- preForth/seedForth-i386.pre | 24 +++++++------- 4 files changed, 40 insertions(+), 54 deletions(-) diff --git a/preForth/preForth-i386-backend.pre b/preForth/preForth-i386-backend.pre index 663bff5..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,11 +134,11 @@ \ ,tail compiles a tail call : ,tail ( S -- ) body ,_lit - '>' 'r' 2 ,>word ; + '>' 'r' 2 ,word ; \ : ."done" ( -- ) \ ';' emit space 'd' emit 'o' emit 'n' emit 'e' emit ; -\ +\ \ : ."last:" ( -- ) \ ';' emit space 'l' emit 'a' emit 's' emit 't' emit ':' emit space ; diff --git a/preForth/preForth-i386-rts.pre b/preForth/preForth-i386-rts.pre index 4d92b2c..fc5a7a4 100644 --- a/preForth/preForth-i386-rts.pre +++ b/preForth/preForth-i386-rts.pre @@ -15,14 +15,14 @@ format ELF section '.bss' executable writeable - DD 10000 dup(0) -stck: DD 16 dup(0) - - DD 10000 dup(0) -rstck: DD 16 dup(0) + dd 10000 dup(0) +stck: dd 16 dup(0) + dd 10000 dup(0) +rstck: dd 16 dup(0) section '.text' executable writeable + public main extrn putchar extrn getchar @@ -40,8 +40,8 @@ main: cld mov esi,main1 next -main1: DD _cold - DD _bye +main1: dd _cold + dd _bye _nest: lea ebp,[ebp-4] mov [ebp],esi diff --git a/preForth/preForth.pre b/preForth/preForth.pre index 741d2dc..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 @@ -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 \ ------------- diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index 199f623..778ca7b 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -21,17 +21,17 @@ format ELF section '.bss' executable writeable - DD 10000 dup(0) -stck: DD 16 dup(0) + dd 10000 dup(0) +stck: dd 16 dup(0) - DD 10000 dup(0) -rstck: DD 16 dup(0) + dd 10000 dup(0) +rstck: dd 16 dup(0) -_dp: DD _start ; dictionary pointer: points to next free location in memory +_dp: dd _start ; dictionary pointer: points to next free location in memory ; free memory starts at _start -__hp: DD 0 ; head pointer: index of first unused head -_head: DD 10000 dup (0) +__hp: dd 0 ; head pointer: index of first unused head +_head: dd 10000 dup (0) section '.text' executable writeable align 4096 @@ -84,8 +84,8 @@ main: cld main0: mov esi,main1 next -main1: DD _cold - DD _bye +main1: dd _cold + dd _bye _nest: _enter: lea ebp,[ebp-4] @@ -533,8 +533,8 @@ code usleep ( c -- ) interpreter bye ; pre -_start: DB 43 - DD 100000 dup (0) +_start: db 43 + dd 100000 dup (0) _memtop: - DD 0 + dd 0 ; From 927ca5ae133c5c4b41cbfb9541e386c650f29140 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sat, 23 Apr 2022 02:08:40 +1000 Subject: [PATCH 06/25] Rationalize the sections in assembly output, make code be compiled into bss rather than text section which avoids the need to call mprotect(), rename things --- preForth/preForth-i386-rts.pre | 32 +++++++++----- preForth/seedForth-i386.pre | 77 ++++++++++++---------------------- 2 files changed, 47 insertions(+), 62 deletions(-) diff --git a/preForth/preForth-i386-rts.pre b/preForth/preForth-i386-rts.pre index fc5a7a4..9adda37 100644 --- a/preForth/preForth-i386-rts.pre +++ b/preForth/preForth-i386-rts.pre @@ -11,17 +11,12 @@ pre ;;; This is a preForth generated file using preForth-i386-backend. ;;; Only modify it, if you know what you are doing. -format ELF - -section '.bss' executable writeable - - dd 10000 dup(0) -stck: dd 16 dup(0) +DATA_STACK_SIZE = 40000 +RETURN_STACK_SIZE = 40000 - dd 10000 dup(0) -rstck: dd 16 dup(0) +format ELF -section '.text' executable writeable +section '.text' executable public main extrn putchar @@ -35,8 +30,8 @@ macro next { } main: cld - mov esp,dword stck - mov ebp,dword rstck + mov esp,data_stack + DATA_STACK_SIZE + mov ebp,return_stack + RETURN_STACK_SIZE mov esi,main1 next @@ -162,3 +157,18 @@ code lit ( -- ) 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 '.bss' writeable + +data_stack: + db DATA_STACK_SIZE dup (0) +return_stack: + db RETURN_STACK_SIZE dup (0) + +section '.text' executable +; diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index 778ca7b..008b0e6 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -17,30 +17,20 @@ pre ;;; ;;; Use the seedForth tokenizer to convert human readable source code to byte-token form. -format ELF - -section '.bss' executable writeable - - dd 10000 dup(0) -stck: dd 16 dup(0) +DATA_STACK_SIZE = 40000 +RETURN_STACK_SIZE = 40000 +HEAD_SIZE = 40000 +MEM_SIZE = 400000 - dd 10000 dup(0) -rstck: dd 16 dup(0) - -_dp: dd _start ; dictionary pointer: points to next free location in memory - ; free memory starts at _start - -__hp: dd 0 ; head pointer: index of first unused head -_head: dd 10000 dup (0) +format ELF -section '.text' executable writeable align 4096 +section '.text' executable public main extrn putchar extrn getchar extrn fflush extrn exit -extrn mprotect extrn ioctl extrn usleep @@ -52,36 +42,9 @@ macro next { origin: main: cld - mov esp,dword stck - mov ebp,dword rstck - - ; make section writeable - 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 + mov esp,data_stack + DATA_STACK_SIZE + mov ebp,return_stack + RETURN_STACK_SIZE + mov esi,main1 next main1: dd _cold @@ -311,7 +274,7 @@ code ?branch ( f -- ) \ threaded code: ?exit r> @ >r ; ; code depth ( -- n ) - mov eax,stck + mov eax,data_stack + DATA_STACK_SIZE sub eax,esp sar eax,2 push eax @@ -373,7 +336,6 @@ code usleep ( c -- ) next ; - : negate ( n1 -- n2 ) 0 swap - ; @@ -533,8 +495,21 @@ code usleep ( c -- ) interpreter bye ; pre -_start: db 43 - dd 100000 dup (0) +section '.bss' writeable + +data_stack: + db DATA_STACK_SIZE dup (0) +return_stack: + db RETURN_STACK_SIZE dup (0) + + ; dictionary pointer: points to next free location in memory +_dp: dd _mem + + ; head pointer: index of first unused head +__hp: dd 0 +_head: dd HEAD_SIZE dup (0) + + ; free memory starts at _mem +_mem: db MEM_SIZE dup (0) _memtop: - dd 0 ; From 77b48fed936116a1ec537c547eeea06ade473fa6 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sat, 23 Apr 2022 02:36:05 +1000 Subject: [PATCH 07/25] Split seedForth-i386.pre into machine dependent/less machine dependent portions --- preForth/Makefile | 60 ++++++++----- preForth/seed | 6 +- preForth/seedForth-i386.pre | 166 ++---------------------------------- preForth/seedForth.pre | 159 ++++++++++++++++++++++++++++++++++ 4 files changed, 209 insertions(+), 182 deletions(-) create mode 100644 preForth/seedForth.pre diff --git a/preForth/Makefile b/preForth/Makefile index 95ec272..a07d51c 100644 --- a/preForth/Makefile +++ b/preForth/Makefile @@ -16,7 +16,7 @@ test: runseedforthdemo runseedforthinteractive .PHONY=runseedforthdemo runseedforthdemo: seedForth seedForthDemo.seed - cat seedForthDemo.seed | ./seedForth + cat seedForthDemo.seed |./seedForth .PHONY=runseedfortinteractive runseedforthinteractive: seedForth seedForthInteractive.seed @@ -25,26 +25,31 @@ 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-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 preForth-i386-rts.pre preForth-rts.pre - cat preForth-i386-rts.pre preForth-rts.pre $< | ./preForth >$@ +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 + cat preForth-i386-rts.pre preForth-rts.pre $< |./preForth >$@ ifeq ($(UNIXFLAVOUR),Linux) # assemble and link executable on linux %: %.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) @@ -53,22 +58,33 @@ ifeq ($(UNIXFLAVOUR),Darwin) 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-i386-rts.pre preForth-rts.pre preForth-i386-backend.pre preForth.pre preForth 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) + cat \ +preForth-i386-rts.pre \ +preForth-rts.pre \ +preForth-i386-backend.pre \ +preForth.pre \ +|./preForth >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 + cat preForth-i386-backend.pre preForth.pre |./preForth # ------------------------------------------------------------------------ # Docker support (for Linux version) @@ -87,8 +103,8 @@ rundocker: docker-image # ------------------------------------------------------------------------ # seedForth # ------------------------------------------------------------------------ -seedForth.$(EXT): seedForth-i386.pre preForth - cat seedForth-i386.pre | ./preForth >seedForth.$(EXT) +seedForth.$(EXT): seedForth-i386.pre seedForth.pre preForth + cat seedForth-i386.pre seedForth.pre |./preForth >seedForth.$(EXT) %.seed: %.seedsource seedForth-tokenizer.fs gforth seedForth-tokenizer.fs $< diff --git a/preForth/seed b/preForth/seed index 52ff983..35f5ac0 100755 --- a/preForth/seed +++ b/preForth/seed @@ -1,6 +1,8 @@ #!/bin/bash +# note: we need to fix the below so it exits cleanly +# when seedForth quits, the "cat" doesn't realize until user types something + stty raw -echo -cat seedForthInteractive.seed hi.forth - | ./seedForth +cat seedForthInteractive.seed hi.forth - |./seedForth stty sane - diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index 008b0e6..1c59965 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -1,3 +1,5 @@ +\ seedForth: machine dependent portion + \ seedForth - seed it, feed it, grow it - i386 (32 bit) ITC flavour uho 2018-04-13 \ ---------------------------------------------------------------------------------- \ @@ -336,164 +338,10 @@ code usleep ( c -- ) next ; -: negate ( n1 -- n2 ) - 0 swap - ; - -: + ( x1 x2 -- x3 ) - negate - ; - -: 0= ( x -- flag ) - 0 swap ?exit drop -1 ; - -: ?dup ( x -- x x | 0 ) - dup 0= ?exit dup ; - -: 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 ; - -: 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 - 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 ; - +\ 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 '.bss' writeable @@ -512,4 +360,6 @@ _head: dd HEAD_SIZE dup (0) ; free memory starts at _mem _mem: db MEM_SIZE dup (0) _memtop: + +section '.text' executable ; diff --git a/preForth/seedForth.pre b/preForth/seedForth.pre new file mode 100644 index 0000000..4ca1fbe --- /dev/null +++ b/preForth/seedForth.pre @@ -0,0 +1,159 @@ +\ 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 .. 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 ; + +: 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 + 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 ; From f843d0837c0f67f7491a4702e2b6ec8ad86b176b Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sat, 23 Apr 2022 02:44:02 +1000 Subject: [PATCH 08/25] Split seedforth-i386.pre further into header and body portions --- preForth/Makefile | 4 ++-- preForth/seedForth-i386-header.pre | 22 ++++++++++++++++++++++ preForth/seedForth-i386.pre | 11 ----------- 3 files changed, 24 insertions(+), 13 deletions(-) create mode 100644 preForth/seedForth-i386-header.pre diff --git a/preForth/Makefile b/preForth/Makefile index a07d51c..47532b6 100644 --- a/preForth/Makefile +++ b/preForth/Makefile @@ -103,8 +103,8 @@ rundocker: docker-image # ------------------------------------------------------------------------ # seedForth # ------------------------------------------------------------------------ -seedForth.$(EXT): seedForth-i386.pre seedForth.pre preForth - cat seedForth-i386.pre seedForth.pre |./preForth >seedForth.$(EXT) +seedForth.$(EXT): seedForth-i386-header.pre seedForth-i386.pre seedForth.pre preForth + cat seedForth-i386-header.pre seedForth-i386.pre seedForth.pre |./preForth >seedForth.$(EXT) %.seed: %.seedsource seedForth-tokenizer.fs gforth seedForth-tokenizer.fs $< diff --git a/preForth/seedForth-i386-header.pre b/preForth/seedForth-i386-header.pre new file mode 100644 index 0000000..a7022ec --- /dev/null +++ b/preForth/seedForth-i386-header.pre @@ -0,0 +1,22 @@ +\ 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 + +; diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index 1c59965..9aa56c6 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -10,19 +10,8 @@ \ ESP data stack pointer 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. - DATA_STACK_SIZE = 40000 RETURN_STACK_SIZE = 40000 -HEAD_SIZE = 40000 -MEM_SIZE = 400000 format ELF From cdd868665dc06148e0d0c0b149bab6ac8b05770f Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sat, 23 Apr 2022 02:55:09 +1000 Subject: [PATCH 09/25] Remove duplicated code in seedForth-i386.pre, take from preForth-i386-rts.pre --- preForth/Makefile | 15 ++- preForth/preForth-i386-rts.pre | 1 + preForth/seedForth-i386.pre | 169 ++------------------------------- 3 files changed, 20 insertions(+), 165 deletions(-) diff --git a/preForth/Makefile b/preForth/Makefile index 47532b6..945cac0 100644 --- a/preForth/Makefile +++ b/preForth/Makefile @@ -103,13 +103,22 @@ rundocker: docker-image # ------------------------------------------------------------------------ # seedForth # ------------------------------------------------------------------------ -seedForth.$(EXT): seedForth-i386-header.pre seedForth-i386.pre seedForth.pre preForth - cat seedForth-i386-header.pre seedForth-i386.pre seedForth.pre |./preForth >seedForth.$(EXT) +seedForth.$(EXT): \ +seedForth-i386-header.pre \ +preForth-i386-rts.pre \ +seedForth-i386.pre \ +seedForth.pre \ +preForth + cat \ +seedForth-i386-header.pre \ +preForth-i386-rts.pre \ +seedForth-i386.pre \ +seedForth.pre \ +|./preForth >seedForth.$(EXT) %.seed: %.seedsource seedForth-tokenizer.fs gforth seedForth-tokenizer.fs $< - .PHONY=clean clean: rm -f *.asm *.o *.seed preForthdemo preForth seedForth diff --git a/preForth/preForth-i386-rts.pre b/preForth/preForth-i386-rts.pre index 9adda37..f54a123 100644 --- a/preForth/preForth-i386-rts.pre +++ b/preForth/preForth-i386-rts.pre @@ -171,4 +171,5 @@ return_stack: db RETURN_STACK_SIZE dup (0) section '.text' executable + ; diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index 9aa56c6..03a6b37 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -1,51 +1,13 @@ \ seedForth: machine dependent portion -\ 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 +\ interpreter and basic asm primitives are taken from preForth-i386-rts.pre, +\ and then this file defines additional primitives (arithmetic, memory, etc) pre -DATA_STACK_SIZE = 40000 -RETURN_STACK_SIZE = 40000 - -format ELF - -section '.text' executable - -public main -extrn putchar -extrn getchar -extrn fflush -extrn exit extrn ioctl extrn usleep -macro next { - lodsd - jmp dword [eax] -} - -origin: - -main: cld - mov esp,data_stack + DATA_STACK_SIZE - mov ebp,return_stack + RETURN_STACK_SIZE - 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 @@ -57,50 +19,6 @@ _dovar: ; ( -- addr ) next ; -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 -; - code key? ( -- f ) push ebp mov ebp,esp @@ -125,65 +43,7 @@ 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 -; - -code or ( x1 x2 -- x3 ) +code or ( x1 x2 -- x3 ) pop edx pop eax or eax,edx @@ -191,7 +51,7 @@ code or ( x1 x2 -- x3 ) next ; -code and ( x1 x2 -- x3 ) +code and ( x1 x2 -- x3 ) pop edx pop eax and eax,edx @@ -200,18 +60,7 @@ code and ( x1 x2 -- x3 ) ; pre -_unnest: -; -code exit ( -- ) - mov esi,[ebp] - lea ebp,[ebp+4] - next -; - -code lit ( -- ) - lodsd - push eax - next +_exit = _unnest ; code @ ( addr -- x ) @@ -334,11 +183,6 @@ code usleep ( c -- ) pre section '.bss' writeable -data_stack: - db DATA_STACK_SIZE dup (0) -return_stack: - db RETURN_STACK_SIZE dup (0) - ; dictionary pointer: points to next free location in memory _dp: dd _mem @@ -351,4 +195,5 @@ _mem: db MEM_SIZE dup (0) _memtop: section '.text' executable + ; From c962f42d37fa171868fed4f7fee6a48e48755822 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sat, 23 Apr 2022 15:08:37 +1000 Subject: [PATCH 10/25] Implement built-in "cat" functionality in preForth/seedForth for reading input --- preForth/Makefile | 14 +- preForth/preForth-i386-rts.pre | 233 ++++++++++++++++++++++++++--- preForth/seed | 6 +- preForth/seedForth-i386-header.pre | 2 + preForth/seedForth-i386.pre | 25 ++-- 5 files changed, 236 insertions(+), 44 deletions(-) diff --git a/preForth/Makefile b/preForth/Makefile index 945cac0..d669794 100644 --- a/preForth/Makefile +++ b/preForth/Makefile @@ -16,7 +16,7 @@ test: runseedforthdemo runseedforthinteractive .PHONY=runseedforthdemo runseedforthdemo: seedForth seedForthDemo.seed - cat seedForthDemo.seed |./seedForth + ./seedForth seedForthDemo.seed .PHONY=runseedfortinteractive runseedforthinteractive: seedForth seedForthInteractive.seed @@ -39,7 +39,7 @@ preForth.pre \ |$(HOSTFORTH) load-i386-preForth.fs >preForth.asm %.asm: %.pre preForth-i386-rts.pre preForth-rts.pre preForth - cat 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 @@ -73,18 +73,18 @@ preForth-i386-backend.pre \ preForth.pre \ preForth \ preForth.$(EXT) - cat \ + ./preForth \ preForth-i386-rts.pre \ preForth-rts.pre \ preForth-i386-backend.pre \ preForth.pre \ -|./preForth >preForth1.$(EXT) +>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) @@ -109,12 +109,12 @@ preForth-i386-rts.pre \ seedForth-i386.pre \ seedForth.pre \ preForth - cat \ + ./preForth \ seedForth-i386-header.pre \ preForth-i386-rts.pre \ seedForth-i386.pre \ seedForth.pre \ -|./preForth >seedForth.$(EXT) +>seedForth.$(EXT) %.seed: %.seedsource seedForth-tokenizer.fs gforth seedForth-tokenizer.fs $< diff --git a/preForth/preForth-i386-rts.pre b/preForth/preForth-i386-rts.pre index f54a123..14756be 100644 --- a/preForth/preForth-i386-rts.pre +++ b/preForth/preForth-i386-rts.pre @@ -14,15 +14,28 @@ pre DATA_STACK_SIZE = 40000 RETURN_STACK_SIZE = 40000 +O_RDONLY = 0 +STDIN_FILENO = 0 +STDOUT_FILENO = 1 +STDERR_FILENO = 2 + +EXIT_SUCCESS = 0 +EXIT_FAILURE = 1 + +EOT_CHAR = 4 + format ELF section '.text' executable public main -extrn putchar -extrn getchar -extrn fflush +extrn close extrn exit +extrn open +extrn read +extrn strcmp +extrn strlen +extrn write macro next { lodsd @@ -30,11 +43,95 @@ macro next { } 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 + + mov esp,ebp + pop ebp + pop esi + ret + +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 @@ -42,32 +139,44 @@ _nest: lea ebp,[ebp-4] mov [ebp],esi lea esi,[eax+4] next + ; code bye ( -- ) - push ebp - mov ebp,esp and esp,0xfffffff0 - mov eax,0 - mov [esp],eax - call exit + 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 - push eax and esp,0xfffffff0 + sub esp,16 - mov dword [esp],eax - call putchar + mov [esp+12],al ; char ch_out = character to emit - mov eax,0 - mov [esp],eax - call fflush ; flush all output streams + 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 @@ -77,14 +186,59 @@ code key ( -- c ) 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 - call getchar mov esp,ebp pop ebp - cmp eax,-1 - jnz key1 - mov eax,4 ; eof: return Ctrl-D -key1: push eax + + push eax next ; @@ -163,7 +317,44 @@ code lit ( -- ) \ 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 '.bss' writeable +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) diff --git a/preForth/seed b/preForth/seed index 35f5ac0..c0ba74d 100755 --- a/preForth/seed +++ b/preForth/seed @@ -1,8 +1,4 @@ #!/bin/bash - -# note: we need to fix the below so it exits cleanly -# when seedForth quits, the "cat" doesn't realize until user types something - stty raw -echo -cat seedForthInteractive.seed hi.forth - |./seedForth +./seedForth seedForthInteractive.seed hi.forth - stty sane diff --git a/preForth/seedForth-i386-header.pre b/preForth/seedForth-i386-header.pre index a7022ec..d0d87ea 100644 --- a/preForth/seedForth-i386-header.pre +++ b/preForth/seedForth-i386-header.pre @@ -19,4 +19,6 @@ pre HEAD_SIZE = 40000 MEM_SIZE = 400000 +IOCTL_FIONREAD = 0x4004667f + ; diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index 03a6b37..c56727d 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -23,20 +23,23 @@ code key? ( -- f ) push ebp mov ebp,esp and esp,0xfffffff0 - sub esp,32 + sub esp,16 - mov dword [esp],0 - mov dword [esp+4],1074030207 ; FIONREAD - lea dword eax,[esp+24] - mov dword [esp+8],eax + mov dword [esp+12],0 ; int count = 0 - call ioctl - mov dword eax,[esp+24] + mov dword [esp],STDIN_FILENO + mov dword [esp+4],IOCTL_FIONREAD + lea eax,[esp+12] + mov [esp+8],eax + call ioctl ; eax = ioctl(STDIN_FILENO, IOCTL_FIONREAD, &count) + ; ignore error, count initialized to 0 so it will show not ready + + mov eax,[esp+12] ; eax = count mov esp,ebp pop ebp - cmp eax,0 + test eax,eax jz keyq1 mov eax,-1 keyq1: push eax @@ -161,14 +164,14 @@ code um/mod ( ud u1 -- u2 u3 ) ; code usleep ( c -- ) - pop eax + pop eax ; eax = microseconds to sleep push ebp mov ebp,esp - push eax and esp,0xfffffff0 + sub esp,16 - mov dword [esp],eax + mov [esp],eax call usleep mov esp,ebp From ebf5bfaddc26530cc4027cfee59d56877bcfba4e Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sat, 23 Apr 2022 15:52:36 +1000 Subject: [PATCH 11/25] Make key? use fdin instead of always STDIN_FILENO, and use poll() not ioctl() --- preForth/seedForth-i386-header.pre | 2 +- preForth/seedForth-i386.pre | 56 ++++++++++++++++++++++-------- 2 files changed, 42 insertions(+), 16 deletions(-) diff --git a/preForth/seedForth-i386-header.pre b/preForth/seedForth-i386-header.pre index d0d87ea..bddc8e3 100644 --- a/preForth/seedForth-i386-header.pre +++ b/preForth/seedForth-i386-header.pre @@ -19,6 +19,6 @@ pre HEAD_SIZE = 40000 MEM_SIZE = 400000 -IOCTL_FIONREAD = 0x4004667f +POLLIN = 1 ; diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index c56727d..5666857 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -4,7 +4,7 @@ \ and then this file defines additional primitives (arithmetic, memory, etc) pre -extrn ioctl +extrn poll extrn usleep _enter = _nest @@ -23,26 +23,46 @@ code key? ( -- f ) push ebp mov ebp,esp and esp,0xfffffff0 - sub esp,16 + sub esp,32 - mov dword [esp+12],0 ; int count = 0 + ; if all arguments exhausted, return ready + ; this allows application to collect the EOT character + mov eax,[argn] + cmp eax,[argc] + jae keyq_ready - mov dword [esp],STDIN_FILENO - mov dword [esp+4],IOCTL_FIONREAD - lea eax,[esp+12] - mov [esp+8],eax - call ioctl ; eax = ioctl(STDIN_FILENO, IOCTL_FIONREAD, &count) - ; ignore error, count initialized to 0 so it will show not ready + mov eax,[fd_in] + mov dword [esp+12],eax + mov dword [esp+16],POLLIN ; struct pollfd fd = {fd_in, POLLIN, 0} - mov eax,[esp+12] ; eax = count + 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 - test eax,eax - jz keyq1 - mov eax,-1 -keyq1: push eax + push eax next ; @@ -184,7 +204,13 @@ code usleep ( c -- ) \ 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 '.bss' writeable +section '.data' writeable align 16 + +message_cant_poll: + db 'can''t poll',0xa +message_cant_poll_end: + +section '.bss' writeable align 16 ; dictionary pointer: points to next free location in memory _dp: dd _mem From d48d34ad02fc315a915b91c5b3fe5c2296befc5a Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sun, 24 Apr 2022 00:09:42 +1000 Subject: [PATCH 12/25] Rationalize seedForth-tokenize.fs so that seedsource no longer has to be wrapped with PROGRAM / END, also removes automatic bye token that was generated by END --- .gitignore | 3 +- preForth/Makefile | 11 ++++++-- preForth/seedForth-tokenizer | 9 ++++++ preForth/seedForth-tokenizer.fs | 36 ++++++++++++++---------- preForth/seedForthDemo.seedsource | 7 +---- preForth/seedForthInteractive.seedsource | 5 +--- 6 files changed, 41 insertions(+), 30 deletions(-) create mode 100755 preForth/seedForth-tokenizer diff --git a/.gitignore b/.gitignore index 666eb1c..748240b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,6 @@ *.asm *.o *.seed -/preForth/preForthdemo /preForth/preForth -/preForth/forth /preForth/seedForth +/preForth/__temp__.fs diff --git a/preForth/Makefile b/preForth/Makefile index d669794..67441f7 100644 --- a/preForth/Makefile +++ b/preForth/Makefile @@ -116,9 +116,14 @@ seedForth-i386.pre \ seedForth.pre \ >seedForth.$(EXT) -%.seed: %.seedsource seedForth-tokenizer.fs - gforth seedForth-tokenizer.fs $< +# 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 +%.seed: seedForth-tokenizer.fs %.seedsource + cat $^ >__temp__.fs + gforth __temp__.fs -e bye >$@ + rm __temp__.fs .PHONY=clean clean: - rm -f *.asm *.o *.seed preForthdemo preForth seedForth + rm -f *.asm *.o *.seed preForthdemo preForth seedForth __temp__.fs diff --git a/preForth/seedForth-tokenizer b/preForth/seedForth-tokenizer new file mode 100755 index 0000000..3650380 --- /dev/null +++ b/preForth/seedForth-tokenizer @@ -0,0 +1,9 @@ +#!/bin/sh + +# 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 + +cat seedForth-tokenizer.fs - >__temp__.fs +gforth __temp__.fs -e bye +rm __temp__.fs diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs index cc6160b..3ba9f3c 100644 --- a/preForth/seedForth-tokenizer.fs +++ b/preForth/seedForth-tokenizer.fs @@ -33,22 +33,24 @@ Create tokens #hashsize cells allot tokens #hashsize cells 0 fill cr source type cr r> @ name-see abort THEN nip nip ; -VARIABLE OUTFILE +\ VARIABLE OUTFILE -: submit ( c -- ) - PAD C! PAD 1 OUTFILE @ WRITE-FILE THROW ; - -: submit-token ( x -- ) - dup 255 > IF dup 8 rshift SUBMIT THEN SUBMIT ; +\ : 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 255 > IF dup 8 rshift emit THEN emit ; : ( -- c-addr u ) bl word count ; Variable #tokens 0 #tokens ! : Token ( -- ) :noname - #tokens @ postpone LITERAL postpone SUBMIT-TOKEN postpone ; + #tokens @ postpone LITERAL postpone emit-token postpone ; \ SUBMIT-TOKEN postpone ; - cr #tokens @ 3 .r space 2dup type \ tell user about used tokens + \ cr #tokens @ 3 .r space 2dup type \ tell user about used tokens ?token ! 1 #tokens +! ; : Macro ( -- ) @@ -81,7 +83,7 @@ Variable #tokens 0 #tokens ! \ 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 @@ -118,12 +120,12 @@ Variable #tokens 0 #tokens ! : seed-file ( -- ) BEGIN refill WHILE seed-line REPEAT ; -: PROGRAM ( -- ) - R/W CREATE-FILE THROW OUTFILE ! - seed-file ; +\ : PROGRAM ( -- ) +\ R/W CREATE-FILE THROW OUTFILE ! +\ seed-file ; -Macro END ( -- ) - .S CR 0 SUBMIT OUTFILE @ CLOSE-FILE THROW BYE end-macro +\ Macro END ( -- ) +\ .S CR 0 SUBMIT OUTFILE @ CLOSE-FILE THROW BYE end-macro Macro [ ( -- ) seed bye end-macro \ bye Macro ] ( -- ) seed compiler end-macro \ compiler @@ -251,7 +253,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 @@ -278,3 +280,7 @@ Macro restore-#tokens postpone #tokens postpone ! end-macro + +seed-file +\ user code has to be concatenated here +\ it cannot be in a separate file when running via gforth diff --git a/preForth/seedForthDemo.seedsource b/preForth/seedForthDemo.seedsource index 4e2ddad..9521033 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,3 @@ 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 - - diff --git a/preForth/seedForthInteractive.seedsource b/preForth/seedForthInteractive.seedsource index 089137f..b77fe6d 100644 --- a/preForth/seedForthInteractive.seedsource +++ b/preForth/seedForthInteractive.seedsource @@ -9,8 +9,6 @@ \ cat seedForthInteractive.seed | ./seedForth \ -PROGRAM seedForthInteractive.seed - \ Defining words Definer Create ( -- ) create ( x ) drop ; Definer Variable ( -- ) create ( x ) drop 0 , ; @@ -1180,7 +1178,7 @@ Create errormsg 0 , 0 , : boot ( -- ) - key drop \ skip 0 of boot program + \ key drop \ skip 0 of boot program .banner BEGIN [ ' warm ] Literal catch ?dup IF .error cr THEN @@ -1206,4 +1204,3 @@ t{ -> }t \ 0 input-echo ! reveal boot -END From 375ab0fca12c303a425327c06c7dc9e700ff9002 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sun, 24 Apr 2022 00:55:37 +1000 Subject: [PATCH 13/25] Move most code from seedForthInteractive.seedsource into seedForthRuntime.seedsource, so that we can run textual forth code without the tests or the banner --- preForth/Makefile | 25 +- preForth/seedForthBoot.seedsource | 3 + preForth/seedForthDemo.seedsource | 1 + preForth/seedForthInteractive.seedsource | 1082 +--------------------- preForth/seedForthRuntime.seedsource | 1068 +++++++++++++++++++++ 5 files changed, 1101 insertions(+), 1078 deletions(-) create mode 100644 preForth/seedForthBoot.seedsource create mode 100644 preForth/seedForthRuntime.seedsource diff --git a/preForth/Makefile b/preForth/Makefile index 67441f7..71579c2 100644 --- a/preForth/Makefile +++ b/preForth/Makefile @@ -9,7 +9,12 @@ 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 @@ -119,7 +124,23 @@ seedForth.pre \ # 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 -%.seed: seedForth-tokenizer.fs %.seedsource +seedForthDemo.seed: seedForth-tokenizer.fs seedForthDemo.seedsource + cat $^ >__temp__.fs + gforth __temp__.fs -e bye >$@ + rm __temp__.fs + +seedForthBoot.seed: \ +seedForth-tokenizer.fs \ +seedForthRuntime.seedsource \ +seedForthBoot.seedsource + cat $^ >__temp__.fs + gforth __temp__.fs -e bye >$@ + rm __temp__.fs + +seedForthInteractive.seed: \ +seedForth-tokenizer.fs \ +seedForthRuntime.seedsource \ +seedForthInteractive.seedsource cat $^ >__temp__.fs gforth __temp__.fs -e bye >$@ rm __temp__.fs 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 9521033..2efb7d6 100644 --- a/preForth/seedForthDemo.seedsource +++ b/preForth/seedForthDemo.seedsource @@ -399,3 +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 +bye diff --git a/preForth/seedForthInteractive.seedsource b/preForth/seedForthInteractive.seedsource index b77fe6d..328ef81 100644 --- a/preForth/seedForthInteractive.seedsource +++ b/preForth/seedForthInteractive.seedsource @@ -1,239 +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) -\ 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 @@ -298,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 @@ -316,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 @@ -377,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 ) @@ -1159,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, @@ -1203,4 +132,5 @@ t{ -> }t 0 echo ! \ 0 input-echo ! reveal +.banner boot diff --git a/preForth/seedForthRuntime.seedsource b/preForth/seedForthRuntime.seedsource new file mode 100644 index 0000000..c054cb5 --- /dev/null +++ b/preForth/seedForthRuntime.seedsource @@ -0,0 +1,1068 @@ +\ 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 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 + +\ 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 ! 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) From 8da6c87ca89590ba8607496942bc0b7534f3af7e Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sun, 24 Apr 2022 01:17:50 +1000 Subject: [PATCH 14/25] Rationalize how echo is handled during the seedForthInteractive loading phases --- preForth/hi.forth | 3 --- preForth/seedForthInteractive.seedsource | 2 -- preForth/seedForthRuntime.seedsource | 10 ++++++---- 3 files changed, 6 insertions(+), 9 deletions(-) diff --git a/preForth/hi.forth b/preForth/hi.forth index 4cd1091..a0fb056 100644 --- a/preForth/hi.forth +++ b/preForth/hi.forth @@ -1,6 +1,3 @@ -0 echo ! -0 input-echo ! - cr .( ⓪ ) : ( diff --git a/preForth/seedForthInteractive.seedsource b/preForth/seedForthInteractive.seedsource index 328ef81..935ed18 100644 --- a/preForth/seedForthInteractive.seedsource +++ b/preForth/seedForthInteractive.seedsource @@ -129,8 +129,6 @@ cr t{ -> }t -0 echo ! -\ 0 input-echo ! reveal .banner boot diff --git a/preForth/seedForthRuntime.seedsource b/preForth/seedForthRuntime.seedsource index c054cb5..4423b0b 100644 --- a/preForth/seedForthRuntime.seedsource +++ b/preForth/seedForthRuntime.seedsource @@ -386,7 +386,9 @@ Constant #tib Defer getkey ' key is getkey -Variable input-echo -1 input-echo ! +\ 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 @@ -979,8 +981,9 @@ Variable handlers interpreters @ handlers ! ' refill has-header refill - -Variable echo -1 echo ! +\ 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 @@ -1055,7 +1058,6 @@ Create errormsg 0 , 0 , : .error ( n -- ) red bold .error# normal reset-colors ." 🤔 " ; - : boot ( -- ) BEGIN [ ' warm ] Literal catch ?dup IF .error cr THEN From 62bcae1596dcf2589a21eb8033d3040de09cfe94 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sun, 24 Apr 2022 01:35:35 +1000 Subject: [PATCH 15/25] Split out control flow words and a few others from hi.forth into runtime.forth --- preForth/hi.forth | 156 ----------------------------------------- preForth/runtime.forth | 152 +++++++++++++++++++++++++++++++++++++++ preForth/seed | 2 +- 3 files changed, 153 insertions(+), 157 deletions(-) create mode 100644 preForth/runtime.forth diff --git a/preForth/hi.forth b/preForth/hi.forth index a0fb056..6515c6c 100644 --- a/preForth/hi.forth +++ b/preForth/hi.forth @@ -1,12 +1,5 @@ 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!) @@ -28,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 ; @@ -164,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 @@ -183,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 @@ -251,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 * ; @@ -277,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 @@ -395,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 ; @@ -449,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 @@ -807,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, ) @@ -843,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/runtime.forth b/preForth/runtime.forth new file mode 100644 index 0000000..9d685de --- /dev/null +++ b/preForth/runtime.forth @@ -0,0 +1,152 @@ +: ( + ')' 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/ ( u1 u2 -- u3 ) >r 0 r> um/mod nip ; + +: 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 -- ) + 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 diff --git a/preForth/seed b/preForth/seed index c0ba74d..4deb5df 100755 --- a/preForth/seed +++ b/preForth/seed @@ -1,4 +1,4 @@ #!/bin/bash stty raw -echo -./seedForth seedForthInteractive.seed hi.forth - +./seedForth seedForthInteractive.seed runtime.forth hi.forth - stty sane From 78426fc09a9d4d3d0612414e134a209b9231b4ce Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sun, 24 Apr 2022 02:35:38 +1000 Subject: [PATCH 16/25] Make ./seedForth-tokenizer self hosting (works, but hangs after tokenizing) --- preForth/runtime.forth | 14 +++++-- preForth/seedForth-tokenizer | 9 +--- preForth/seedForth-tokenizer.fs | 63 +++++++++++++++------------- preForth/seedForthRuntime.seedsource | 4 +- 4 files changed, 46 insertions(+), 44 deletions(-) diff --git a/preForth/runtime.forth b/preForth/runtime.forth index 9d685de..e6571e2 100644 --- a/preForth/runtime.forth +++ b/preForth/runtime.forth @@ -146,7 +146,13 @@ false invert Constant true : I ( -- ) postpone r@ ; immediate -\ : ?DO ( to from -- ) -\ postpone 2dup -\ postpone - -\ postpone IF postpone DO ; immediate +: ?DO ( to from -- ) + postpone 2dup + postpone - + postpone IF postpone DO ; immediate + +\ Nick +: UNLOOP ( -- ) + postpone r> + postpone r> + postpone 2drop ; immediate diff --git a/preForth/seedForth-tokenizer b/preForth/seedForth-tokenizer index 3650380..75d6736 100755 --- a/preForth/seedForth-tokenizer +++ b/preForth/seedForth-tokenizer @@ -1,9 +1,2 @@ #!/bin/sh - -# 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 - -cat seedForth-tokenizer.fs - >__temp__.fs -gforth __temp__.fs -e bye -rm __temp__.fs +./seedForth seedForthBoot.seed runtime.forth seedForth-tokenizer.fs - diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs index 3ba9f3c..d3a6d8d 100644 --- a/preForth/seedForth-tokenizer.fs +++ b/preForth/seedForth-tokenizer.fs @@ -1,8 +1,13 @@ \ Another seedForth tokenizer 2019-10-18 +\ seedForth does not support hex so put some useful constants in decimal +255 Constant xFF +65261 Constant xFEED +4294967295 Constant xFFFFFFFF + : 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> ; + BEGIN dup WHILE over c@ r> xor 16777619 um* drop xFFFFFFFF and >r 1 /string REPEAT 2drop r> ; 15 Constant #hashbits 1 #hashbits lshift Constant #hashsize @@ -30,7 +35,7 @@ Create tokens #hashsize cells allot tokens #hashsize cells 0 fill 2dup 'token dup @ IF >r cr type ." collides with another token " - cr source type cr r> @ name-see abort + cr source type cr r> @ abort \ ??? name-see abort THEN nip nip ; \ VARIABLE OUTFILE @@ -41,27 +46,25 @@ Create tokens #hashsize cells allot tokens #hashsize cells 0 fill \ : submit-token ( x -- ) \ dup 255 > IF dup 8 rshift SUBMIT THEN SUBMIT ; : emit-token ( x -- ) - dup 255 > IF dup 8 rshift emit THEN emit ; - -: ( -- c-addr u ) bl word count ; + dup xFF > IF dup 8 rshift emit THEN emit ; Variable #tokens 0 #tokens ! : Token ( -- ) :noname - #tokens @ postpone LITERAL postpone emit-token postpone ; \ SUBMIT-TOKEN postpone ; - + #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 @@ -87,41 +90,41 @@ Variable #tokens 0 #tokens ! : 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 ; : process-number? ( c-addr u -- x flag ) - dup 0= IF 2drop 0 false EXIT THEN - over c@ '-' = dup >r IF 1 /string THEN + 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 process-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 ! +\ parse-name R/W CREATE-FILE THROW OUTFILE ! \ seed-file ; \ Macro END ( -- ) @@ -152,7 +155,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 @@ -162,15 +165,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 @@ -178,8 +181,8 @@ end-macro : forward ( -- ) seed [ seed here - 0 seed-number seed , - seed ] + 0 seed-number seed , + seed ] ; : back ( -- ) @@ -190,11 +193,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 diff --git a/preForth/seedForthRuntime.seedsource b/preForth/seedForthRuntime.seedsource index 4423b0b..4d9df10 100644 --- a/preForth/seedForthRuntime.seedsource +++ b/preForth/seedForthRuntime.seedsource @@ -379,7 +379,7 @@ init \ for the input stream a struct could be defined that generally handles terminal input, evaluate, file input and others. -Create tib 80 allot +Create tib 255 allot Create 'source here 0 , tib , \ ' source is normally ^tib #tib is set to c-addr u for evaluate Constant #tib @@ -406,7 +406,7 @@ Variable input-echo 0 input-echo ! ; : query ( -- ) - tib 80 accept #tib ! ; + tib 255 accept #tib ! ; From cbfdac88d7777dd6c565ef10fead578847f7d1ca Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sun, 24 Apr 2022 14:39:12 +1000 Subject: [PATCH 17/25] Remap tokens so that EOT is no longer a seedForth token, detect EOT everywhere --- preForth/seedForth-tokenizer.fs | 8 +++--- preForth/seedForth.pre | 37 ++++++++++++++++++++-------- preForth/seedForthRuntime.seedsource | 17 +++++++++++-- 3 files changed, 47 insertions(+), 15 deletions(-) diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs index d3a6d8d..fb157fd 100644 --- a/preForth/seedForth-tokenizer.fs +++ b/preForth/seedForth-tokenizer.fs @@ -67,8 +67,9 @@ Variable #tokens 0 #tokens ! 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 +5 #tokens ! +( 4 $04 ) 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 @@ -81,7 +82,8 @@ 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 emit +( 60 $3C ) Token key \ generate token sequences for numbers diff --git a/preForth/seedForth.pre b/preForth/seedForth.pre index 4ca1fbe..e5b1669 100644 --- a/preForth/seedForth.pre +++ b/preForth/seedForth.pre @@ -48,14 +48,15 @@ : 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 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 3 - 0< 0= ?exit \ not 1 2 -> single byte token - key couple ; \ double byte token + 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 @@ -68,8 +69,22 @@ lit lit , num , \ generate lit x num call puts x on stack r> drop tail compiler ; +\ Nick: detect EOT and treat as an immediate bye token +\ note: Nick has moved tokens key/emit so that EOT is no longer a token, +\ but EOT can still occur in numbers and will not terminate compilation +: ?eot + dup 4 - ?exit \ not EOT token: exit i.e. normal compile action + 'X' emit + bye ; \ EOT token: assume program has run, automatic bye + : compiler ( -- ) - token ?dup 0= ?exit ?lit + token + + \ Nick: old way of detecting bye token directly prevented compiling it + \ ?dup 0= ?exit + ?eot + + ?lit compile, tail compiler ; : new ( -- xt ) @@ -100,8 +115,8 @@ 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 + 0 h, \ 3 03 prefix + lit bye h, \ 4 04 EOT (this entry accessed in interpretive mode) lit dup h, \ 5 05 code lit swap h, \ 6 06 code lit drop h, \ 7 07 code @@ -156,4 +171,6 @@ lit token h, \ 56 38 lit usleep h, \ 57 39 code lit hp h, \ 58 40 + lit emit h, \ 59 41 code + lit key h, \ 60 42 code interpreter bye ; diff --git a/preForth/seedForthRuntime.seedsource b/preForth/seedForthRuntime.seedsource index 4d9df10..c36d724 100644 --- a/preForth/seedForthRuntime.seedsource +++ b/preForth/seedForthRuntime.seedsource @@ -976,7 +976,14 @@ Variable handlers interpreters @ handlers ! ' evaluate has-header evaluate : refill ( -- f ) - 'source cell+ @ tib = IF query 0 >in ! -1 exit THEN + '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 exit THEN THEN + + -1 exit + THEN 0 ; ' refill has-header refill @@ -1034,7 +1041,13 @@ Defer .status : noop ; ' noop is .status tib 0 'source 2! ([) BEGIN - .status prompt query 0 >in ! interpret ?stack .ok + .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 ( -- ) From caac682455ce3be4b0c6d5c51d10282eeff24acb Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sun, 24 Apr 2022 18:51:36 +1000 Subject: [PATCH 18/25] Implement eot token similar to the old bye token (so we can compile bye token) --- preForth/seedForth-tokenizer.fs | 17 ++++++++++++++--- preForth/seedForth.pre | 15 +++++++-------- 2 files changed, 21 insertions(+), 11 deletions(-) diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs index fb157fd..7fd4014 100644 --- a/preForth/seedForth-tokenizer.fs +++ b/preForth/seedForth-tokenizer.fs @@ -68,8 +68,8 @@ Variable #tokens 0 #tokens ! ( 0 $00 ) Token bye -5 #tokens ! -( 4 $04 ) Token dup Token swap Token drop +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 @@ -132,7 +132,17 @@ Variable #tokens 0 #tokens ! \ Macro END ( -- ) \ .S CR 0 SUBMIT OUTFILE @ CLOSE-FILE THROW BYE end-macro -Macro [ ( -- ) seed bye end-macro \ bye +\ 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 @@ -289,3 +299,4 @@ 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 index e5b1669..c134a6c 100644 --- a/preForth/seedForth.pre +++ b/preForth/seedForth.pre @@ -69,13 +69,12 @@ lit lit , num , \ generate lit x num call puts x on stack r> drop tail compiler ; -\ Nick: detect EOT and treat as an immediate bye token -\ note: Nick has moved tokens key/emit so that EOT is no longer a token, -\ but EOT can still occur in numbers and will not terminate compilation -: ?eot - dup 4 - ?exit \ not EOT token: exit i.e. normal compile action - 'X' emit - bye ; \ EOT token: assume program has run, automatic bye +: 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 @@ -116,7 +115,7 @@ 0 h, \ 1 01 prefix 0 h, \ 2 02 prefix 0 h, \ 3 03 prefix - lit bye h, \ 4 04 EOT (this entry accessed in interpretive mode) + lit eot h, \ 4 04 code lit dup h, \ 5 05 code lit swap h, \ 6 06 code lit drop h, \ 7 07 code From 75138c34c8d18d25c18442833db837fc002e2bad Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sun, 24 Apr 2022 19:58:33 +1000 Subject: [PATCH 19/25] Implement a new preForth/seedForth token eemit which is like emit but writes to stderr, fix self-hosted tokenizer termination issue (was debugged with eemit) --- preForth/preForth-i386-rts.pre | 32 +++++++ preForth/seedForth-tokenizer.fs | 4 +- preForth/seedForth.pre | 5 +- preForth/seedForthRuntime.seedsource | 126 +++++++++++++++------------ 4 files changed, 106 insertions(+), 61 deletions(-) diff --git a/preForth/preForth-i386-rts.pre b/preForth/preForth-i386-rts.pre index 14756be..9fed2a9 100644 --- a/preForth/preForth-i386-rts.pre +++ b/preForth/preForth-i386-rts.pre @@ -182,6 +182,38 @@ emit_ok: next ; +code eemit ( c -- ) + 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],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 diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs index 7fd4014..8a4db0a 100644 --- a/preForth/seedForth-tokenizer.fs +++ b/preForth/seedForth-tokenizer.fs @@ -82,8 +82,8 @@ 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 Token emit -( 60 $3C ) Token key +( 56 $38 ) Token token Token usleep Token hp Token key +( 60 $3C ) Token emit Token eemit \ generate token sequences for numbers diff --git a/preForth/seedForth.pre b/preForth/seedForth.pre index c134a6c..dd5aaee 100644 --- a/preForth/seedForth.pre +++ b/preForth/seedForth.pre @@ -170,6 +170,7 @@ lit token h, \ 56 38 lit usleep h, \ 57 39 code lit hp h, \ 58 40 - lit emit h, \ 59 41 code - lit key h, \ 60 42 code + lit key h, \ 59 41 code + lit emit h, \ 60 42 code + lit eemit h, \ 61 43 code interpreter bye ; diff --git a/preForth/seedForthRuntime.seedsource b/preForth/seedForthRuntime.seedsource index c36d724..3706722 100644 --- a/preForth/seedForthRuntime.seedsource +++ b/preForth/seedForthRuntime.seedsource @@ -395,10 +395,21 @@ Variable input-echo 0 input-echo ! 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 + 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 @@ -547,58 +558,56 @@ Macro has-header ( -- ) 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 +' 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 @@ -606,6 +615,9 @@ end-macro \ ' 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 @@ -980,7 +992,7 @@ Variable handlers interpreters @ handlers ! query 0 >in ! \ Nick: detect EOT (only works at the start of a line) - #tib @ IF tib c@ 4 = IF 0 exit THEN THEN + #tib @ IF tib c@ 4 = IF 0 #tib ! 0 exit THEN THEN -1 exit THEN From 7115f49f36ff26d2c7e1138006a8342e81fe7b3e Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sun, 24 Apr 2022 23:53:43 +1000 Subject: [PATCH 20/25] Implement DO/?DO/LOOP, as experimental ?DO didn't have a correct companion LOOP --- preForth/runtime.forth | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/preForth/runtime.forth b/preForth/runtime.forth index e6571e2..8c9af88 100644 --- a/preForth/runtime.forth +++ b/preForth/runtime.forth @@ -78,7 +78,11 @@ false invert Constant true : * ( n1 n2 -- ) 2dup xor 0< >r abs swap abs um* drop r> IF negate THEN ; -: u/ ( u1 u2 -- u3 ) >r 0 r> um/mod nip ; +: 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 @@ -132,6 +136,15 @@ false invert Constant true 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 @@ -141,16 +154,13 @@ false invert Constant true postpone 1+ postpone r> postpone 2dup postpone = postpone UNTIL - postpone 2drop ; immediate + postpone 2drop + \ this backpatches IF block for ?DO or does nothing for DO + ?dup IF postpone THEN THEN ; immediate : I ( -- ) postpone r@ ; immediate -: ?DO ( to from -- ) - postpone 2dup - postpone - - postpone IF postpone DO ; immediate - \ Nick : UNLOOP ( -- ) postpone r> From 03f58726561fae82d1c9e7627d9dc39690968b5f Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sun, 24 Apr 2022 23:55:27 +1000 Subject: [PATCH 21/25] Add CRC10/ATM (bit reversed) table generator and evaluator --- .gitignore | 1 + preForth/Makefile | 7 ++++- preForth/crc10_gen.forth | 50 ++++++++++++++++++++++++++++++++++++ preForth/seedForth-tokenizer | 2 +- 4 files changed, 58 insertions(+), 2 deletions(-) create mode 100644 preForth/crc10_gen.forth diff --git a/.gitignore b/.gitignore index 748240b..e1a4c55 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ *.asm *.o *.seed +/preForth/crc10.forth /preForth/preForth /preForth/seedForth /preForth/__temp__.fs diff --git a/preForth/Makefile b/preForth/Makefile index 71579c2..6cff6b4 100644 --- a/preForth/Makefile +++ b/preForth/Makefile @@ -124,12 +124,13 @@ seedForth.pre \ # 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: seedForth-tokenizer.fs seedForthDemo.seedsource +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 @@ -138,6 +139,7 @@ seedForthBoot.seedsource rm __temp__.fs seedForthInteractive.seed: \ +crc10.forth \ seedForth-tokenizer.fs \ seedForthRuntime.seedsource \ seedForthInteractive.seedsource @@ -145,6 +147,9 @@ seedForthInteractive.seedsource gforth __temp__.fs -e bye >$@ rm __temp__.fs +crc10.forth: crc10_gen.forth + gforth $^ -e bye >$@ + .PHONY=clean clean: 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/seedForth-tokenizer b/preForth/seedForth-tokenizer index 75d6736..420ff59 100755 --- a/preForth/seedForth-tokenizer +++ b/preForth/seedForth-tokenizer @@ -1,2 +1,2 @@ #!/bin/sh -./seedForth seedForthBoot.seed runtime.forth seedForth-tokenizer.fs - +./seedForth seedForthBoot.seed runtime.forth crc10.forth seedForth-tokenizer.fs - From 913f5ddd2377fe80ce6062d68457a25c0f789feb Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Mon, 25 Apr 2022 02:01:36 +1000 Subject: [PATCH 22/25] Modify tokenizer to use a 1024-entry symbol table with closed hashing by CRC10 --- preForth/seedForth-tokenizer.fs | 107 +++++++++++++++++++++++--------- 1 file changed, 77 insertions(+), 30 deletions(-) diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs index 8a4db0a..6ac5ed6 100644 --- a/preForth/seedForth-tokenizer.fs +++ b/preForth/seedForth-tokenizer.fs @@ -2,41 +2,88 @@ \ seedForth does not support hex so put some useful constants in decimal 255 Constant xFF +1023 Constant x3FF +1024 Constant x400 65261 Constant xFEED -4294967295 Constant xFFFFFFFF -: fnv1a ( c-addr u -- x ) - 2166136261 >r - BEGIN dup WHILE over c@ r> xor 16777619 um* drop xFFFFFFFF 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 +\ 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 -- addr ) - fnv1a fold cells tokens + ; +: token@ ( c-addr u -- x ) + \ get entry address and flag for found/empty + hash_table_find -: token@ ( c-addr u -- x ) 'token @ ; + \ if found, return value of _xt, otherwise 0 + IF _hash_table_xt + @ ELSE drop 0 THEN +; -: ?token ( c-addr u -- x ) - 2dup 'token dup @ - IF - >r cr type ." collides with another token " - cr source type cr r> @ abort \ ??? name-see abort - THEN nip nip ; +: ?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 + +; \ VARIABLE OUTFILE From 4e4fa66ac46e2fd468257faebf6ed50979699a28 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Mon, 25 Apr 2022 11:56:08 +1000 Subject: [PATCH 23/25] Move nonstandard words from preForth-rts.pre into preForth-rts-nonstandard.pre --- preForth/Makefile | 18 +++++++- preForth/load-i386-preForth.fs | 1 + preForth/preForth-rts-nonstandard.pre | 64 +++++++++++++++++++++++++++ preForth/preForth-rts.pre | 54 +--------------------- 4 files changed, 82 insertions(+), 55 deletions(-) create mode 100644 preForth/preForth-rts-nonstandard.pre diff --git a/preForth/Makefile b/preForth/Makefile index 6cff6b4..5bc3c18 100644 --- a/preForth/Makefile +++ b/preForth/Makefile @@ -32,19 +32,31 @@ EXT=asm preForth.asm: \ preForth-i386-rts.pre \ +preForth-rts-nonstandard.pre \ preForth-rts.pre \ preForth-i386-backend.pre \ preForth.pre \ load-i386-preForth.fs cat \ preForth-i386-rts.pre \ +preForth-rts-nonstandard.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 $< >$@ +%.asm: \ +%.pre \ +preForth-i386-rts.pre \ +preForth-rts-nonstandard.pre \ +preForth-rts.pre \ +preForth + ./preForth \ +preForth-i386-rts.pre \ +preForth-rts-nonstandard.pre \ +preForth-rts.pre \ +$< \ +>$@ ifeq ($(UNIXFLAVOUR),Linux) # assemble and link executable on linux @@ -73,6 +85,7 @@ endif # should produce identical results bootstrap: \ preForth-i386-rts.pre \ +preForth-rts-nonstandard.pre \ preForth-rts.pre \ preForth-i386-backend.pre \ preForth.pre \ @@ -80,6 +93,7 @@ preForth \ preForth.$(EXT) ./preForth \ preForth-i386-rts.pre \ +preForth-rts-nonstandard.pre \ preForth-rts.pre \ preForth-i386-backend.pre \ preForth.pre \ diff --git a/preForth/load-i386-preForth.fs b/preForth/load-i386-preForth.fs index 7da3f75..74924f3 100644 --- a/preForth/load-i386-preForth.fs +++ b/preForth/load-i386-preForth.fs @@ -2,6 +2,7 @@ include load-preForth.fs include preForth-i386-rts.pre +include preForth-rts-nonstandard.pre include preForth-rts.pre include preForth-i386-backend.pre include preForth.pre diff --git a/preForth/preForth-rts-nonstandard.pre b/preForth/preForth-rts-nonstandard.pre new file mode 100644 index 0000000..67a8ff0 --- /dev/null +++ b/preForth/preForth-rts-nonstandard.pre @@ -0,0 +1,64 @@ +\ preForth runtime system - machine independent part - nonstandard words + +\ since preForth is mostly a subset of standard Forth, preForth programs can +\ basically run under gForth or similar for bootstrapping, after including: +\ preForth-bootstrap.fs: adjust environment (not needed under pure preForth) +\ preForth-rts-nonstandard.fs: useful words (needed under/part of preForth) + +\ case? compares the value x to y. If they match, return true. If not keep x +\ and return false. +: case? ( x y -- tf | x ff ) + over = dup 0= ?exit 2drop -1 ; + +\ text output words +\ ----------------- + +: tab ( -- ) + 9 emit ; + + +\ number output +\ ------------- + +: 10* ( x1 -- x2 ) + dup + dup dup + dup + + ; + + +\ strings +\ ------- + +\ Strings are represented as character stack elements with a count on top +\ They can be processed conveniently using recursion. +\ Idioms: dup pick gets 1st character +\ dup gets length +\ x swap 1+ adds x to end of string +\ nip 1- removes last character +\ +\ Useful words +\ show displays trings +\ _dup duplicates topmost string +\ _drop removes topmost string +\ _swap exchanges two topmost strings + +\ show displays topmost string +: show ( S -- ) + ?dup 0= ?exit swap >r 1- show r> emit ; + +: (_dup ( S m n -- S S ) + ?dup 0= ?exit over 2 + pick rot rot 1- tail (_dup ; + +\ _dup duplicated topmost string +: _dup ( S -- S S ) + dup dup (_dup ; + +\ _drop removes topmost string +: _drop ( S -- ) + ?dup 0= ?exit nip 1- _drop ; + + +: (_swap ( S1 S2 x1 x2 -- S2 S1 x1 0 ) + dup 0= ?exit over 3 + roll rot rot 1- (_swap ; + +\ _swap exchanges two topmost strings +: _swap ( S1 S2 -- S2 S1 ) + dup >r pick r> dup >r over >r + r> r> rot rot 1+ (_swap 2drop ; diff --git a/preForth/preForth-rts.pre b/preForth/preForth-rts.pre index a66b851..490fe37 100644 --- a/preForth/preForth-rts.pre +++ b/preForth/preForth-rts.pre @@ -1,4 +1,4 @@ -\ preForth runtime system - machine independent part +\ preForth runtime system - machine independent part - standard words \ ------------------------------------ \ define lots of useful standard words @@ -31,10 +31,6 @@ : > ( n1 n2 -- flag ) swap < ; -\ case? compares the value x to y. If they match, return true. If not keep x and return false. -: case? ( x y -- tf | x ff ) - over = dup 0= ?exit 2drop -1 ; - \ additional stack operators \ -------------------------- @@ -67,9 +63,6 @@ : space ( -- ) bl emit ; -: tab ( -- ) - 9 emit ; - : cr ( -- ) 10 emit ; @@ -81,9 +74,6 @@ >r over over < r> swap ?exit >r swap over - swap r> 1+ (/mod ; -: 10* ( x1 -- x2 ) - dup + dup dup + dup + + ; - : (10u/mod ( n q d -- r q d ) 2 pick over > 0= ?exit \ ( n q d ) dup >r 10* \ ( n q 10*d ) ( R: d ) @@ -107,45 +97,3 @@ \ display signed number : . ( n -- ) (. u. ; - - -\ ----------- -\ strings -\ ----------- -\ Strings are represented as character stack elements with a count on top -\ They convieniently be processed using recursion. -\ Idioms: dup pick gets 1st character -\ dup gets length -\ x swap 1+ adds x to end of string -\ nip 1- removes last character -\ -\ Useful words -\ show displays trings -\ _dup duplicates topmost string -\ _drop removes topmost string -\ _swap exchanges two topmost strings - -\ show displays topmost string -: show ( S -- ) - ?dup 0= ?exit swap >r 1- show r> emit ; - - -: (_dup ( S m n -- S S ) - ?dup 0= ?exit over 2 + pick rot rot 1- tail (_dup ; - -\ _dup duplicated topmost string -: _dup ( S -- S S ) - dup dup (_dup ; - -\ _drop removes topmost string -: _drop ( S -- ) - ?dup 0= ?exit nip 1- _drop ; - - -: (_swap ( S1 S2 x1 x2 -- S2 S1 x1 0 ) - dup 0= ?exit over 3 + roll rot rot 1- (_swap ; - -\ _swap exchanges two topmost strings -: _swap ( S1 S2 -- S2 S1 ) - dup >r pick r> dup >r over >r + r> r> rot rot 1+ (_swap 2drop ; - From 4add97d48042d4a047c36cfcb9966132d65e5c1a Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Mon, 25 Apr 2022 12:20:13 +1000 Subject: [PATCH 24/25] Simplify bootstrapping by not creating a new wordlist and only defining the nonstandard words on top of gForth's standard words, produces redefinition warnings --- preForth/borrow.fs | 56 ---------------- preForth/load-i386-preForth.fs | 8 +-- preForth/load-preForth.fs | 115 --------------------------------- preForth/preForth-bootstrap.fs | 20 ++++++ 4 files changed, 24 insertions(+), 175 deletions(-) delete mode 100644 preForth/borrow.fs delete mode 100644 preForth/load-preForth.fs create mode 100644 preForth/preForth-bootstrap.fs diff --git a/preForth/borrow.fs b/preForth/borrow.fs deleted file mode 100644 index b0d84e2..0000000 --- a/preForth/borrow.fs +++ /dev/null @@ -1,56 +0,0 @@ -\ Minimal Forth Workbench: main file uh 2015-10-05 - -: tick ( name -- comp-xt exec-xt flag ) - STATE @ >R - ] >IN @ >R BL WORD FIND - IF R> >IN ! - POSTPONE [ BL WORD FIND - ELSE R> DROP - DROP 0 0 false - THEN - R> IF ] ELSE POSTPONE [ THEN ; - -: immediate-alias ( comp-xt exec-xt name -- ) - CREATE , , IMMEDIATE DOES> STATE @ IF CELL+ THEN @ EXECUTE ; - -: non-immediate-alias ( comp-xt exec-xt name -- ) - CREATE , , IMMEDIATE DOES> STATE @ IF CELL+ @ COMPILE, ELSE @ EXECUTE THEN ; - -VARIABLE #primitives 0 #primitives ! -VARIABLE #words 0 #words ! - -: another-primitive ( -- ) 1 #primitives +! 1 #words +! ; - -: borrow ( ccc -- ) - get-order - >IN @ >R tick R> >IN ! NIP NIP - 0= IF - forth-wordlist 1 set-order - another-primitive - >IN @ >R tick R> >IN ! DUP 0= Abort" ?" - 0< IF non-immediate-alias ELSE immediate-alias THEN - ELSE - CR BL WORD COUNT TYPE ." is already defined." - THEN - set-order ; - -: primitive ( ccc -- ) borrow ; - -\ : later ( ccc -- ) \ word ccc uses late binding -\ \ has danger of infinite recursion if no defintion exists -\ >IN @ >R CREATE R> >IN ! -\ HERE BL WORD COUNT >R -\ HERE CHAR+ R@ MOVE R@ CHAR+ ALLOT R> SWAP C! -\ DOES> COUNT EVALUATE ; - -: later ( ccc -- ) \ word ccc uses late binding - >IN @ >R CREATE R> >IN ! - HERE BL WORD COUNT >R - HERE CHAR+ R@ MOVE R@ CHAR+ ALLOT R> SWAP C! - DOES> DUP >R - FIND 0= ABORT" ?" - DUP >BODY R@ = IF R> COUNT TYPE ." is not yet defined." ABORT THEN - R> DROP EXECUTE ; - - - diff --git a/preForth/load-i386-preForth.fs b/preForth/load-i386-preForth.fs index 74924f3..e0168ce 100644 --- a/preForth/load-i386-preForth.fs +++ b/preForth/load-i386-preForth.fs @@ -1,12 +1,12 @@ \ load i386 preForth on top of a host Forth system +\ omit the standard words (either machine code or high level code) -include load-preForth.fs -include preForth-i386-rts.pre +include preForth-bootstrap.fs +\ include preForth-i386-rts.pre include preForth-rts-nonstandard.pre -include preForth-rts.pre +\ include preForth-rts.pre include preForth-i386-backend.pre include preForth.pre cold - bye diff --git a/preForth/load-preForth.fs b/preForth/load-preForth.fs deleted file mode 100644 index 13dd2c9..0000000 --- a/preForth/load-preForth.fs +++ /dev/null @@ -1,115 +0,0 @@ -\ Load preForth on GForth or SwiftForth connected to stdin and stdout. - - -defined warnings [IF] \ e.g. gforth - warnings off -[THEN] - -defined warning [IF] \ e.g. SwiftForth - warning off -[THEN] - -Variable ch - -\ key reads from stdin so it can be used with pipes and input redirection. -: key ( -- c ) - ch 1 stdin read-file throw - 1 < IF 4 ( eof ) ELSE ch c@ THEN - ; \ dup emit ; - -\ This : allows for recursion by using a word's name. -defined -smudge [IF] \ SwiftForth -: : : -smudge ; -[THEN] - -defined reveal [IF] \ gforth -: : : reveal ; -[THEN] - - -\ Define pre and code so they skip their body - -: pre ( -- ) - BEGIN refill WHILE - source s" ;" compare 0= IF POSTPONE \ EXIT THEN - REPEAT ; - -: prefix pre ; -: prelude pre ; -: preamble pre ; -: code pre ; - -: tail ; - -include borrow.fs - -wordlist Constant preForth - -preForth set-current - -: borrow borrow ; -: primitive borrow ; -: tail tail ; - -preForth 1 set-order - -borrow include -borrow : -borrow ; -borrow \ -borrow ( -borrow .s - -borrow pre -borrow prefix -borrow prelude -borrow preamble -borrow code - -borrow later -later ?dup -later 0= -later negate -later + -later 1+ -later 1- -later = -later < -later > -later case? - -later over -later rot -later nip -later 2drop -later pick -later roll - -later bl -later space -later tab -later cr -later u. -later . - -later show -later _dup -later _drop -later _swap - -primitive emit -primitive key -primitive dup -primitive swap -primitive 0< -primitive ?exit -primitive drop -primitive recurse -primitive >r -primitive r> -primitive - -\ nest -\ unnest -\ lit - -borrow bye diff --git a/preForth/preForth-bootstrap.fs b/preForth/preForth-bootstrap.fs new file mode 100644 index 0000000..129a24e --- /dev/null +++ b/preForth/preForth-bootstrap.fs @@ -0,0 +1,20 @@ +\ preForth runtime system - compatibility package for bootstrap + +\ since preForth is mostly a subset of standard Forth, preForth programs can +\ basically run under gForth or similar for bootstrapping, after including: +\ preForth-bootstrap.fs: adjust environment (not needed under pure preForth) +\ preForth-rts-nonstandard.fs: useful words (needed under/part of preForth) + +\ This : allows for recursion by using a word's name. +defined -smudge [IF] \ SwiftForth +: : : -smudge ; +[THEN] + +defined reveal [IF] \ gforth +: : : reveal ; +[THEN] + +\ ignore tail recursion optimization +\ the host system is assumed to have a large enough stack to handle the +\ steady growth of the stack as the compiler loops through the input file +: tail ( -- ) ; From 12b1f58512ffc38e4d1664d76b75b61e1decfcba Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Mon, 25 Apr 2022 12:40:35 +1000 Subject: [PATCH 25/25] Remove load-i386-preForth.fs, instead list the compiler sources on command line --- preForth/Makefile | 13 ++++++++++--- preForth/load-i386-preForth.fs | 12 ------------ preForth/preForth-cold.fs | 4 ++++ preForth/preForth.pre | 10 ++-------- 4 files changed, 16 insertions(+), 23 deletions(-) delete mode 100644 preForth/load-i386-preForth.fs create mode 100644 preForth/preForth-cold.fs diff --git a/preForth/Makefile b/preForth/Makefile index 5bc3c18..a76624b 100644 --- a/preForth/Makefile +++ b/preForth/Makefile @@ -31,19 +31,26 @@ UNIXFLAVOUR=$(shell uname -s) EXT=asm preForth.asm: \ +preForth-bootstrap.fs \ +preForth-cold.fs \ preForth-i386-rts.pre \ preForth-rts-nonstandard.pre \ preForth-rts.pre \ preForth-i386-backend.pre \ -preForth.pre \ -load-i386-preForth.fs +preForth.pre cat \ preForth-i386-rts.pre \ preForth-rts-nonstandard.pre \ preForth-rts.pre \ preForth-i386-backend.pre \ preForth.pre \ -|$(HOSTFORTH) load-i386-preForth.fs >preForth.asm +|$(HOSTFORTH) \ +preForth-bootstrap.fs \ +preForth-rts-nonstandard.pre \ +preForth-i386-backend.pre \ +preForth.pre \ +preForth-cold.fs \ +>$@ %.asm: \ %.pre \ diff --git a/preForth/load-i386-preForth.fs b/preForth/load-i386-preForth.fs deleted file mode 100644 index e0168ce..0000000 --- a/preForth/load-i386-preForth.fs +++ /dev/null @@ -1,12 +0,0 @@ -\ load i386 preForth on top of a host Forth system -\ omit the standard words (either machine code or high level code) - -include preForth-bootstrap.fs -\ include preForth-i386-rts.pre -include preForth-rts-nonstandard.pre -\ include preForth-rts.pre -include preForth-i386-backend.pre -include preForth.pre - -cold -bye diff --git a/preForth/preForth-cold.fs b/preForth/preForth-cold.fs new file mode 100644 index 0000000..c4d2343 --- /dev/null +++ b/preForth/preForth-cold.fs @@ -0,0 +1,4 @@ +\ include this after the bootstrap compiler, to launch reading of stdin + +quit \ quit is the top-level interpreter loop +bye diff --git a/preForth/preForth.pre b/preForth/preForth.pre index 751fb0d..6418cc8 100644 --- a/preForth/preForth.pre +++ b/preForth/preForth.pre @@ -316,13 +316,7 @@ \ cold initializes the dictionary link and starts the interpreter. Acknowledge end on exit. : cold ( -- ) - '0' 1 \ dictionary anchor - quit _drop \ eof + \ '0' 1 \ dictionary anchor + quit \ _drop \ eof \ top of dictionary as string on stack ,end ; - -\ : is eventually defined as preForth is now complete (assuming the primitives existed). -\ In order to bootstrap. They have to be defined. -: : ( -- ) - :' ; -