From df227c795a94b62c6788ee8c09630e8e8d065f75 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Fri, 22 Apr 2022 13:40:34 +1000 Subject: [PATCH 01/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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/41] 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. -: : ( -- ) - :' ; - From afd90821c3a64c54f0938d4668e4368aeed8b327 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 10:07:11 +1000 Subject: [PATCH 26/41] Separate /preForth directory into /common and /i386, add appropriate Makefiles --- .gitignore | 8 +- Makefile | 14 +++ {preForth => common}/.gitignore | 0 {preForth => common}/Dockerfile | 0 common/Makefile | 15 +++ {preForth => common}/crc10_gen.forth | 0 {preForth => common}/hi.forth | 0 {preForth => common}/preForth-bootstrap.fs | 0 {preForth => common}/preForth-cold.fs | 0 .../preForth-rts-nonstandard.pre | 0 {preForth => common}/preForth-rts.pre | 0 {preForth => common}/preForth.pre | 0 {preForth => common}/preForthDemo.pre | 0 {preForth => common}/runtime.forth | 0 {preForth => common}/seedForth-tokenizer.fs | 0 {preForth => common}/seedForth.pre | 0 {preForth => common}/seedForthBoot.seedsource | 0 {preForth => common}/seedForthDemo.seedsource | 0 .../seedForthInteractive.seedsource | 0 .../seedForthRuntime.seedsource | 0 {preForth => i386}/Makefile | 98 +++++++++---------- {preForth => i386}/preForth-i386-backend.pre | 0 {preForth => i386}/preForth-i386-rts.pre | 0 i386/seed | 4 + {preForth => i386}/seedForth-i386-header.pre | 0 {preForth => i386}/seedForth-i386.pre | 0 i386/seedForth-tokenizer | 2 + preForth/seed | 4 - preForth/seedForth-tokenizer | 2 - 29 files changed, 88 insertions(+), 59 deletions(-) create mode 100644 Makefile rename {preForth => common}/.gitignore (100%) rename {preForth => common}/Dockerfile (100%) create mode 100644 common/Makefile rename {preForth => common}/crc10_gen.forth (100%) rename {preForth => common}/hi.forth (100%) rename {preForth => common}/preForth-bootstrap.fs (100%) rename {preForth => common}/preForth-cold.fs (100%) rename {preForth => common}/preForth-rts-nonstandard.pre (100%) rename {preForth => common}/preForth-rts.pre (100%) rename {preForth => common}/preForth.pre (100%) rename {preForth => common}/preForthDemo.pre (100%) rename {preForth => common}/runtime.forth (100%) rename {preForth => common}/seedForth-tokenizer.fs (100%) rename {preForth => common}/seedForth.pre (100%) rename {preForth => common}/seedForthBoot.seedsource (100%) rename {preForth => common}/seedForthDemo.seedsource (100%) rename {preForth => common}/seedForthInteractive.seedsource (100%) rename {preForth => common}/seedForthRuntime.seedsource (100%) rename {preForth => i386}/Makefile (67%) rename {preForth => i386}/preForth-i386-backend.pre (100%) rename {preForth => i386}/preForth-i386-rts.pre (100%) create mode 100755 i386/seed rename {preForth => i386}/seedForth-i386-header.pre (100%) rename {preForth => i386}/seedForth-i386.pre (100%) create mode 100755 i386/seedForth-tokenizer delete mode 100755 preForth/seed delete mode 100755 preForth/seedForth-tokenizer diff --git a/.gitignore b/.gitignore index e1a4c55..ef430de 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,7 @@ *.asm *.o *.seed -/preForth/crc10.forth -/preForth/preForth -/preForth/seedForth -/preForth/__temp__.fs +/common/crc10.forth +/i386/preForth +/i386/seedForth +/i386/__temp__.fs diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..2115904 --- /dev/null +++ b/Makefile @@ -0,0 +1,14 @@ +.PHONY: all +all: common i386 + +.PHONY: common +common: + $(MAKE) $(MAKEFLAGS) -C common + +.PHONY: i386 +i386: common + $(MAKE) $(MAKEFLAGS) -C i386 + +clean: + $(MAKE) $(MAKEFLAGS) -C common clean + $(MAKE) $(MAKEFLAGS) -C i386 clean diff --git a/preForth/.gitignore b/common/.gitignore similarity index 100% rename from preForth/.gitignore rename to common/.gitignore diff --git a/preForth/Dockerfile b/common/Dockerfile similarity index 100% rename from preForth/Dockerfile rename to common/Dockerfile diff --git a/common/Makefile b/common/Makefile new file mode 100644 index 0000000..c75c47c --- /dev/null +++ b/common/Makefile @@ -0,0 +1,15 @@ +# Set HOSTFORTH to the Forth system that generates the initial preForth +# ------------------------------------------------------------------------ +HOSTFORTH=gforth +# HOSTFORTH=sf # SwiftForth >3.7 +# ------------------------------------------------------------------------ + +.PHONY: all +all: crc10.forth + +crc10.forth: crc10_gen.forth + $(HOSTFORTH) $^ -e bye >$@ + +.PHONY: clean +clean: + rm -f crc10.forth diff --git a/preForth/crc10_gen.forth b/common/crc10_gen.forth similarity index 100% rename from preForth/crc10_gen.forth rename to common/crc10_gen.forth diff --git a/preForth/hi.forth b/common/hi.forth similarity index 100% rename from preForth/hi.forth rename to common/hi.forth diff --git a/preForth/preForth-bootstrap.fs b/common/preForth-bootstrap.fs similarity index 100% rename from preForth/preForth-bootstrap.fs rename to common/preForth-bootstrap.fs diff --git a/preForth/preForth-cold.fs b/common/preForth-cold.fs similarity index 100% rename from preForth/preForth-cold.fs rename to common/preForth-cold.fs diff --git a/preForth/preForth-rts-nonstandard.pre b/common/preForth-rts-nonstandard.pre similarity index 100% rename from preForth/preForth-rts-nonstandard.pre rename to common/preForth-rts-nonstandard.pre diff --git a/preForth/preForth-rts.pre b/common/preForth-rts.pre similarity index 100% rename from preForth/preForth-rts.pre rename to common/preForth-rts.pre diff --git a/preForth/preForth.pre b/common/preForth.pre similarity index 100% rename from preForth/preForth.pre rename to common/preForth.pre diff --git a/preForth/preForthDemo.pre b/common/preForthDemo.pre similarity index 100% rename from preForth/preForthDemo.pre rename to common/preForthDemo.pre diff --git a/preForth/runtime.forth b/common/runtime.forth similarity index 100% rename from preForth/runtime.forth rename to common/runtime.forth diff --git a/preForth/seedForth-tokenizer.fs b/common/seedForth-tokenizer.fs similarity index 100% rename from preForth/seedForth-tokenizer.fs rename to common/seedForth-tokenizer.fs diff --git a/preForth/seedForth.pre b/common/seedForth.pre similarity index 100% rename from preForth/seedForth.pre rename to common/seedForth.pre diff --git a/preForth/seedForthBoot.seedsource b/common/seedForthBoot.seedsource similarity index 100% rename from preForth/seedForthBoot.seedsource rename to common/seedForthBoot.seedsource diff --git a/preForth/seedForthDemo.seedsource b/common/seedForthDemo.seedsource similarity index 100% rename from preForth/seedForthDemo.seedsource rename to common/seedForthDemo.seedsource diff --git a/preForth/seedForthInteractive.seedsource b/common/seedForthInteractive.seedsource similarity index 100% rename from preForth/seedForthInteractive.seedsource rename to common/seedForthInteractive.seedsource diff --git a/preForth/seedForthRuntime.seedsource b/common/seedForthRuntime.seedsource similarity index 100% rename from preForth/seedForthRuntime.seedsource rename to common/seedForthRuntime.seedsource diff --git a/preForth/Makefile b/i386/Makefile similarity index 67% rename from preForth/Makefile rename to i386/Makefile index a76624b..69732b1 100644 --- a/preForth/Makefile +++ b/i386/Makefile @@ -8,7 +8,7 @@ HOSTFORTH=gforth # HOSTFORTH=sf # SwiftForth >3.7 # ------------------------------------------------------------------------ -.PHONY=all +.PHONY: all all: \ preForth \ seedForth \ @@ -16,14 +16,14 @@ seedForthDemo.seed \ seedForthBoot.seed \ seedForthInteractive.seed -.PHONY=test +.PHONY: test test: runseedforthdemo runseedforthinteractive -.PHONY=runseedforthdemo +.PHONY: runseedforthdemo runseedforthdemo: seedForth seedForthDemo.seed ./seedForth seedForthDemo.seed -.PHONY=runseedfortinteractive +.PHONY: runseedfortinteractive runseedforthinteractive: seedForth seedForthInteractive.seed ./seed @@ -31,37 +31,37 @@ UNIXFLAVOUR=$(shell uname -s) EXT=asm preForth.asm: \ -preForth-bootstrap.fs \ -preForth-cold.fs \ +../common/preForth-bootstrap.fs \ +../common/preForth-cold.fs \ preForth-i386-rts.pre \ -preForth-rts-nonstandard.pre \ -preForth-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ preForth-i386-backend.pre \ -preForth.pre +../common/preForth.pre cat \ preForth-i386-rts.pre \ -preForth-rts-nonstandard.pre \ -preForth-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ preForth-i386-backend.pre \ -preForth.pre \ +../common/preForth.pre \ |$(HOSTFORTH) \ -preForth-bootstrap.fs \ -preForth-rts-nonstandard.pre \ +../common/preForth-bootstrap.fs \ +../common/preForth-rts-nonstandard.pre \ preForth-i386-backend.pre \ -preForth.pre \ -preForth-cold.fs \ +../common/preForth.pre \ +../common/preForth-cold.fs \ >$@ %.asm: \ %.pre \ preForth-i386-rts.pre \ -preForth-rts-nonstandard.pre \ -preForth-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ preForth ./preForth \ preForth-i386-rts.pre \ -preForth-rts-nonstandard.pre \ -preForth-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ $< \ >$@ @@ -92,36 +92,36 @@ endif # should produce identical results bootstrap: \ preForth-i386-rts.pre \ -preForth-rts-nonstandard.pre \ -preForth-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ preForth-i386-backend.pre \ -preForth.pre \ +../common/preForth.pre \ preForth \ preForth.$(EXT) ./preForth \ preForth-i386-rts.pre \ -preForth-rts-nonstandard.pre \ -preForth-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ preForth-i386-backend.pre \ -preForth.pre \ +../common/preForth.pre \ >preForth1.$(EXT) cmp preForth.$(EXT) preForth1.$(EXT) # preForth connected to stdin - output to stdout -.PHONY=visible-bootstrap -visible-bootstrap: preForth preForth-i386-backend.pre preForth.pre - ./preForth preForth-i386-backend.pre preForth.pre +.PHONY: visible-bootstrap +visible-bootstrap: preForth preForth-i386-backend.pre ../common/preForth.pre + ./preForth preForth-i386-backend.pre ../common/preForth.pre # ------------------------------------------------------------------------ # Docker support (for Linux version) # ------------------------------------------------------------------------ # create a linux image based on Dockerfile -.PHONY=docker-image +.PHONY: docker-image docker-image: Dockerfile docker build -t preforth . # run the docker image -.PHONY=run +.PHONY: run rundocker: docker-image docker run -i -t --rm preforth /preForth/seed # ------------------------------------------------------------------------ @@ -133,44 +133,44 @@ seedForth.$(EXT): \ seedForth-i386-header.pre \ preForth-i386-rts.pre \ seedForth-i386.pre \ -seedForth.pre \ +../common/seedForth.pre \ preForth ./preForth \ seedForth-i386-header.pre \ preForth-i386-rts.pre \ seedForth-i386.pre \ -seedForth.pre \ +../common/seedForth.pre \ >seedForth.$(EXT) # a little ugly, because gforth insists upon echoing anything read from # stdin, and also does not allow parsing words to cross a file boundary, # so we will concatenate the tokenizer and source into a *.fs file first -seedForthDemo.seed: crc10.forth seedForth-tokenizer.fs seedForthDemo.seedsource +seedForthDemo.seed: \ +../common/crc10.forth \ +../common/../common/seedForth-tokenizer.fs \ +../common/seedForthDemo.seedsource cat $^ >__temp__.fs - gforth __temp__.fs -e bye >$@ + $(HOSTFORTH) __temp__.fs -e bye >$@ rm __temp__.fs seedForthBoot.seed: \ -crc10.forth \ -seedForth-tokenizer.fs \ -seedForthRuntime.seedsource \ -seedForthBoot.seedsource +../common/crc10.forth \ +../common/../common/seedForth-tokenizer.fs \ +../common/seedForthRuntime.seedsource \ +../common/seedForthBoot.seedsource cat $^ >__temp__.fs - gforth __temp__.fs -e bye >$@ + $(HOSTFORTH) __temp__.fs -e bye >$@ rm __temp__.fs seedForthInteractive.seed: \ -crc10.forth \ -seedForth-tokenizer.fs \ -seedForthRuntime.seedsource \ -seedForthInteractive.seedsource +../common/crc10.forth \ +../common/../common/seedForth-tokenizer.fs \ +../common/seedForthRuntime.seedsource \ +../common/seedForthInteractive.seedsource cat $^ >__temp__.fs - gforth __temp__.fs -e bye >$@ + $(HOSTFORTH) __temp__.fs -e bye >$@ rm __temp__.fs -crc10.forth: crc10_gen.forth - gforth $^ -e bye >$@ - -.PHONY=clean +.PHONY: clean clean: rm -f *.asm *.o *.seed preForthdemo preForth seedForth __temp__.fs diff --git a/preForth/preForth-i386-backend.pre b/i386/preForth-i386-backend.pre similarity index 100% rename from preForth/preForth-i386-backend.pre rename to i386/preForth-i386-backend.pre diff --git a/preForth/preForth-i386-rts.pre b/i386/preForth-i386-rts.pre similarity index 100% rename from preForth/preForth-i386-rts.pre rename to i386/preForth-i386-rts.pre diff --git a/i386/seed b/i386/seed new file mode 100755 index 0000000..ca20158 --- /dev/null +++ b/i386/seed @@ -0,0 +1,4 @@ +#!/bin/bash +stty raw -echo +./seedForth seedForthInteractive.seed ../common/runtime.forth ../common/hi.forth - +stty sane diff --git a/preForth/seedForth-i386-header.pre b/i386/seedForth-i386-header.pre similarity index 100% rename from preForth/seedForth-i386-header.pre rename to i386/seedForth-i386-header.pre diff --git a/preForth/seedForth-i386.pre b/i386/seedForth-i386.pre similarity index 100% rename from preForth/seedForth-i386.pre rename to i386/seedForth-i386.pre diff --git a/i386/seedForth-tokenizer b/i386/seedForth-tokenizer new file mode 100755 index 0000000..942d967 --- /dev/null +++ b/i386/seedForth-tokenizer @@ -0,0 +1,2 @@ +#!/bin/sh +./seedForth seedForthBoot.seed ../common/runtime.forth ../common/crc10.forth ../common/seedForth-tokenizer.fs - diff --git a/preForth/seed b/preForth/seed deleted file mode 100755 index 4deb5df..0000000 --- a/preForth/seed +++ /dev/null @@ -1,4 +0,0 @@ -#!/bin/bash -stty raw -echo -./seedForth seedForthInteractive.seed runtime.forth hi.forth - -stty sane diff --git a/preForth/seedForth-tokenizer b/preForth/seedForth-tokenizer deleted file mode 100755 index 420ff59..0000000 --- a/preForth/seedForth-tokenizer +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -./seedForth seedForthBoot.seed runtime.forth crc10.forth seedForth-tokenizer.fs - From ee347d8110e8868337e3a23482c439929282cbfe Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 11:11:06 +1000 Subject: [PATCH 27/41] Add emu_z80 directory based on submodules https://github.com/nickd4/asxv5pxx.git and https://github.com/superzazu/z80.git --- .gitignore | 8 ++++ .gitmodules | 6 +++ Makefile | 14 +++++- asxv5pxx | 1 + emu_z80/Makefile | 28 ++++++++++++ emu_z80/emu_z80.c | 107 ++++++++++++++++++++++++++++++++++++++++++++++ emu_z80/z80 | 1 + 7 files changed, 164 insertions(+), 1 deletion(-) create mode 100644 .gitmodules create mode 160000 asxv5pxx create mode 100644 emu_z80/Makefile create mode 100644 emu_z80/emu_z80.c create mode 160000 emu_z80/z80 diff --git a/.gitignore b/.gitignore index ef430de..3fe7d1a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,15 @@ *.asm +*.bin +*.hlr +*.ihx +*.lst +*.map *.o +*.rel +*.rst *.seed /common/crc10.forth +/emu_z80/emu_z80 /i386/preForth /i386/seedForth /i386/__temp__.fs diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..9bed4cf --- /dev/null +++ b/.gitmodules @@ -0,0 +1,6 @@ +[submodule "emu_z80/z80"] + path = emu_z80/z80 + url = https://github.com/superzazu/z80.git +[submodule "asxv5pxx"] + path = asxv5pxx + url = https://github.com/nickd4/asxv5pxx.git diff --git a/Makefile b/Makefile index 2115904..6205c10 100644 --- a/Makefile +++ b/Makefile @@ -1,14 +1,26 @@ .PHONY: all -all: common i386 +all: asxv5pxx common emu_z80 i386 + +.PHONY: asxv5pxx +asxv5pxx: + $(MAKE) $(MAKEFLAGS) -C asxv5pxx/asxmak/linux/build asz80 aslink .PHONY: common common: $(MAKE) $(MAKEFLAGS) -C common +.PHONY: emu_z80 +emu_z80: asxv5pxx + $(MAKE) $(MAKEFLAGS) -C emu_z80 + .PHONY: i386 i386: common $(MAKE) $(MAKEFLAGS) -C i386 clean: + $(MAKE) $(MAKEFLAGS) -C asxv5pxx/asxmak/linux/build clean + # avoid git complaining of changes in subrepo: + touch asxv5pxx/asxmak/linux/exe/_exe $(MAKE) $(MAKEFLAGS) -C common clean + $(MAKE) $(MAKEFLAGS) -C emu_z80 clean $(MAKE) $(MAKEFLAGS) -C i386 clean diff --git a/asxv5pxx b/asxv5pxx new file mode 160000 index 0000000..6d5d121 --- /dev/null +++ b/asxv5pxx @@ -0,0 +1 @@ +Subproject commit 6d5d1219781ad4b90294d84bd2589cccc4d728f3 diff --git a/emu_z80/Makefile b/emu_z80/Makefile new file mode 100644 index 0000000..6b61c69 --- /dev/null +++ b/emu_z80/Makefile @@ -0,0 +1,28 @@ +CFLAGS=-g -Wall +LDFLAGS=-g + +ASZ80=../asxv5pxx/asxmak/linux/exe/asz80 +ASLINK=../asxv5pxx/asxmak/linux/exe/aslink + +# need to install intelhex package in Python first: +# pip3 install --user intelhex +HEX2BIN=python3 $(HOME)/.local/bin/hex2bin.py + +.PHONY: all +all: emu_z80 test.bin + +emu_z80: emu_z80.o z80/z80.o z80/z80.o + $(CC) $(LDFLAGS) -o $@ $^ + +test.bin: test.ihx + $(HEX2BIN) $< $@ + +test.ihx: test.rel + $(ASLINK) -n -m -u -i $@ $^ + +test.rel: test.asm + $(ASZ80) -l -o $< + +.PHONY: clean +clean: + rm -f *.bin *.hlr *.ihx *.lst *.map *.o *.rel *.rst emu_z80 diff --git a/emu_z80/emu_z80.c b/emu_z80/emu_z80.c new file mode 100644 index 0000000..15c4ca5 --- /dev/null +++ b/emu_z80/emu_z80.c @@ -0,0 +1,107 @@ +#include +#include +#include +#include +#include +#include +#include "z80/z80.h" + +#define STDIN_DATA 0 +#define STDOUT_DATA 1 +#define STDERR_DATA 2 +#define SYS_EXIT 3 + +z80 cpu; +bool timing; +long nb_instructions; + +#define MEMORY_SIZE 0x10000 +uint8_t memory[MEMORY_SIZE]; + +uint8_t rb(void *userdata, uint16_t addr) { + return memory[addr]; +} + +void wb(void *userdata, uint16_t addr, uint8_t val) { + memory[addr] = val; +} + +uint8_t in(z80 *const z, uint8_t port) { + switch (port) { + case STDIN_DATA: + { + uint8_t data = 4; // EOT + if (read(STDIN_FILENO, &data, 1) == -1) { + perror("read()"); + exit(EXIT_FAILURE); + } + return data; + } + } + return 0xff; +} + +void out(z80 *const z, uint8_t port, uint8_t val) { + switch (port) { + case STDOUT_DATA: + if (write(STDOUT_FILENO, &val, 1) == -1) { + perror("write()"); + exit(EXIT_FAILURE); + } + break; + case STDERR_DATA: + if (write(STDERR_FILENO, &val, 1) == -1) { + perror("write()"); + exit(EXIT_FAILURE); + } + break; + case SYS_EXIT: + if (timing) + fprintf( + stderr, + "%lu instructions executed on %lu cycles\n", + nb_instructions, + cpu.cyc + ); + exit(val); + } +} + +int main(int argc, char **argv) { + int argn = 1; + if (argn < argc && strcmp(argv[argn], "-t") == 0) { + timing = true; + ++argn; + } + + if (argn >= argc) { + printf("usage: %s [-t] program.bin\n", argv[0]); + exit(EXIT_FAILURE); + } + + int fd = open(argv[argn], O_RDONLY); + if (fd == -1) { + perror(argv[argn]); + exit(EXIT_FAILURE); + } + if (read(fd, memory, MEMORY_SIZE) == -1) { + perror("read()"); + exit(EXIT_FAILURE); + } + close(fd); + + z80_init(&cpu); + cpu.read_byte = rb; + cpu.write_byte = wb; + cpu.port_in = in; + cpu.port_out = out; + + while (true) { + ++nb_instructions; + + // warning: the following line will output dozens of GB of data. + //z80_debug_output(&cpu); + + z80_step(&cpu); + } +} diff --git a/emu_z80/z80 b/emu_z80/z80 new file mode 160000 index 0000000..d64fe10 --- /dev/null +++ b/emu_z80/z80 @@ -0,0 +1 @@ +Subproject commit d64fe10a2274e5e40019b1086bf7d8990cbc5f23 From 3036d3774274339b04825c536dd644a907ad3c3c Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 12:07:33 +1000 Subject: [PATCH 28/41] In emu_z80, add "cat" functionality for stdin, and non-blocking I/O facilities --- emu_z80/emu_z80.c | 99 ++++++++++++++++++++++++++++++++++++++--- i386/seedForth-i386.pre | 2 +- 2 files changed, 95 insertions(+), 6 deletions(-) diff --git a/emu_z80/emu_z80.c b/emu_z80/emu_z80.c index 15c4ca5..0991260 100644 --- a/emu_z80/emu_z80.c +++ b/emu_z80/emu_z80.c @@ -1,22 +1,35 @@ #include +#include #include #include -#include #include +#include #include #include "z80/z80.h" #define STDIN_DATA 0 #define STDOUT_DATA 1 #define STDERR_DATA 2 -#define SYS_EXIT 3 +#define STDIN_STATUS 3 +#define STDOUT_STATUS 4 +#define STDERR_STATUS 5 +#define USLEEP_LO 6 +#define USLEEP_HI 7 +#define SYS_EXIT 8 z80 cpu; bool timing; long nb_instructions; +int stdin_fd; +int g_argn = 0; +int g_argc = 1; +const char *default_argv = "-"; +const char **g_argv = &default_argv; + #define MEMORY_SIZE 0x10000 uint8_t memory[MEMORY_SIZE]; +uint8_t usleep_lo; uint8_t rb(void *userdata, uint16_t addr) { return memory[addr]; @@ -26,17 +39,77 @@ void wb(void *userdata, uint16_t addr, uint8_t val) { memory[addr] = val; } +// call with g_argn < g_argc +void open_stdin(void) { + if (strcmp(g_argv[g_argn], "-") == 0) + stdin_fd = STDIN_FILENO; + else { + stdin_fd = open(g_argv[g_argn], O_RDONLY); + if (stdin_fd == -1) { + perror(g_argv[g_argn]); + exit(EXIT_FAILURE); + } + } +} + +void close_stdin(void) { + if (stdin_fd != STDIN_FILENO) + close(stdin_fd); +} + uint8_t in(z80 *const z, uint8_t port) { switch (port) { case STDIN_DATA: { uint8_t data = 4; // EOT - if (read(STDIN_FILENO, &data, 1) == -1) { - perror("read()"); + if (g_argn < g_argc) + while (true) { + ssize_t count = read(stdin_fd, &data, 1); + if (count == -1) { + perror("read()"); + exit(EXIT_FAILURE); + } + if (count) + break; + close_stdin(); + ++g_argn; + if (g_argn >= g_argc) + break; + open_stdin(); + } + return data; + } + case STDIN_STATUS: + { + if (g_argn >= g_argc) + return 1; // if no more input, force application to read EOT + struct pollfd fd = {stdin_fd, POLLIN, 0}; + if (poll(&fd, 1, 0) == -1) { + perror("poll()"); exit(EXIT_FAILURE); } - return data; + return (fd.revents & POLLIN) != 0; } + case STDOUT_STATUS: + { + struct pollfd fd = {STDOUT_FILENO, POLLOUT, 0}; + if (poll(&fd, 1, 0) == -1) { + perror("poll()"); + exit(EXIT_FAILURE); + } + return (fd.revents & POLLOUT) != 0; + } + case STDERR_STATUS: + { + struct pollfd fd = {STDERR_FILENO, POLLOUT, 0}; + if (poll(&fd, 1, 0) == -1) { + perror("poll()"); + exit(EXIT_FAILURE); + } + return (fd.revents & POLLOUT) != 0; + } + case USLEEP_LO: + return usleep_lo; } return 0xff; } @@ -55,6 +128,12 @@ void out(z80 *const z, uint8_t port, uint8_t val) { exit(EXIT_FAILURE); } break; + case USLEEP_LO: + usleep_lo = val; + break; + case USLEEP_HI: + usleep(usleep_lo | (val << 8)); + break; case SYS_EXIT: if (timing) fprintf( @@ -90,6 +169,16 @@ int main(int argc, char **argv) { } close(fd); + // implement "cat" functionality for stdin + // if not enough arguments, supply default argument of "-" + ++argn; + if (argn < argc) { + g_argn = argn; + g_argc = argc; + g_argv = (const char **)argv; + } + open_stdin(); + z80_init(&cpu); cpu.read_byte = rb; cpu.write_byte = wb; diff --git a/i386/seedForth-i386.pre b/i386/seedForth-i386.pre index 5666857..2901382 100644 --- a/i386/seedForth-i386.pre +++ b/i386/seedForth-i386.pre @@ -46,7 +46,7 @@ code key? ( -- f ) 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) + call write ; write(STDERR_FILENO, "can't poll\n", 11) mov dword [esp],EXIT_FAILURE call exit ; exit(EXIT_FAILURE) From 4df5731bedda4152c376d3bd3de80cff8e14677f Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 12:33:28 +1000 Subject: [PATCH 29/41] Move 16/32 bit and ITC/DTC dependencies into extra sources in /i386 directory --- common/hi.forth | 4 ++-- common/hi16bit.forth | 2 ++ common/hi32bit.forth | 2 ++ common/seedForth.pre | 6 ------ common/seedForth16bit.pre | 7 +++++++ common/seedForth32bit.pre | 7 +++++++ common/seedForthDemo.seedsource | 10 ---------- common/seedForthInteractive.seedsource | 6 +++--- common/seedForthRuntime.seedsource | 24 ++++-------------------- common/seedForthRuntime16bit.seedsource | 4 ++++ common/seedForthRuntime32bit.seedsource | 4 ++++ i386/Makefile | 9 ++++++++- i386/seed | 2 +- i386/seedForthDemoi386.seedsource | 12 ++++++++++++ i386/seedForthRuntimei386.seedsource | 19 +++++++++++++++++++ 15 files changed, 75 insertions(+), 43 deletions(-) create mode 100644 common/hi16bit.forth create mode 100644 common/hi32bit.forth create mode 100644 common/seedForth16bit.pre create mode 100644 common/seedForth32bit.pre create mode 100644 common/seedForthRuntime16bit.seedsource create mode 100644 common/seedForthRuntime32bit.seedsource create mode 100644 i386/seedForthDemoi386.seedsource create mode 100644 i386/seedForthRuntimei386.seedsource diff --git a/common/hi.forth b/common/hi.forth index 6515c6c..43b4ad0 100644 --- a/common/hi.forth +++ b/common/hi.forth @@ -219,7 +219,7 @@ end-tests begin-tests t{ 3 4 pyth -> 5 }t -t{ 65535 dup * sqrt -> 65535 }t +t{ test_sqr dup * sqrt -> test_sqr }t end-tests @@ -487,7 +487,7 @@ only Forth also definitions : th.prime ( u -- ) 1 BEGIN over WHILE 1+ dup prime? IF swap 1- swap THEN REPEAT nip ; -cr cr cr .( The ) 10001 dup . .( st prime is ) th.prime . +cr cr cr .( The ) test_prime dup . .( st prime is ) th.prime . \ cooperative multi tasker diff --git a/common/hi16bit.forth b/common/hi16bit.forth new file mode 100644 index 0000000..7496c75 --- /dev/null +++ b/common/hi16bit.forth @@ -0,0 +1,2 @@ +255 Constant test_sqr +1001 Constant test_prime diff --git a/common/hi32bit.forth b/common/hi32bit.forth new file mode 100644 index 0000000..4368905 --- /dev/null +++ b/common/hi32bit.forth @@ -0,0 +1,2 @@ +65535 Constant test_sqr +10001 Constant test_prime diff --git a/common/seedForth.pre b/common/seedForth.pre index dd5aaee..02c250b 100644 --- a/common/seedForth.pre +++ b/common/seedForth.pre @@ -12,12 +12,6 @@ : ?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 ! ; diff --git a/common/seedForth16bit.pre b/common/seedForth16bit.pre new file mode 100644 index 0000000..22be495 --- /dev/null +++ b/common/seedForth16bit.pre @@ -0,0 +1,7 @@ +\ seedForth: less machine dependent portion + +: 2* ( x1 -- x2 ) + dup + ; + +: cells ( x1 -- x2 ) + 2* ; diff --git a/common/seedForth32bit.pre b/common/seedForth32bit.pre new file mode 100644 index 0000000..d67da51 --- /dev/null +++ b/common/seedForth32bit.pre @@ -0,0 +1,7 @@ +\ seedForth: less machine dependent portion + +: 2* ( x1 -- x2 ) + dup + ; + +: cells ( x1 -- x2 ) + 2* 2* ; diff --git a/common/seedForthDemo.seedsource b/common/seedForthDemo.seedsource index 2efb7d6..e25a071 100644 --- a/common/seedForthDemo.seedsource +++ b/common/seedForthDemo.seedsource @@ -173,16 +173,6 @@ t{ person -> 3 cells }t \ size of structure Definer Defer ( -- ) create >r 'uninitialized , r> does> @ execute ; -: >body ( xt -- body ) h@ 1 cells + ; - -: is ( xt -- ) ' >body ! ; - -Defer d1 -' ten is d1 -t{ d1 d1 d1 -> ten ten ten }t -' five is d1 -t{ d1 d1 d1 -> five five five }t - t{ 3 4 + -> 7 }t diff --git a/common/seedForthInteractive.seedsource b/common/seedForthInteractive.seedsource index 935ed18..dc983a8 100644 --- a/common/seedForthInteractive.seedsource +++ b/common/seedForthInteractive.seedsource @@ -48,9 +48,9 @@ t{ 15 10 xor -> 5 }t t{ 21845 dup xor -> 0 }t \ $5555 t{ 21845 dup 2* xor -> 65535 }t -t{ -2147483648 2147483647 < -> -1 }t \ 32bit $80000000 $7FFFFFFF -t{ -2147483648 0 < -> -1 }t \ 32bit $80000000 0 -t{ 0 -2147483648 < -> 0 }t \ 32bit 0 $80000000 +t{ minint maxint < -> -1 }t \ 32bit $80000000 $7FFFFFFF +t{ minint 0 < -> -1 }t \ 32bit $80000000 0 +t{ 0 minint < -> 0 }t \ 32bit 0 $80000000 \ both positive t{ 10 10 < -> 0 }t diff --git a/common/seedForthRuntime.seedsource b/common/seedForthRuntime.seedsource index 3706722..a8d7e97 100644 --- a/common/seedForthRuntime.seedsource +++ b/common/seedForthRuntime.seedsource @@ -4,7 +4,8 @@ \ Defining words Definer Create ( -- ) create ( x ) drop ; Definer Variable ( -- ) create ( x ) drop 0 , ; -Definer Constant ( x -- ) create ( x ) >r , r> does> @ ; +\ the following is defined in seedForthRuntimeXXbit.seedsource +\ Definer Constant ( x -- ) create ( x ) >r , r> does> @ ; Macro Literal seed lit @@ -216,11 +217,6 @@ 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 @@ -264,12 +260,6 @@ minint 1- Constant maxint 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 @@ -384,7 +374,7 @@ Create tib 255 allot Create 'source here 0 , tib , \ ' source is normally ^tib #tib is set to c-addr u for evaluate Constant #tib -Defer getkey ' key is getkey +Defer getkey \ ' key is getkey (done later) \ 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 @@ -680,7 +670,6 @@ end-macro ' reveal has-header reveal ' hide has-header hide ' pad has-header pad -' >body has-header >body ' allocate has-header allocate ' free has-header free @@ -760,11 +749,6 @@ Variable heads -1 heads ! : 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 @@ -1031,7 +1015,7 @@ Variable echo 0 echo ! ' compiling? has-header compiling? -Defer .status : noop ; ' noop is .status +Defer .status : noop ; \ ' noop is .status (done later) ' noop has-header noop diff --git a/common/seedForthRuntime16bit.seedsource b/common/seedForthRuntime16bit.seedsource new file mode 100644 index 0000000..4eb6fd7 --- /dev/null +++ b/common/seedForthRuntime16bit.seedsource @@ -0,0 +1,4 @@ +Definer Constant ( x -- ) create ( x ) >r , r> does> @ ; + +-32768 Constant minint +32767 Constant maxint diff --git a/common/seedForthRuntime32bit.seedsource b/common/seedForthRuntime32bit.seedsource new file mode 100644 index 0000000..dbdfbbe --- /dev/null +++ b/common/seedForthRuntime32bit.seedsource @@ -0,0 +1,4 @@ +Definer Constant ( x -- ) create ( x ) >r , r> does> @ ; + +-2147483648 Constant minint +2147483647 Constant maxint diff --git a/i386/Makefile b/i386/Makefile index 69732b1..0e45b9c 100644 --- a/i386/Makefile +++ b/i386/Makefile @@ -133,12 +133,14 @@ seedForth.$(EXT): \ seedForth-i386-header.pre \ preForth-i386-rts.pre \ seedForth-i386.pre \ +../common/seedForth32bit.pre \ ../common/seedForth.pre \ preForth ./preForth \ seedForth-i386-header.pre \ preForth-i386-rts.pre \ seedForth-i386.pre \ +../common/seedForth32bit.pre \ ../common/seedForth.pre \ >seedForth.$(EXT) @@ -148,7 +150,8 @@ seedForth-i386.pre \ seedForthDemo.seed: \ ../common/crc10.forth \ ../common/../common/seedForth-tokenizer.fs \ -../common/seedForthDemo.seedsource +../common/seedForthDemo.seedsource \ +seedForthDemoi386.seedsource cat $^ >__temp__.fs $(HOSTFORTH) __temp__.fs -e bye >$@ rm __temp__.fs @@ -156,7 +159,9 @@ seedForthDemo.seed: \ seedForthBoot.seed: \ ../common/crc10.forth \ ../common/../common/seedForth-tokenizer.fs \ +../common/seedForthRuntime32bit.seedsource \ ../common/seedForthRuntime.seedsource \ +seedForthRuntimei386.seedsource \ ../common/seedForthBoot.seedsource cat $^ >__temp__.fs $(HOSTFORTH) __temp__.fs -e bye >$@ @@ -165,7 +170,9 @@ seedForthBoot.seed: \ seedForthInteractive.seed: \ ../common/crc10.forth \ ../common/../common/seedForth-tokenizer.fs \ +../common/seedForthRuntime32bit.seedsource \ ../common/seedForthRuntime.seedsource \ +seedForthRuntimei386.seedsource \ ../common/seedForthInteractive.seedsource cat $^ >__temp__.fs $(HOSTFORTH) __temp__.fs -e bye >$@ diff --git a/i386/seed b/i386/seed index ca20158..dc9b45d 100755 --- a/i386/seed +++ b/i386/seed @@ -1,4 +1,4 @@ #!/bin/bash stty raw -echo -./seedForth seedForthInteractive.seed ../common/runtime.forth ../common/hi.forth - +./seedForth seedForthInteractive.seed ../common/runtime.forth ../common/hi32bit.forth ../common/hi.forth - stty sane diff --git a/i386/seedForthDemoi386.seedsource b/i386/seedForthDemoi386.seedsource new file mode 100644 index 0000000..87139ac --- /dev/null +++ b/i386/seedForthDemoi386.seedsource @@ -0,0 +1,12 @@ +\ machine dependent part of seedForthDemo.seedsource +\ allows us to adjust things for direct threaded vs indirect threaded + +: >body ( xt -- body ) h@ 1 cells + ; + +: is ( xt -- ) ' >body ! ; + +Defer d1 +' ten is d1 +t{ d1 d1 d1 -> ten ten ten }t +' five is d1 +t{ d1 d1 d1 -> five five five }t diff --git a/i386/seedForthRuntimei386.seedsource b/i386/seedForthRuntimei386.seedsource new file mode 100644 index 0000000..0126e9b --- /dev/null +++ b/i386/seedForthRuntimei386.seedsource @@ -0,0 +1,19 @@ +\ machine dependent part of seedForthRuntime.seedsource +\ allows us to adjust things for direct threaded vs indirect threaded + +: >body ( xt -- body ) + h@ 1 cells + ; +' >body has-header >body + +: is ( xt -- ) \ only interactive + ' >body ! ; +' is has-header is + +\ these could not be done until here +' key is getkey +' noop is .status + +: (Does>) ( -- ) + [ ' last-xt ] Literal compile, + [ ' does> ] Literal compile, ; +' (Does>) has-header Does> immediate From 65e486ad29f906b7176bd53164d99c6b841126e4 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 14:33:36 +1000 Subject: [PATCH 30/41] Rename seedForth-i386.pre to seedForth-i386-rts.pre, implement a new seedForth-i386.pre containing some compiler words so we can do special handling for DTC --- common/seedForth.pre | 21 ---- i386/Makefile | 2 + i386/seedForth-i386-rts.pre | 228 ++++++++++++++++++++++++++++++++++ i386/seedForth-i386.pre | 238 +++--------------------------------- 4 files changed, 244 insertions(+), 245 deletions(-) create mode 100644 i386/seedForth-i386-rts.pre diff --git a/common/seedForth.pre b/common/seedForth.pre index 02c250b..bab1729 100644 --- a/common/seedForth.pre +++ b/common/seedForth.pre @@ -70,19 +70,6 @@ dup h@ lit eot - ?exit drop \ not eot token: exit i.e. normal compile action r> drop ; \ compilation semantics: return to interpretive state -: compiler ( -- ) - token - - \ Nick: old way of detecting bye token directly prevented compiling it - \ ?dup 0= ?exit - ?eot - - ?lit - compile, tail compiler ; - -: new ( -- xt ) - hp @ here h, lit enter , ; - : fun ( -- ) new drop compiler ; @@ -92,14 +79,6 @@ : $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 - ; diff --git a/i386/Makefile b/i386/Makefile index 0e45b9c..f931460 100644 --- a/i386/Makefile +++ b/i386/Makefile @@ -132,6 +132,7 @@ rundocker: docker-image seedForth.$(EXT): \ seedForth-i386-header.pre \ preForth-i386-rts.pre \ +seedForth-i386-rts.pre \ seedForth-i386.pre \ ../common/seedForth32bit.pre \ ../common/seedForth.pre \ @@ -139,6 +140,7 @@ preForth ./preForth \ seedForth-i386-header.pre \ preForth-i386-rts.pre \ +seedForth-i386-rts.pre \ seedForth-i386.pre \ ../common/seedForth32bit.pre \ ../common/seedForth.pre \ diff --git a/i386/seedForth-i386-rts.pre b/i386/seedForth-i386-rts.pre new file mode 100644 index 0000000..2901382 --- /dev/null +++ b/i386/seedForth-i386-rts.pre @@ -0,0 +1,228 @@ +\ seedForth: machine dependent portion + +\ interpreter and basic asm primitives are taken from preForth-i386-rts.pre, +\ and then this file defines additional primitives (arithmetic, memory, etc) + +pre +extrn poll +extrn usleep + +_enter = _nest + +_dodoes: ; ( -- addr ) + 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 +; + +code key? ( -- f ) + push ebp + mov ebp,esp + and esp,0xfffffff0 + sub esp,32 + + ; if all arguments exhausted, return ready + ; this allows application to collect the EOT character + mov eax,[argn] + cmp eax,[argc] + jae keyq_ready + + mov eax,[fd_in] + mov dword [esp+12],eax + mov dword [esp+16],POLLIN ; struct pollfd fd = {fd_in, POLLIN, 0} + + lea eax,[esp+12] + mov [esp],eax + mov dword [esp+4],1 + mov dword [esp+8],0 + call poll ; eax = poll(&fd, 1, 0) + cmp eax,-1 + jnz keyq_ok + + mov dword [esp],STDERR_FILENO + mov dword [esp+4],message_cant_poll + mov dword [esp+8],message_cant_poll_end - message_cant_poll + call write ; write(STDERR_FILENO, "can't poll\n", 11) + + mov dword [esp],EXIT_FAILURE + call exit ; exit(EXIT_FAILURE) + +keyq_ok: + sub eax,eax + test word [esp+18],POLLIN ; fd.revents & POLLIN + jz keyq_done +keyq_ready: + mov eax,-1 +keyq_done: + + mov esp,ebp + pop ebp + + push eax + next +; + +code or ( x1 x2 -- x3 ) + pop edx + pop eax + or eax,edx + push eax + next +; + +code and ( x1 x2 -- x3 ) + pop edx + pop eax + and eax,edx + push eax + next +; + +pre +_exit = _unnest +; + +code @ ( addr -- x ) + pop eax + mov eax,[eax] + push eax + next +; + +code c@ ( c-addr -- c ) + pop edx + xor eax,eax + mov al,byte [edx] + push eax + next +; + +code ! ( x addr -- ) + pop edx + pop eax + mov dword [edx],eax + next +; + +code c! ( c c-addr -- ) + pop edx + pop eax + mov byte [edx],al + next +; + +\ code 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 branch ( -- ) \ threaded code: r> @ >r ; + lodsd + mov esi,eax + next +; + +code ?branch ( f -- ) \ threaded code: ?exit r> @ >r ; + pop eax + or eax,eax + jz _branchX + lea esi,[esi+4] + next +; + +code depth ( -- n ) + mov eax,data_stack + DATA_STACK_SIZE + sub eax,esp + sar eax,2 + push eax + next +; + +code sp@ ( -- x ) + push esp + next +; + +code sp! ( x -- ) + pop esp + next +; + +code rp@ ( -- x ) + push ebp + next +; + +code rp! ( x -- ) + pop ebp + next +; + +code um* ( u1 u2 -- ud ) + 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 +; + +code usleep ( c -- ) + pop eax ; eax = microseconds to sleep + + push ebp + mov ebp,esp + and esp,0xfffffff0 + sub esp,16 + + mov [esp],eax + call usleep + + mov esp,ebp + pop ebp + next +; + +\ we want the text section to be first and bss last (for linkers that output +\ sections in definition order), so it would be good to have the bss section +\ be output by the ",end" hook, but at present we cannot call "pre" from a +\ defined word, so we make do by switching to bss and then back to text again +pre +section '.data' writeable align 16 + +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 + + ; 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: + +section '.text' executable + +; diff --git a/i386/seedForth-i386.pre b/i386/seedForth-i386.pre index 2901382..c21f5d8 100644 --- a/i386/seedForth-i386.pre +++ b/i386/seedForth-i386.pre @@ -1,228 +1,18 @@ -\ seedForth: machine dependent portion +\ seedForth: less machine dependent portion +\ allows us to adjust things for direct threaded vs indirect threaded -\ interpreter and basic asm primitives are taken from preForth-i386-rts.pre, -\ and then this file defines additional primitives (arithmetic, memory, etc) +: compiler ( -- ) + token + ?eot + ?lit + compile, tail compiler ; -pre -extrn poll -extrn usleep +: new ( -- xt ) + hp @ here h, lit enter , ; -_enter = _nest +: create ( -- xt ) + 0 , \ dummy does> field + hp @ here h, lit dovar , ; -_dodoes: ; ( -- addr ) - 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 -; - -code key? ( -- f ) - push ebp - mov ebp,esp - and esp,0xfffffff0 - sub esp,32 - - ; if all arguments exhausted, return ready - ; this allows application to collect the EOT character - mov eax,[argn] - cmp eax,[argc] - jae keyq_ready - - mov eax,[fd_in] - mov dword [esp+12],eax - mov dword [esp+16],POLLIN ; struct pollfd fd = {fd_in, POLLIN, 0} - - lea eax,[esp+12] - mov [esp],eax - mov dword [esp+4],1 - mov dword [esp+8],0 - call poll ; eax = poll(&fd, 1, 0) - cmp eax,-1 - jnz keyq_ok - - mov dword [esp],STDERR_FILENO - mov dword [esp+4],message_cant_poll - mov dword [esp+8],message_cant_poll_end - message_cant_poll - call write ; write(STDERR_FILENO, "can't poll\n", 11) - - mov dword [esp],EXIT_FAILURE - call exit ; exit(EXIT_FAILURE) - -keyq_ok: - sub eax,eax - test word [esp+18],POLLIN ; fd.revents & POLLIN - jz keyq_done -keyq_ready: - mov eax,-1 -keyq_done: - - mov esp,ebp - pop ebp - - push eax - next -; - -code or ( x1 x2 -- x3 ) - pop edx - pop eax - or eax,edx - push eax - next -; - -code and ( x1 x2 -- x3 ) - pop edx - pop eax - and eax,edx - push eax - next -; - -pre -_exit = _unnest -; - -code @ ( addr -- x ) - pop eax - mov eax,[eax] - push eax - next -; - -code c@ ( c-addr -- c ) - pop edx - xor eax,eax - mov al,byte [edx] - push eax - next -; - -code ! ( x addr -- ) - pop edx - pop eax - mov dword [edx],eax - next -; - -code c! ( c c-addr -- ) - pop edx - pop eax - mov byte [edx],al - next -; - -\ code 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 branch ( -- ) \ threaded code: r> @ >r ; - lodsd - mov esi,eax - next -; - -code ?branch ( f -- ) \ threaded code: ?exit r> @ >r ; - pop eax - or eax,eax - jz _branchX - lea esi,[esi+4] - next -; - -code depth ( -- n ) - mov eax,data_stack + DATA_STACK_SIZE - sub eax,esp - sar eax,2 - push eax - next -; - -code sp@ ( -- x ) - push esp - next -; - -code sp! ( x -- ) - pop esp - next -; - -code rp@ ( -- x ) - push ebp - next -; - -code rp! ( x -- ) - pop ebp - next -; - -code um* ( u1 u2 -- ud ) - 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 -; - -code usleep ( c -- ) - pop eax ; eax = microseconds to sleep - - push ebp - mov ebp,esp - and esp,0xfffffff0 - sub esp,16 - - mov [esp],eax - call usleep - - mov esp,ebp - pop ebp - next -; - -\ we want the text section to be first and bss last (for linkers that output -\ sections in definition order), so it would be good to have the bss section -\ be output by the ",end" hook, but at present we cannot call "pre" from a -\ defined word, so we make do by switching to bss and then back to text again -pre -section '.data' writeable align 16 - -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 - - ; 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: - -section '.text' executable - -; +: does> ( xt -- ) \ set code field of last defined word + r> swap h@ dup >r 1 cells - ! lit dodoes r> ! ; From 6134fa650289a33fbef3b74ddbc17ccb7c1f24fe Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 13:12:03 +1000 Subject: [PATCH 31/41] Copy /i386 to /z80 and rename files as appropriate --- .gitignore | 3 + Makefile | 6 +- z80/Makefile | 185 ++++++++++++++ z80/preForth-z80-backend.pre | 153 +++++++++++ z80/preForth-z80-rts.pre | 398 +++++++++++++++++++++++++++++ z80/seed | 4 + z80/seedForth-tokenizer | 2 + z80/seedForth-z80-header.pre | 24 ++ z80/seedForth-z80-rts.pre | 228 +++++++++++++++++ z80/seedForth-z80.pre | 18 ++ z80/seedForthDemoz80.seedsource | 12 + z80/seedForthRuntimez80.seedsource | 19 ++ 12 files changed, 1051 insertions(+), 1 deletion(-) create mode 100644 z80/Makefile create mode 100644 z80/preForth-z80-backend.pre create mode 100644 z80/preForth-z80-rts.pre create mode 100755 z80/seed create mode 100755 z80/seedForth-tokenizer create mode 100644 z80/seedForth-z80-header.pre create mode 100644 z80/seedForth-z80-rts.pre create mode 100644 z80/seedForth-z80.pre create mode 100644 z80/seedForthDemoz80.seedsource create mode 100644 z80/seedForthRuntimez80.seedsource diff --git a/.gitignore b/.gitignore index 3fe7d1a..0bad648 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,6 @@ /i386/preForth /i386/seedForth /i386/__temp__.fs +/z80/preForth +/z80/seedForth +/z80/__temp__.fs diff --git a/Makefile b/Makefile index 6205c10..b481a8f 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ .PHONY: all -all: asxv5pxx common emu_z80 i386 +all: asxv5pxx common emu_z80 i386 z80 .PHONY: asxv5pxx asxv5pxx: @@ -17,6 +17,10 @@ emu_z80: asxv5pxx i386: common $(MAKE) $(MAKEFLAGS) -C i386 +.PHONY: z80 +z80: emu_z80 common + $(MAKE) $(MAKEFLAGS) -C z80 + clean: $(MAKE) $(MAKEFLAGS) -C asxv5pxx/asxmak/linux/build clean # avoid git complaining of changes in subrepo: diff --git a/z80/Makefile b/z80/Makefile new file mode 100644 index 0000000..29960e2 --- /dev/null +++ b/z80/Makefile @@ -0,0 +1,185 @@ +# Makefile for preForth and seedForth +# +# make bootstrap should produce two identical files: preForth1.asm and preForth.asm + +# Set HOSTFORTH to the Forth system that generates the initial preForth +# ------------------------------------------------------------------------ +HOSTFORTH=gforth +# HOSTFORTH=sf # SwiftForth >3.7 +# ------------------------------------------------------------------------ + +.PHONY: all +all: \ +preForth \ +seedForth \ +seedForthDemo.seed \ +seedForthBoot.seed \ +seedForthInteractive.seed + +.PHONY: test +test: runseedforthdemo runseedforthinteractive + +.PHONY: runseedforthdemo +runseedforthdemo: seedForth seedForthDemo.seed + ./seedForth seedForthDemo.seed + +.PHONY: runseedfortinteractive +runseedforthinteractive: seedForth seedForthInteractive.seed + ./seed + +UNIXFLAVOUR=$(shell uname -s) +EXT=asm + +preForth.asm: \ +../common/preForth-bootstrap.fs \ +../common/preForth-cold.fs \ +preForth-z80-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth-z80-backend.pre \ +../common/preForth.pre + cat \ +preForth-z80-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth-z80-backend.pre \ +../common/preForth.pre \ +|$(HOSTFORTH) \ +../common/preForth-bootstrap.fs \ +../common/preForth-rts-nonstandard.pre \ +preForth-z80-backend.pre \ +../common/preForth.pre \ +../common/preForth-cold.fs \ +>$@ + +%.asm: \ +%.pre \ +preForth-z80-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth + ./preForth \ +preForth-z80-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +$< \ +>$@ + +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 + # rm $@.o +else +ifeq ($(UNIXFLAVOUR),Darwin) +# assemble and link executable on MacOS +%: %.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-z80-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth-z80-backend.pre \ +../common/preForth.pre \ +preForth \ +preForth.$(EXT) + ./preForth \ +preForth-z80-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth-z80-backend.pre \ +../common/preForth.pre \ +>preForth1.$(EXT) + cmp preForth.$(EXT) preForth1.$(EXT) + +# preForth connected to stdin - output to stdout +.PHONY: visible-bootstrap +visible-bootstrap: preForth preForth-z80-backend.pre ../common/preForth.pre + ./preForth preForth-z80-backend.pre ../common/preForth.pre + +# ------------------------------------------------------------------------ +# Docker support (for Linux version) +# ------------------------------------------------------------------------ +# create a linux image based on Dockerfile +.PHONY: docker-image +docker-image: Dockerfile + docker build -t preforth . + +# run the docker image +.PHONY: run +rundocker: docker-image + docker run -i -t --rm preforth /preForth/seed +# ------------------------------------------------------------------------ + +# ------------------------------------------------------------------------ +# seedForth +# ------------------------------------------------------------------------ +seedForth.$(EXT): \ +seedForth-z80-header.pre \ +preForth-z80-rts.pre \ +seedForth-z80-rts.pre \ +seedForth-z80.pre \ +../common/seedForth32bit.pre \ +../common/seedForth.pre \ +preForth + ./preForth \ +seedForth-z80-header.pre \ +preForth-z80-rts.pre \ +seedForth-z80-rts.pre \ +seedForth-z80.pre \ +../common/seedForth32bit.pre \ +../common/seedForth.pre \ +>seedForth.$(EXT) + +# a little ugly, because gforth insists upon echoing anything read from +# stdin, and also does not allow parsing words to cross a file boundary, +# so we will concatenate the tokenizer and source into a *.fs file first +seedForthDemo.seed: \ +../common/crc10.forth \ +../common/../common/seedForth-tokenizer.fs \ +../common/seedForthDemo.seedsource \ +seedForthDemoz80.seedsource + cat $^ >__temp__.fs + $(HOSTFORTH) __temp__.fs -e bye >$@ + rm __temp__.fs + +seedForthBoot.seed: \ +../common/crc10.forth \ +../common/../common/seedForth-tokenizer.fs \ +../common/seedForthRuntime32bit.seedsource \ +../common/seedForthRuntime.seedsource \ +seedForthRuntimez80.seedsource \ +../common/seedForthBoot.seedsource + cat $^ >__temp__.fs + $(HOSTFORTH) __temp__.fs -e bye >$@ + rm __temp__.fs + +seedForthInteractive.seed: \ +../common/crc10.forth \ +../common/../common/seedForth-tokenizer.fs \ +../common/seedForthRuntime32bit.seedsource \ +../common/seedForthRuntime.seedsource \ +seedForthRuntimez80.seedsource \ +../common/seedForthInteractive.seedsource + cat $^ >__temp__.fs + $(HOSTFORTH) __temp__.fs -e bye >$@ + rm __temp__.fs + +.PHONY: clean +clean: + rm -f *.asm *.o *.seed preForthdemo preForth seedForth __temp__.fs diff --git a/z80/preForth-z80-backend.pre b/z80/preForth-z80-backend.pre new file mode 100644 index 0000000..6881741 --- /dev/null +++ b/z80/preForth-z80-backend.pre @@ -0,0 +1,153 @@ +\ -------------------------- +\ preForth backend for i386 (32 bit) FASM +\ -------------------------- + +\ alter substitutes non-letter characters by upper case letters (to aid assemblers to deal with labels). +: replace ( c -- c d ) + 'A' swap 39 case? ?exit nip + 'B' swap '\' case? ?exit nip + 'C' swap ':' case? ?exit nip + 'D' swap '.' case? ?exit nip + 'E' swap '=' case? ?exit nip + 'F' swap '[' case? ?exit nip + 'G' swap '>' case? ?exit nip + 'H' swap ']' case? ?exit nip + 'I' swap '1' case? ?exit nip + 'J' swap '2' case? ?exit nip + 'K' swap '/' case? ?exit nip + 'L' swap '<' case? ?exit nip + 'M' swap '-' case? ?exit nip + 'N' swap '#' case? ?exit nip + 'O' swap '0' case? ?exit nip + 'P' swap '+' case? ?exit nip + 'Q' swap '?' case? ?exit nip + 'R' swap '"' case? ?exit nip +\ 'S' swap '!' case? ?exit nip + 'T' swap '*' case? ?exit nip + 'U' swap '(' case? ?exit nip + 'V' swap '|' case? ?exit nip + 'W' swap ',' case? ?exit nip + \ also 'X' for machine code + 'Y' swap ')' case? ?exit nip + 'Z' swap ';' case? ?exit nip +; + +\ alter substitutes all non-letter characters by upper case letters. +: alter ( S1 -- S2 ) + '_' 1 rot ?dup 0= ?exit nip nip + \ dup 0= ?exit + swap >r 1- alter r> replace swap 1+ ; + +\ ------------ +\ output words +\ ------------ +\ Output is done by emit. +\ We define convenience words of the form ."xxx" to output xxx (maybe tabbed) + +: ."dd" ( -- ) + tab 'd' emit 'd' emit tab ; + +: ."db" ( -- ) + tab 'd' emit 'b' emit tab ; + +: ."nest" ( -- ) + 'n' 'e' 's' 't' 4 alter show ; + +: ."unnest" ( -- ) + 'u' 'n' 'n' 'e' 's' 't' 6 alter show ; + +: ."lit" ( -- ) + 'l' 'i' 't' 3 alter show ; + +\ ------------ +\ Compiling words +\ ------------ + +\ ,string compiles the topmost string as a sequence of numeric DB values. +: ,string ( S -- ) + ?dup 0= ?exit + 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 +: ,word ( S -- ) + ."dd" alter show cr ; + +\ compile reference to nest primitive +: ,nest ( -- ) + ."dd" ."nest" cr ; + +\ compile reference to unnest primitive +: ,unnest ( -- ) + ."dd" ."unnest" cr cr ; + +\ compile signed number +: ,n ( n -- ) + ."dd" . cr ; + +\ compile unsigned number +: ,u ( u -- ) + ."dd" u. cr ; + +\ compile literal +: ,_lit ( S -- ) + ."dd" ."lit" cr ,word ; + +\ compile literal +: ,lit ( x -- ) + ."dd" ."lit" cr ,n ; + +\ output string as comment +: ,comment ( S -- ) + 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 -- ) + alter dup >r show ':' emit r> 7 - 0< ?exit cr ; + +\ body calculates the name of the body from a token +: body ( S1 -- S2 ) + 'X' swap 1+ ; + +\ ,codefield compiles the code field of primitive +: ,codefield ( S -- ) + body _dup ,word label ; + +: ,code ( S -- ) + _dup label + ,codefield ; + +: ,end-code ( -- ) + cr ; + +\ ----------------------------------- +\ tail call optimization tail word ; -> [ ' word >body ] literal >r ; + +: bodylabel ( S -- ) + body label ; + +\ ,tail compiles a tail call +: ,tail ( S -- ) + 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 ; + +: ,end ( S -- ) + \ 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 ; + diff --git a/z80/preForth-z80-rts.pre b/z80/preForth-z80-rts.pre new file mode 100644 index 0000000..9fed2a9 --- /dev/null +++ b/z80/preForth-z80-rts.pre @@ -0,0 +1,398 @@ +\ preForth runtime system - i386 (32 bit) dependent part +\ -------------------------- +\ +\ - registers: +\ EAX, EDX general purpose +\ ESI instruction pointer +\ EBP return stack pointer +\ ESP data stack pointer + +pre +;;; This is a preForth generated file using preForth-i386-backend. +;;; Only modify it, if you know what you are doing. + +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 close +extrn exit +extrn open +extrn read +extrn strcmp +extrn strlen +extrn write + +macro next { + lodsd + jmp dword [eax] +} + +main: cld + + ; implement the functionality of "cat" for reading "key" input + ; files listed on command line will be read in order, "-" is stdin + ; if there are no command line arguments, supply a default of "-" + mov eax,[esp+4] ; argc + mov ecx,[esp+8] ; argv + cmp eax,2 + jb no_arguments ; if no arguments, use pre-filled defaults + mov [argc],eax + mov [argv],ecx +no_arguments: + call open_fd_in + + mov esp,data_stack + DATA_STACK_SIZE + mov ebp,return_stack + RETURN_STACK_SIZE + mov esi,main1 + next + +open_fd_in: + push esi + push ebp + mov ebp,esp + and esp,0xfffffff0 + sub esp,16 + + mov eax,[argn] + mov ecx,[argv] + mov esi,[ecx+eax*4] ; esi = argv[argn] + + mov [esp],esi + mov dword [esp+4],dash_c_str + call strcmp ; eax = strcmp(esi, "-") + test eax,eax + mov eax,STDIN_FILENO + jz open_fd_in_ok ; if "-", do not open and use STDIN_FILENO + + mov [esp],esi + mov dword [esp+4],O_RDONLY + call open ; eax = open(esi, O_RDONLY) + cmp eax,-1 + jnz open_fd_in_ok ; if open successful, use returned fd + + mov dword [esp],STDERR_FILENO + mov dword [esp+4],message_cant_open + mov dword [esp+8],message_cant_open_end - message_cant_open + call write ; write(STDERR_FILENO, "can't open: ", 12) + + mov dword [esp],esi + call strlen ; eax = strlen(esi) + + mov dword [esp],STDERR_FILENO + mov [esp+4],esi + mov [esp+8],eax + call write ; write(STDERR_FILENO, esi, strlen(esi)) + + mov dword [esp],STDERR_FILENO + mov dword [esp+4],message_newline + mov dword [esp+8],message_newline_end - message_newline + call write ; write(STDERR_FILENO, "\n", 1) + + mov dword [esp],EXIT_FAILURE + call exit ; exit(EXIT_FAILURE) + +open_fd_in_ok: + mov [fd_in],eax + + 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 + +_nest: lea ebp,[ebp-4] + mov [ebp],esi + lea esi,[eax+4] + next + +; + +code bye ( -- ) + and esp,0xfffffff0 + sub esp,16 + + mov dword [esp],EXIT_SUCCESS + call exit ; exit(EXIT_SUCCESS) +; + +code emit ( 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],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 +; + +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 + and esp,0xfffffff0 + sub esp,16 + + mov dword [esp+12],EOT_CHAR ; int ch_in = EOT_CHAR (litle endian) + + ; if argn >= argc then no file is open, so return EOT_CHAR + mov eax,[argn] + cmp eax,[argc] + jae key_done + +key_read: + mov eax,[fd_in] + mov [esp],eax + lea eax,[esp+12] + mov [esp+4],eax + mov dword [esp+8],1 + call read ; eax = read(fd_in, &ch_in, 1) + cmp eax,-1 + jnz key_ok + + mov dword [esp],STDERR_FILENO + mov dword [esp+4],message_cant_read + mov dword [esp+8],message_cant_read_end - message_cant_read + call write ; write(STDERR_FILENO, "can't read\n", 11) + + mov dword [esp],EXIT_FAILURE + call exit ; exit(EXIT_FAILURE) + +key_ok: + ; if key was read successfully, send to application + test eax,eax + jnz key_done + + ; eof + call close_fd_in + + ; if arguments now exhausted, sent EOT to application + mov eax,[argn] + inc eax + mov [argn],eax + cmp eax,[argc] + jae key_done + + ; open next input file, and then re-attempt the read + call open_fd_in + jmp key_read + +key_done: + mov eax,[esp+12] ; eax = ch_in + + mov esp,ebp + pop ebp + + push eax + next +; + +code dup ( x -- x x ) + pop eax + push eax + push eax + next +; + +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 unnest ( -- ) + mov esi,[ebp] + lea ebp,[ebp+4] + next +; + +code lit ( -- ) + lodsd + push eax + next +; + +\ we want the text section to be first and bss last (for linkers that output +\ sections in definition order), so it would be good to have the bss section +\ be output by the ",end" hook, but at present we cannot call "pre" from a +\ defined word, so we make do by switching to bss and then back to text again +pre +section '.data' writeable align 16 + +message_cant_open: + db 'can''t open: ' +message_cant_open_end: + +message_newline: + db 0xa +message_newline_end: + +message_cant_read: + db 'can''t read',0xa +message_cant_read_end: + +message_cant_write: + db 'can''t write',0xa +message_cant_write_end: + +dash_c_str: + db '-',0 + + align 4 + +default_argv: + dd 0 ; argv[0] + dd dash_c_str +default_argv_end: + +; default command line arguments, overwritten if any passed in +argc: dd (default_argv_end - default_argv) / 4 +argv: dd default_argv + +; argument number being processed, fd_in is valid if argn < argc +argn: dd 1 + +section '.bss' writeable align 16 + +fd_in: dd 0 + +data_stack: + db DATA_STACK_SIZE dup (0) +return_stack: + db RETURN_STACK_SIZE dup (0) + +section '.text' executable + +; diff --git a/z80/seed b/z80/seed new file mode 100755 index 0000000..dd58d16 --- /dev/null +++ b/z80/seed @@ -0,0 +1,4 @@ +#!/bin/bash +stty raw -echo +./seedForth seedForthInteractive.seed ../common/runtime.forth ../common/hi16bit.forth ../common/hi.forth - +stty sane diff --git a/z80/seedForth-tokenizer b/z80/seedForth-tokenizer new file mode 100755 index 0000000..942d967 --- /dev/null +++ b/z80/seedForth-tokenizer @@ -0,0 +1,2 @@ +#!/bin/sh +./seedForth seedForthBoot.seed ../common/runtime.forth ../common/crc10.forth ../common/seedForth-tokenizer.fs - diff --git a/z80/seedForth-z80-header.pre b/z80/seedForth-z80-header.pre new file mode 100644 index 0000000..bddc8e3 --- /dev/null +++ b/z80/seedForth-z80-header.pre @@ -0,0 +1,24 @@ +\ seedForth: machine dependent header portion + +\ this contains only definitions we want at the top of the file +\ it is then followed by preForth-i386-rts.pre (primitive asm words) +\ and then by seedForth-i386.pre (additional primitive asm words) +\ and then by seedForth.pre (high level words and the interpreter) + +pre +;;; This is seedForth - a small potentially interactive Forth, that dynamically +;;; bootstraps from a minimal kernel. +;;; +;;; cat seedForth.seed - | ./seedForth +;;; +;;; .seed files are in byte-tokenized source code format. +;;; +;;; Use the seedForth tokenizer to convert human readable source code to +;;; byte-token form. + +HEAD_SIZE = 40000 +MEM_SIZE = 400000 + +POLLIN = 1 + +; diff --git a/z80/seedForth-z80-rts.pre b/z80/seedForth-z80-rts.pre new file mode 100644 index 0000000..2901382 --- /dev/null +++ b/z80/seedForth-z80-rts.pre @@ -0,0 +1,228 @@ +\ seedForth: machine dependent portion + +\ interpreter and basic asm primitives are taken from preForth-i386-rts.pre, +\ and then this file defines additional primitives (arithmetic, memory, etc) + +pre +extrn poll +extrn usleep + +_enter = _nest + +_dodoes: ; ( -- addr ) + 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 +; + +code key? ( -- f ) + push ebp + mov ebp,esp + and esp,0xfffffff0 + sub esp,32 + + ; if all arguments exhausted, return ready + ; this allows application to collect the EOT character + mov eax,[argn] + cmp eax,[argc] + jae keyq_ready + + mov eax,[fd_in] + mov dword [esp+12],eax + mov dword [esp+16],POLLIN ; struct pollfd fd = {fd_in, POLLIN, 0} + + lea eax,[esp+12] + mov [esp],eax + mov dword [esp+4],1 + mov dword [esp+8],0 + call poll ; eax = poll(&fd, 1, 0) + cmp eax,-1 + jnz keyq_ok + + mov dword [esp],STDERR_FILENO + mov dword [esp+4],message_cant_poll + mov dword [esp+8],message_cant_poll_end - message_cant_poll + call write ; write(STDERR_FILENO, "can't poll\n", 11) + + mov dword [esp],EXIT_FAILURE + call exit ; exit(EXIT_FAILURE) + +keyq_ok: + sub eax,eax + test word [esp+18],POLLIN ; fd.revents & POLLIN + jz keyq_done +keyq_ready: + mov eax,-1 +keyq_done: + + mov esp,ebp + pop ebp + + push eax + next +; + +code or ( x1 x2 -- x3 ) + pop edx + pop eax + or eax,edx + push eax + next +; + +code and ( x1 x2 -- x3 ) + pop edx + pop eax + and eax,edx + push eax + next +; + +pre +_exit = _unnest +; + +code @ ( addr -- x ) + pop eax + mov eax,[eax] + push eax + next +; + +code c@ ( c-addr -- c ) + pop edx + xor eax,eax + mov al,byte [edx] + push eax + next +; + +code ! ( x addr -- ) + pop edx + pop eax + mov dword [edx],eax + next +; + +code c! ( c c-addr -- ) + pop edx + pop eax + mov byte [edx],al + next +; + +\ code 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 branch ( -- ) \ threaded code: r> @ >r ; + lodsd + mov esi,eax + next +; + +code ?branch ( f -- ) \ threaded code: ?exit r> @ >r ; + pop eax + or eax,eax + jz _branchX + lea esi,[esi+4] + next +; + +code depth ( -- n ) + mov eax,data_stack + DATA_STACK_SIZE + sub eax,esp + sar eax,2 + push eax + next +; + +code sp@ ( -- x ) + push esp + next +; + +code sp! ( x -- ) + pop esp + next +; + +code rp@ ( -- x ) + push ebp + next +; + +code rp! ( x -- ) + pop ebp + next +; + +code um* ( u1 u2 -- ud ) + 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 +; + +code usleep ( c -- ) + pop eax ; eax = microseconds to sleep + + push ebp + mov ebp,esp + and esp,0xfffffff0 + sub esp,16 + + mov [esp],eax + call usleep + + mov esp,ebp + pop ebp + next +; + +\ we want the text section to be first and bss last (for linkers that output +\ sections in definition order), so it would be good to have the bss section +\ be output by the ",end" hook, but at present we cannot call "pre" from a +\ defined word, so we make do by switching to bss and then back to text again +pre +section '.data' writeable align 16 + +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 + + ; 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: + +section '.text' executable + +; diff --git a/z80/seedForth-z80.pre b/z80/seedForth-z80.pre new file mode 100644 index 0000000..c21f5d8 --- /dev/null +++ b/z80/seedForth-z80.pre @@ -0,0 +1,18 @@ +\ seedForth: less machine dependent portion +\ allows us to adjust things for direct threaded vs indirect threaded + +: compiler ( -- ) + token + ?eot + ?lit + compile, tail compiler ; + +: new ( -- xt ) + hp @ here h, lit enter , ; + +: 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> ! ; diff --git a/z80/seedForthDemoz80.seedsource b/z80/seedForthDemoz80.seedsource new file mode 100644 index 0000000..87139ac --- /dev/null +++ b/z80/seedForthDemoz80.seedsource @@ -0,0 +1,12 @@ +\ machine dependent part of seedForthDemo.seedsource +\ allows us to adjust things for direct threaded vs indirect threaded + +: >body ( xt -- body ) h@ 1 cells + ; + +: is ( xt -- ) ' >body ! ; + +Defer d1 +' ten is d1 +t{ d1 d1 d1 -> ten ten ten }t +' five is d1 +t{ d1 d1 d1 -> five five five }t diff --git a/z80/seedForthRuntimez80.seedsource b/z80/seedForthRuntimez80.seedsource new file mode 100644 index 0000000..0126e9b --- /dev/null +++ b/z80/seedForthRuntimez80.seedsource @@ -0,0 +1,19 @@ +\ machine dependent part of seedForthRuntime.seedsource +\ allows us to adjust things for direct threaded vs indirect threaded + +: >body ( xt -- body ) + h@ 1 cells + ; +' >body has-header >body + +: is ( xt -- ) \ only interactive + ' >body ! ; +' is has-header is + +\ these could not be done until here +' key is getkey +' noop is .status + +: (Does>) ( -- ) + [ ' last-xt ] Literal compile, + [ ' does> ] Literal compile, ; +' (Does>) has-header Does> immediate From af0ef29d1aaba02b591c80cd180f4d3eb1546677 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 14:48:51 +1000 Subject: [PATCH 32/41] Insert z80-specific code in /z80, and change to 16-bit and from ITC to DTC --- common/seedForth-tokenizer.fs | 2 +- common/seedForth.pre | 1 + i386/preForth-i386-rts.pre | 18 +- i386/seedForth-i386-rts.pre | 4 +- z80/Makefile | 63 ++-- z80/preForth-z80-backend.pre | 33 ++- z80/preForth-z80-rts.pre | 452 ++++++++--------------------- z80/seed | 2 +- z80/seedForth-tokenizer | 2 +- z80/seedForth-z80-header.pre | 8 +- z80/seedForth-z80-rts.pre | 398 +++++++++++++++---------- z80/seedForth-z80.pre | 23 +- z80/seedForthDemoz80.seedsource | 3 +- z80/seedForthRuntimez80.seedsource | 7 +- 14 files changed, 457 insertions(+), 559 deletions(-) diff --git a/common/seedForth-tokenizer.fs b/common/seedForth-tokenizer.fs index 6ac5ed6..e7dc889 100644 --- a/common/seedForth-tokenizer.fs +++ b/common/seedForth-tokenizer.fs @@ -130,7 +130,7 @@ Variable #tokens 0 #tokens ! ( 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 key -( 60 $3C ) Token emit Token eemit +( 60 $3C ) Token emit Token eemit Token dodoes \ generate token sequences for numbers diff --git a/common/seedForth.pre b/common/seedForth.pre index bab1729..485eb5e 100644 --- a/common/seedForth.pre +++ b/common/seedForth.pre @@ -146,4 +146,5 @@ lit key h, \ 59 41 code lit emit h, \ 60 42 code lit eemit h, \ 61 43 code + lit dodoes h, \ 62 44 interpreter bye ; diff --git a/i386/preForth-i386-rts.pre b/i386/preForth-i386-rts.pre index 9fed2a9..93e3614 100644 --- a/i386/preForth-i386-rts.pre +++ b/i386/preForth-i386-rts.pre @@ -301,15 +301,6 @@ code 0< ( x -- flag ) 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] @@ -332,6 +323,15 @@ code - ( x1 x2 -- x3 ) 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 unnest ( -- ) mov esi,[ebp] lea ebp,[ebp+4] diff --git a/i386/seedForth-i386-rts.pre b/i386/seedForth-i386-rts.pre index 2901382..6c69035 100644 --- a/i386/seedForth-i386-rts.pre +++ b/i386/seedForth-i386-rts.pre @@ -210,11 +210,13 @@ message_cant_poll: db 'can''t poll',0xa message_cant_poll_end: -section '.bss' writeable align 16 + align 4 ; dictionary pointer: points to next free location in memory _dp: dd _mem +section '.bss' writeable align 16 + ; head pointer: index of first unused head __hp: dd 0 _head: dd HEAD_SIZE dup (0) diff --git a/z80/Makefile b/z80/Makefile index 29960e2..37d9a28 100644 --- a/z80/Makefile +++ b/z80/Makefile @@ -8,10 +8,19 @@ HOSTFORTH=gforth # HOSTFORTH=sf # SwiftForth >3.7 # ------------------------------------------------------------------------ +ASZ80=../asxv5pxx/asxmak/linux/exe/asz80 +ASLINK=../asxv5pxx/asxmak/linux/exe/aslink + +# need to install intelhex package in Python first: +# pip3 install --user intelhex +HEX2BIN=python3 $(HOME)/.local/bin/hex2bin.py + +EMU_Z80=../emu_z80/emu_z80 + .PHONY: all all: \ -preForth \ -seedForth \ +preForth.bin \ +seedForth.bin \ seedForthDemo.seed \ seedForthBoot.seed \ seedForthInteractive.seed @@ -57,36 +66,18 @@ preForth-z80-backend.pre \ preForth-z80-rts.pre \ ../common/preForth-rts-nonstandard.pre \ ../common/preForth-rts.pre \ -preForth - ./preForth \ +preForth.bin + $(EMU_Z80) preForth.bin \ preForth-z80-rts.pre \ ../common/preForth-rts-nonstandard.pre \ ../common/preForth-rts.pre \ $< \ >$@ -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 - # rm $@.o -else -ifeq ($(UNIXFLAVOUR),Darwin) -# assemble and link executable on MacOS -%: %.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 +%.bin: %.asm + $(ASZ80) -l -o $< + $(ASLINK) -n -m -u -i $(<:.asm=.ihx) $(<:.asm=.rel) + $(HEX2BIN) $(<:.asm=.ihx) $@ # run preForth on its own source code to perform a bootstrap # should produce identical results @@ -96,9 +87,9 @@ preForth-z80-rts.pre \ ../common/preForth-rts.pre \ preForth-z80-backend.pre \ ../common/preForth.pre \ -preForth \ +preForth.bin \ preForth.$(EXT) - ./preForth \ + $(EMU_Z80) preForth.bin \ preForth-z80-rts.pre \ ../common/preForth-rts-nonstandard.pre \ ../common/preForth-rts.pre \ @@ -109,8 +100,8 @@ preForth-z80-backend.pre \ # preForth connected to stdin - output to stdout .PHONY: visible-bootstrap -visible-bootstrap: preForth preForth-z80-backend.pre ../common/preForth.pre - ./preForth preForth-z80-backend.pre ../common/preForth.pre +visible-bootstrap: preForth.bin preForth-z80-backend.pre ../common/preForth.pre + $(EMU_Z80) preForth.bin preForth-z80-backend.pre ../common/preForth.pre # ------------------------------------------------------------------------ # Docker support (for Linux version) @@ -134,15 +125,15 @@ seedForth-z80-header.pre \ preForth-z80-rts.pre \ seedForth-z80-rts.pre \ seedForth-z80.pre \ -../common/seedForth32bit.pre \ +../common/seedForth16bit.pre \ ../common/seedForth.pre \ -preForth - ./preForth \ +preForth.bin + $(EMU_Z80) preForth.bin \ seedForth-z80-header.pre \ preForth-z80-rts.pre \ seedForth-z80-rts.pre \ seedForth-z80.pre \ -../common/seedForth32bit.pre \ +../common/seedForth16bit.pre \ ../common/seedForth.pre \ >seedForth.$(EXT) @@ -161,7 +152,7 @@ seedForthDemoz80.seedsource seedForthBoot.seed: \ ../common/crc10.forth \ ../common/../common/seedForth-tokenizer.fs \ -../common/seedForthRuntime32bit.seedsource \ +../common/seedForthRuntime16bit.seedsource \ ../common/seedForthRuntime.seedsource \ seedForthRuntimez80.seedsource \ ../common/seedForthBoot.seedsource @@ -172,7 +163,7 @@ seedForthRuntimez80.seedsource \ seedForthInteractive.seed: \ ../common/crc10.forth \ ../common/../common/seedForth-tokenizer.fs \ -../common/seedForthRuntime32bit.seedsource \ +../common/seedForthRuntime16bit.seedsource \ ../common/seedForthRuntime.seedsource \ seedForthRuntimez80.seedsource \ ../common/seedForthInteractive.seedsource diff --git a/z80/preForth-z80-backend.pre b/z80/preForth-z80-backend.pre index 6881741..068c940 100644 --- a/z80/preForth-z80-backend.pre +++ b/z80/preForth-z80-backend.pre @@ -1,5 +1,5 @@ \ -------------------------- -\ preForth backend for i386 (32 bit) FASM +\ preForth backend for z80 (16 bit) as-z80 \ -------------------------- \ alter substitutes non-letter characters by upper case letters (to aid assemblers to deal with labels). @@ -22,12 +22,12 @@ 'P' swap '+' case? ?exit nip 'Q' swap '?' case? ?exit nip 'R' swap '"' case? ?exit nip -\ 'S' swap '!' case? ?exit nip + 'S' swap '!' case? ?exit nip 'T' swap '*' case? ?exit nip 'U' swap '(' case? ?exit nip 'V' swap '|' case? ?exit nip 'W' swap ',' case? ?exit nip - \ also 'X' for machine code + 'X' swap '@' case? ?exit nip \ may clash with 'X' suffix for machine code 'Y' swap ')' case? ?exit nip 'Z' swap ';' case? ?exit nip ; @@ -44,11 +44,14 @@ \ Output is done by emit. \ We define convenience words of the form ."xxx" to output xxx (maybe tabbed) -: ."dd" ( -- ) - tab 'd' emit 'd' emit tab ; +: ."dw" ( -- ) + tab '.' emit 'd' emit 'w' emit tab ; : ."db" ( -- ) - tab 'd' emit 'b' emit tab ; + tab '.' emit 'd' emit 'b' emit tab ; + +: ."call" ( -- ) + tab 'c' emit 'a' emit 'l' emit 'l' emit tab ; : ."nest" ( -- ) 'n' 'e' 's' 't' 4 alter show ; @@ -75,31 +78,31 @@ \ compile a reference to an invoked word : ,word ( S -- ) - ."dd" alter show cr ; + ."dw" alter show cr ; \ compile reference to nest primitive : ,nest ( -- ) - ."dd" ."nest" cr ; + ."call" ."nest" cr ; \ compile reference to unnest primitive : ,unnest ( -- ) - ."dd" ."unnest" cr cr ; + ."dw" ."unnest" cr cr ; \ compile signed number : ,n ( n -- ) - ."dd" . cr ; + ."dw" . cr ; \ compile unsigned number : ,u ( u -- ) - ."dd" u. cr ; + ."dw" u. cr ; \ compile literal : ,_lit ( S -- ) - ."dd" ."lit" cr ,word ; + ."dw" ."lit" cr ,word ; \ compile literal : ,lit ( x -- ) - ."dd" ."lit" cr ,n ; + ."dw" ."lit" cr ,n ; \ output string as comment : ,comment ( S -- ) @@ -115,8 +118,10 @@ 'X' swap 1+ ; \ ,codefield compiles the code field of primitive +\ not needed for z80 dtc implementation but define a dummy label anyway : ,codefield ( S -- ) - body _dup ,word label ; + \ body _dup ,word label ; + body label ; : ,code ( S -- ) _dup label diff --git a/z80/preForth-z80-rts.pre b/z80/preForth-z80-rts.pre index 9fed2a9..5cbffb0 100644 --- a/z80/preForth-z80-rts.pre +++ b/z80/preForth-z80-rts.pre @@ -1,398 +1,184 @@ -\ preForth runtime system - i386 (32 bit) dependent part +\ preForth runtime system - i386 (16 bit) dependent part \ -------------------------- \ \ - registers: -\ EAX, EDX general purpose -\ ESI instruction pointer -\ EBP return stack pointer -\ ESP data stack pointer +\ HL, DE general purpose +\ BC instruction pointer +\ IX return stack pointer +\ SP data stack pointer pre -;;; This is a preForth generated file using preForth-i386-backend. +;;; This is a preForth generated file using preForth-z80-backend. ;;; Only modify it, if you know what you are doing. -DATA_STACK_SIZE = 40000 -RETURN_STACK_SIZE = 40000 +DATA_STACK_SIZE = 0x1000 +RETURN_STACK_SIZE = 0x1000 -O_RDONLY = 0 -STDIN_FILENO = 0 -STDOUT_FILENO = 1 -STDERR_FILENO = 2 +STDIN_DATA = 0 +STDOUT_DATA = 1 +STDERR_DATA = 2 +STDIN_STATUS = 3 +STDOUT_STATUS = 4 +STDERR_STATUS = 5 +USLEEP_LO = 6 +USLEEP_HI = 7 +SYS_EXIT = 8 EXIT_SUCCESS = 0 EXIT_FAILURE = 1 -EOT_CHAR = 4 + .area text -format ELF +main: ld ix,return_stack + RETURN_STACK_SIZE + ld sp,data_stack + DATA_STACK_SIZE + ld bc,main1 + jp next -section '.text' executable - -public main -extrn close -extrn exit -extrn open -extrn read -extrn strcmp -extrn strlen -extrn write - -macro next { - lodsd - jmp dword [eax] -} - -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 - -_nest: lea ebp,[ebp-4] - mov [ebp],esi - lea esi,[eax+4] - next +main1: .dw _cold + .dw _bye ; code bye ( -- ) - and esp,0xfffffff0 - sub esp,16 - - mov dword [esp],EXIT_SUCCESS - call exit ; exit(EXIT_SUCCESS) + ld a,EXIT_SUCCESS + out (SYS_EXIT),a ; code emit ( 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],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 + pop hl + ld a,l + out (STDOUT_DATA),a + jr 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 + pop hl + ld a,l + out (STDERR_DATA),a + jr next ; 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 - - mov esp,ebp - pop ebp - - push eax - next + in a,(STDIN_DATA) + ld l,a + ld h,0 + push hl + jr next ; code dup ( x -- x x ) - pop eax - push eax - push eax - next + pop hl + push hl + push hl + jr next ; code swap ( x y -- y x ) - pop edx - pop eax - push edx - push eax - next + pop de + pop hl + push de + push hl + jr next ; code drop ( x -- ) - pop eax - next + pop hl + jr next ; code 0< ( x -- flag ) - pop eax - sar eax,31 - push eax - next + pop hl + add hl,hl + ld hl, 0 + jr nc,zless1 + dec hl +zless1: push hl + jr 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 ?exit ( f -- ) + pop hl + ld a,l + or h + jr z,next + ; fall into unnest +; + +code unnest ( -- ) + ld c,(ix) + inc ix + ld b,(ix) + inc ix + jr next ; code >r ( x -- ) ( R -- x ) - pop ebx - lea ebp,[ebp-4] - mov [ebp],ebx - next + pop hl + dec ix + ld (ix),h + dec ix + ld (ix),l + jr next ; code r> ( R x -- ) ( -- x ) - mov eax,[ebp] - lea ebp,[ebp+4] - push eax - next + ld l,(ix) + inc ix + ld h,(ix) + inc ix + push hl + jr next ; code - ( x1 x2 -- x3 ) - pop edx - pop eax - sub eax,edx - push eax - next -; - -code unnest ( -- ) - mov esi,[ebp] - lea ebp,[ebp+4] - next + pop de + pop hl + or a + sbc hl,de + push hl + jr next +; + +\ put this in middle of the primitives to make it reachable by jr +code nest ( -- ) + dec ix + ld (ix),b + dec ix + ld (ix),c + pop bc +next: ld a,(bc) + ld l,a + inc bc + ld a,(bc) + ld h,a + inc bc + jp (hl) ; code lit ( -- ) - lodsd - push eax - next + ld a,(bc) + ld l,a + inc bc + ld a,(bc) + ld h,a + inc bc + push hl + jr next ; \ we want the text section to be first and bss last (for linkers that output \ sections in definition order), so it would be good to have the bss section \ be output by the ",end" hook, but at present we cannot call "pre" from a \ defined word, so we make do by switching to bss and then back to text again -pre -section '.data' writeable align 16 - -message_cant_open: - db 'can''t open: ' -message_cant_open_end: - -message_newline: - db 0xa -message_newline_end: - -message_cant_read: - db 'can''t read',0xa -message_cant_read_end: - -message_cant_write: - db 'can''t write',0xa -message_cant_write_end: - -dash_c_str: - db '-',0 - align 4 - -default_argv: - dd 0 ; argv[0] - dd dash_c_str -default_argv_end: - -; default command line arguments, overwritten if any passed in -argc: dd (default_argv_end - default_argv) / 4 -argv: dd default_argv - -; argument number being processed, fd_in is valid if argn < argc -argn: dd 1 - -section '.bss' writeable align 16 - -fd_in: dd 0 +pre + .area bss -data_stack: - db DATA_STACK_SIZE dup (0) return_stack: - db RETURN_STACK_SIZE dup (0) + .ds RETURN_STACK_SIZE +data_stack: + .ds DATA_STACK_SIZE -section '.text' executable + .area text ; diff --git a/z80/seed b/z80/seed index dd58d16..95defad 100755 --- a/z80/seed +++ b/z80/seed @@ -1,4 +1,4 @@ #!/bin/bash stty raw -echo -./seedForth seedForthInteractive.seed ../common/runtime.forth ../common/hi16bit.forth ../common/hi.forth - +../emu_z80/emu_z80 seedForth.bin seedForthInteractive.seed ../common/runtime.forth ../common/hi16bit.forth ../common/hi.forth - stty sane diff --git a/z80/seedForth-tokenizer b/z80/seedForth-tokenizer index 942d967..645a590 100755 --- a/z80/seedForth-tokenizer +++ b/z80/seedForth-tokenizer @@ -1,2 +1,2 @@ #!/bin/sh -./seedForth seedForthBoot.seed ../common/runtime.forth ../common/crc10.forth ../common/seedForth-tokenizer.fs - +../emu_z80/emu_z80 seedForth.bin seedForthBoot.seed ../common/runtime.forth ../common/crc10.forth ../common/seedForth-tokenizer.fs - diff --git a/z80/seedForth-z80-header.pre b/z80/seedForth-z80-header.pre index bddc8e3..2f97d33 100644 --- a/z80/seedForth-z80-header.pre +++ b/z80/seedForth-z80-header.pre @@ -9,16 +9,14 @@ pre ;;; This is seedForth - a small potentially interactive Forth, that dynamically ;;; bootstraps from a minimal kernel. ;;; -;;; cat seedForth.seed - | ./seedForth +;;; cat seedForth.seed - | ../z80_emu/z80_emu seedForth.bin ;;; ;;; .seed files are in byte-tokenized source code format. ;;; ;;; Use the seedForth tokenizer to convert human readable source code to ;;; byte-token form. -HEAD_SIZE = 40000 -MEM_SIZE = 400000 - -POLLIN = 1 +HEAD_SIZE = 4000 +MEM_SIZE = 40000 ; diff --git a/z80/seedForth-z80-rts.pre b/z80/seedForth-z80-rts.pre index 2901382..2eaf38d 100644 --- a/z80/seedForth-z80-rts.pre +++ b/z80/seedForth-z80-rts.pre @@ -1,202 +1,282 @@ \ seedForth: machine dependent portion -\ interpreter and basic asm primitives are taken from preForth-i386-rts.pre, +\ interpreter and basic asm primitives are taken from preForth-z80-rts.pre, \ and then this file defines additional primitives (arithmetic, memory, etc) +\ note: we arrive at _dodoes by a sequence of 2 calls, the return +\ address stacked by first call points to some instance data, and +\ the return address stacked by second call (to _dodoes) points to +\ high level forth code which is going to operate on that instance +\ data -- we simply leave the instance data's address stacked for +\ the high level forth code and then "execute" the high level forth +\ code, which means that _dodoes is the same as _enter in our case +\ note: similarly, arriving at _dovar we just leave address stacked pre -extrn poll -extrn usleep - _enter = _nest +_exit = _unnest -_dodoes: ; ( -- addr ) - 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 +_dodoes = _nest +_dovar = next ; code key? ( -- f ) - push ebp - mov ebp,esp - and esp,0xfffffff0 - sub esp,32 - - ; if all arguments exhausted, return ready - ; this allows application to collect the EOT character - mov eax,[argn] - cmp eax,[argc] - jae keyq_ready - - mov eax,[fd_in] - mov dword [esp+12],eax - mov dword [esp+16],POLLIN ; struct pollfd fd = {fd_in, POLLIN, 0} - - lea eax,[esp+12] - mov [esp],eax - mov dword [esp+4],1 - mov dword [esp+8],0 - call poll ; eax = poll(&fd, 1, 0) - cmp eax,-1 - jnz keyq_ok - - mov dword [esp],STDERR_FILENO - mov dword [esp+4],message_cant_poll - mov dword [esp+8],message_cant_poll_end - message_cant_poll - call write ; write(STDERR_FILENO, "can't poll\n", 11) - - mov dword [esp],EXIT_FAILURE - call exit ; exit(EXIT_FAILURE) - -keyq_ok: - sub eax,eax - test word [esp+18],POLLIN ; fd.revents & POLLIN - jz keyq_done -keyq_ready: - mov eax,-1 -keyq_done: - - mov esp,ebp - pop ebp - - push eax - next + in a,(STDIN_STATUS) + ld l,a + ld h,0 + push hl + jr next ; code or ( x1 x2 -- x3 ) - pop edx - pop eax - or eax,edx - push eax - next + pop de + pop hl + ld a,l + or e + ld l,a + ld a,h + or d + ld h,a + push hl + jr next ; code and ( x1 x2 -- x3 ) - pop edx - pop eax - and eax,edx - push eax - next -; - -pre -_exit = _unnest + pop de + pop hl + ld a,l + and e + ld l,a + ld a,h + and d + ld h,a + push hl + jr next ; code @ ( addr -- x ) - pop eax - mov eax,[eax] - push eax - next + pop hl + ld e,(hl) + inc hl + ld d,(hl) + push de + jr next ; code c@ ( c-addr -- c ) - pop edx - xor eax,eax - mov al,byte [edx] - push eax - next + pop hl + ld e,(hl) + ld d,0 + push de + jr next ; code ! ( x addr -- ) - pop edx - pop eax - mov dword [edx],eax - next + pop hl + pop de + ld (hl),e + inc hl + ld (hl),d + jr next ; code c! ( c c-addr -- ) - pop edx - pop eax - mov byte [edx],al - next + pop hl + pop de + ld (hl),e + jr 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 hl + add hl,hl + ld de,_head + add hl,de + ld a,(hl) + inc hl + ld h,(hl) + ld l,a + jp (hl) ; code branch ( -- ) \ threaded code: r> @ >r ; - lodsd - mov esi,eax - next + ld l,c + ld h,b + ld c,(hl) + inc hl + ld b,(hl) + jr next ; code ?branch ( f -- ) \ threaded code: ?exit r> @ >r ; - pop eax - or eax,eax - jz _branchX - lea esi,[esi+4] - next + pop hl + ld a,l + or h + jr z,_branch + inc bc + inc bc + jr next ; code depth ( -- n ) - mov eax,data_stack + DATA_STACK_SIZE - sub eax,esp - sar eax,2 - push eax - next + ld hl,data_stack + DATA_STACK_SIZE + or a + sbc hl,sp ; should leave cf = 0 + rr h + rr l + push hl + jr next1 ; code sp@ ( -- x ) - push esp - next + ld hl,0 + add hl,sp + push hl + jr next1 ; code sp! ( x -- ) - pop esp - next + pop hl + ld sp,hl + jr next1 ; code rp@ ( -- x ) - push ebp - next + push ix + jr next1 ; code rp! ( x -- ) - pop ebp - next + pop ix + jr next1 ; code um* ( u1 u2 -- ud ) - pop edx - pop eax - mul edx - push eax - push edx - next + exx ; preserve bc + + pop de ; pop u2 + pop bc ; pop u1 +; ld l,c +; ld h,b +; call print_hexw +; ld a,0x2a +; call print_char +; ld l,e +; ld h,d +; call print_hexw + + sub a ; clears cf + ld l,a + ld h,a + ld a,b + ld b,16 + or a +umul_loop: + rra + rr c + jr nc,umul_skip + add hl,de ; can't overflow, leaves cf = 0 +umul_skip: + rr h + rr l + djnz umul_loop + rra + rr c + ld b,a +; ld a,0x3d +; call print_char +; push hl +; call print_hexw +; ld l,c +; ld h,b +; call print_hexw +; pop hl +; ld a,0xa +; call print_char + + push bc ; push ud lo + push hl ; push ud hi + + exx + jr next1 ; code um/mod ( ud u1 -- u2 u3 ) - pop ebx - pop edx - pop eax - div ebx - push edx - push eax - next + exx ; preserve bc + + pop bc ; pop u1 + pop hl ; pop ud hi + pop de ; pop ud lo +; push hl +; call print_hexw +; ld l,e +; ld h,d +; call print_hexw +; ld a,0x2f +; call print_char +; ld l,c +; ld h,b +; call print_hexw +; pop hl + + ld a,16 + or a +udiv_loop: + ex de,hl + adc hl,hl + ex de,hl + adc hl,hl + jr nc,udiv_test + ; shift left has overflowed, so we can always subtract bc, and + ; always cf=1 to indicate subtraction went, record cf in quotient + sbc hl,bc + jr udiv_cont +udiv_test: + ; shift left has not overflowed, see if we can subtract bc, cf=0 + ; indicates subtraction went, record complement of cf in quotient + sbc hl,bc + jr nc,udiv_goes + add hl,bc +udiv_goes: + ccf +udiv_cont: + dec a + jr nz,udiv_loop + ex de,hl + adc hl,hl ; record final quotient bit +; ld a,0x3d +; call print_char +; push hl +; call print_hexw +; ld a,0x72 +; call print_char +; ld l,e +; ld h,d +; call print_hexw +; pop hl +; ld a,0xa +; call print_char + + push de ; push u2 (remainder) + push hl ; push u1 (quotient) + + exx + jr next1 ; code usleep ( c -- ) - pop eax ; eax = microseconds to sleep - - push ebp - mov ebp,esp - and esp,0xfffffff0 - sub esp,16 - - mov [esp],eax - call usleep - - mov esp,ebp - pop ebp - next + pop hl + ld a,l + out (USLEEP_LO),a + ld a,h + out (USLEEP_HI),a +next1: ld a,(bc) + ld l,a + inc bc + ld a,(bc) + ld h,a + inc bc + jp (hl) ; \ we want the text section to be first and bss last (for linkers that output @@ -204,25 +284,43 @@ 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 '.data' writeable align 16 - -message_cant_poll: - db 'can''t poll',0xa -message_cant_poll_end: - -section '.bss' writeable align 16 +;print_hexw: +; ld a,h +; call print_hexb +; ld a,l +;print_hexb: +; push af +; rrca +; rrca +; rrca +; rrca +; call print_hexn +; pop af +;print_hexn: +; and 0xf +; add a,0x30 +; cp 0x3a +; jr c,print_char +; add a,0x41 - 0x3a +;print_char: +; out (STDOUT_PORT),a +; ret + + .area data ; dictionary pointer: points to next free location in memory -_dp: dd _mem +_dp: .dw _mem + + .area bss ; head pointer: index of first unused head -__hp: dd 0 -_head: dd HEAD_SIZE dup (0) +__hp: .dw 0 +_head: .ds HEAD_SIZE*2 ; free memory starts at _mem -_mem: db MEM_SIZE dup (0) +_mem: .ds MEM_SIZE _memtop: -section '.text' executable + .area text ; diff --git a/z80/seedForth-z80.pre b/z80/seedForth-z80.pre index c21f5d8..b9b3e18 100644 --- a/z80/seedForth-z80.pre +++ b/z80/seedForth-z80.pre @@ -1,18 +1,31 @@ \ seedForth: less machine dependent portion \ allows us to adjust things for direct threaded vs indirect threaded +\ insert "call _dodoes" after each "does>" token +: ?does> ( xt -- xt | ) + dup h@ lit does> - ?exit \ not does> token: exit i.e. normal compile action + h@ , 205 c, lit dodoes , \ generate word of does> and instruction of call + r> drop tail compiler ; + : compiler ( -- ) token ?eot ?lit + ?does> compile, tail compiler ; +\ for z80 dtc implementation, compile "call _enter" before high level code : new ( -- xt ) - hp @ here h, lit enter , ; + hp @ here h, 205 c, lit enter , ; +\ for z80 dtc implementation, compile "call _dovar" before data field of new +\ word, the "_dovar" will be changed the address of "call _dodoes" if needed : create ( -- xt ) - 0 , \ dummy does> field - hp @ here h, lit dovar , ; + hp @ here h, 205 c, lit dovar , ; -: does> ( xt -- ) \ set code field of last defined word - r> swap h@ dup >r 1 cells - ! lit dodoes r> ! ; +\ for does> we do not execute the remainder of the routine, instead we pop +\ the return stack and plug the resulting number into the word being compiled, +\ so that this word will execute the remainder of the routine when invoked +\ (and note remainder of the routine has been prefixed with a "call _dodoes") +: does> ( xt -- ) \ replace "_dovar" in "call _dovar" with return stack addr + r> swap h@ 1 + ! ; diff --git a/z80/seedForthDemoz80.seedsource b/z80/seedForthDemoz80.seedsource index 87139ac..72d2fac 100644 --- a/z80/seedForthDemoz80.seedsource +++ b/z80/seedForthDemoz80.seedsource @@ -1,7 +1,8 @@ \ machine dependent part of seedForthDemo.seedsource \ allows us to adjust things for direct threaded vs indirect threaded -: >body ( xt -- body ) h@ 1 cells + ; +\ we must index past the "call" instruction +: >body ( xt -- body ) h@ 1 + 1 cells + ; : is ( xt -- ) ' >body ! ; diff --git a/z80/seedForthRuntimez80.seedsource b/z80/seedForthRuntimez80.seedsource index 0126e9b..dc88646 100644 --- a/z80/seedForthRuntimez80.seedsource +++ b/z80/seedForthRuntimez80.seedsource @@ -1,8 +1,9 @@ \ machine dependent part of seedForthRuntime.seedsource \ allows us to adjust things for direct threaded vs indirect threaded +\ we must index past the "call" instruction : >body ( xt -- body ) - h@ 1 cells + ; + h@ 1 + 1 cells + ; ' >body has-header >body : is ( xt -- ) \ only interactive @@ -13,7 +14,9 @@ ' key is getkey ' noop is .status +\ insert "call _dodoes" after each "does>" token : (Does>) ( -- ) [ ' last-xt ] Literal compile, - [ ' does> ] Literal compile, ; + [ ' does> ] Literal compile, + 205 c, [ ' dodoes ] Literal compile, ; ' (Does>) has-header Does> immediate From 7ef4d88c384dc951872d174d61252d4f4cd2f4ae Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 16:07:49 +1000 Subject: [PATCH 33/41] Hack in /emu_z80 to make everything inline and multiple instructions executed --- .gitmodules | 2 +- emu_z80/Makefile | 4 ++-- emu_z80/emu_z80.c | 37 +++++++++++++++++++------------------ emu_z80/z80 | 2 +- 4 files changed, 23 insertions(+), 22 deletions(-) diff --git a/.gitmodules b/.gitmodules index 9bed4cf..edcd001 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,6 +1,6 @@ [submodule "emu_z80/z80"] path = emu_z80/z80 - url = https://github.com/superzazu/z80.git + url = https://github.com/nickd4/z80.git [submodule "asxv5pxx"] path = asxv5pxx url = https://github.com/nickd4/asxv5pxx.git diff --git a/emu_z80/Makefile b/emu_z80/Makefile index 6b61c69..b6d4957 100644 --- a/emu_z80/Makefile +++ b/emu_z80/Makefile @@ -1,4 +1,4 @@ -CFLAGS=-g -Wall +CFLAGS=-g -Wall -O3 LDFLAGS=-g ASZ80=../asxv5pxx/asxmak/linux/exe/asz80 @@ -25,4 +25,4 @@ test.rel: test.asm .PHONY: clean clean: - rm -f *.bin *.hlr *.ihx *.lst *.map *.o *.rel *.rst emu_z80 + rm -f *.bin *.hlr *.ihx *.lst *.map *.o *.rel *.rst emu_z80 z80/*.o diff --git a/emu_z80/emu_z80.c b/emu_z80/emu_z80.c index 0991260..193141a 100644 --- a/emu_z80/emu_z80.c +++ b/emu_z80/emu_z80.c @@ -18,8 +18,6 @@ #define SYS_EXIT 8 z80 cpu; -bool timing; -long nb_instructions; int stdin_fd; int g_argn = 0; @@ -30,6 +28,7 @@ const char **g_argv = &default_argv; #define MEMORY_SIZE 0x10000 uint8_t memory[MEMORY_SIZE]; uint8_t usleep_lo; +int exit_flag; uint8_t rb(void *userdata, uint16_t addr) { return memory[addr]; @@ -135,19 +134,15 @@ void out(z80 *const z, uint8_t port, uint8_t val) { usleep(usleep_lo | (val << 8)); break; case SYS_EXIT: - if (timing) - fprintf( - stderr, - "%lu instructions executed on %lu cycles\n", - nb_instructions, - cpu.cyc - ); - exit(val); + exit_flag = val | 0x100; + cpu.halted = true; + break; } } int main(int argc, char **argv) { int argn = 1; + bool timing = false; if (argn < argc && strcmp(argv[argn], "-t") == 0) { timing = true; ++argn; @@ -185,12 +180,18 @@ int main(int argc, char **argv) { cpu.port_in = in; cpu.port_out = out; - while (true) { - ++nb_instructions; - - // warning: the following line will output dozens of GB of data. - //z80_debug_output(&cpu); - - z80_step(&cpu); - } + long n, nb_instructions = 0; + do { + n = z80_step(&cpu, 1000); + nb_instructions += n; + } while (n >= 1000); + + if (timing) + fprintf( + stderr, + "%lu instructions executed on %lu cycles\n", + nb_instructions, + cpu.cyc + ); + exit(exit_flag & 0xff); } diff --git a/emu_z80/z80 b/emu_z80/z80 index d64fe10..ae62511 160000 --- a/emu_z80/z80 +++ b/emu_z80/z80 @@ -1 +1 @@ -Subproject commit d64fe10a2274e5e40019b1086bf7d8990cbc5f23 +Subproject commit ae625116f1f9b013fd1a69d0173f8207f8703e21 From baae866ce7610597372b1a18f3534f32cdd0daba Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 18:11:04 +1000 Subject: [PATCH 34/41] Fix typo in /emu_z80/Makefile --- emu_z80/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/emu_z80/Makefile b/emu_z80/Makefile index b6d4957..ec9cf98 100644 --- a/emu_z80/Makefile +++ b/emu_z80/Makefile @@ -11,7 +11,7 @@ HEX2BIN=python3 $(HOME)/.local/bin/hex2bin.py .PHONY: all all: emu_z80 test.bin -emu_z80: emu_z80.o z80/z80.o z80/z80.o +emu_z80: emu_z80.o z80/z80.o $(CC) $(LDFLAGS) -o $@ $^ test.bin: test.ihx From 1858907daf39133c44fc544affaf48b9946b0432 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 19:07:05 +1000 Subject: [PATCH 35/41] Add accidentally .gitignored /emu_z80/test.asm --- .gitignore | 5 +++- emu_z80/test.asm | 62 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 66 insertions(+), 1 deletion(-) create mode 100644 emu_z80/test.asm diff --git a/.gitignore b/.gitignore index 0bad648..39cdbd4 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,3 @@ -*.asm *.bin *.hlr *.ihx @@ -11,8 +10,12 @@ /common/crc10.forth /emu_z80/emu_z80 /i386/preForth +/i386/preForth.asm /i386/seedForth +/i386/seedForth.asm /i386/__temp__.fs /z80/preForth +/z80/preForth.asm /z80/seedForth +/z80/seedForth.asm /z80/__temp__.fs diff --git a/emu_z80/test.asm b/emu_z80/test.asm new file mode 100644 index 0000000..eeffe3a --- /dev/null +++ b/emu_z80/test.asm @@ -0,0 +1,62 @@ +STDIN_DATA = 0 +STDOUT_DATA = 1 +STDERR_DATA = 2 +STDIN_STATUS = 3 +STDOUT_STATUS = 4 +STDERR_STATUS = 5 +USLEEP_LO = 6 +USLEEP_HI = 7 +SYS_EXIT = 8 + + .area text + + ld hl,message + ld b,message_end - message +print_message: + ld a,(hl) + inc hl + out (STDERR_DATA),a + djnz print_message + +in_wait: + in a,(STDIN_STATUS) + or a + jr nz,in_char + + ld a,>1000 + out (USLEEP_LO),a + ld a,<1000 + out (USLEEP_HI),a + jr in_wait + +in_char: + in a,(STDIN_DATA) + cp 4 ; EOT + jr z,done + + ld e,a + +out_wait: + in a,(STDOUT_STATUS) + or a + jr nz,out_char + + ld a,>1000 + out (USLEEP_LO),a + ld a,<1000 + out (USLEEP_HI),a + jr out_wait + +out_char: + ld a,e + out (STDOUT_DATA),a + jr in_wait + +done: ld a,0 + out (SYS_EXIT),a + + .area text + +message: + .db 'h,'e,'l,'l,'o,',,' ,'w,'o,'r,'l,'d,'!,0xa +message_end: From 18b4cf378cd2b5e8061c438d82da9ef5834bbd14 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 23:05:10 +1000 Subject: [PATCH 36/41] Improve appearance of z80 generated code slightly --- z80/preForth-z80-backend.pre | 10 +++++----- z80/preForth-z80-rts.pre | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/z80/preForth-z80-backend.pre b/z80/preForth-z80-backend.pre index 068c940..4cac9a7 100644 --- a/z80/preForth-z80-backend.pre +++ b/z80/preForth-z80-backend.pre @@ -118,14 +118,14 @@ 'X' swap 1+ ; \ ,codefield compiles the code field of primitive -\ not needed for z80 dtc implementation but define a dummy label anyway -: ,codefield ( S -- ) - \ body _dup ,word label ; - body label ; +\ for z80, for asm words there is only a body, so omit the body label +\ : ,codefield ( S -- ) +\ \ body _dup ,word label ; +\ body label ; : ,code ( S -- ) _dup label - ,codefield ; + ; \ ,codefield ; : ,end-code ( -- ) cr ; diff --git a/z80/preForth-z80-rts.pre b/z80/preForth-z80-rts.pre index 5cbffb0..3825a54 100644 --- a/z80/preForth-z80-rts.pre +++ b/z80/preForth-z80-rts.pre @@ -89,7 +89,7 @@ code drop ( x -- ) code 0< ( x -- flag ) pop hl add hl,hl - ld hl, 0 + ld hl,0 jr nc,zless1 dec hl zless1: push hl From c3f211f2c3d630abd97d35d26352e4356d8a1f6d Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 23:22:34 +1000 Subject: [PATCH 37/41] Fix asxxxx < > syntax in /z80/test.asm --- emu_z80/test.asm | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/emu_z80/test.asm b/emu_z80/test.asm index eeffe3a..cf9aa68 100644 --- a/emu_z80/test.asm +++ b/emu_z80/test.asm @@ -23,9 +23,9 @@ in_wait: or a jr nz,in_char - ld a,>1000 - out (USLEEP_LO),a ld a,<1000 + out (USLEEP_LO),a + ld a,>1000 out (USLEEP_HI),a jr in_wait @@ -41,9 +41,9 @@ out_wait: or a jr nz,out_char - ld a,>1000 - out (USLEEP_LO),a ld a,<1000 + out (USLEEP_LO),a + ld a,>1000 out (USLEEP_HI),a jr out_wait @@ -58,5 +58,6 @@ done: ld a,0 .area text message: - .db 'h,'e,'l,'l,'o,',,' ,'w,'o,'r,'l,'d,'!,0xa + .ascii /hello, world/ + .db 0xa message_end: From 83a8c33682b867fa327064ab8ccd7c4bc0ebf259 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Thu, 28 Apr 2022 12:53:23 +1000 Subject: [PATCH 38/41] Add preForthDemo build using host Forth (for debugging a new preForth runtime) --- .gitignore | 5 ++-- i386/Makefile | 49 ++++++++++++++++++++++++++++---------- z80/Makefile | 51 ++++++++++++++++++++++++++++++---------- z80/preForth-z80-rts.pre | 1 - 4 files changed, 78 insertions(+), 28 deletions(-) diff --git a/.gitignore b/.gitignore index 39cdbd4..9722f3a 100644 --- a/.gitignore +++ b/.gitignore @@ -11,11 +11,12 @@ /emu_z80/emu_z80 /i386/preForth /i386/preForth.asm +/i386/preForthDemo +/i386/preForthDemo.asm /i386/seedForth /i386/seedForth.asm /i386/__temp__.fs -/z80/preForth /z80/preForth.asm -/z80/seedForth +/z80/preForthDemo.asm /z80/seedForth.asm /z80/__temp__.fs diff --git a/i386/Makefile b/i386/Makefile index f931460..c2429db 100644 --- a/i386/Makefile +++ b/i386/Makefile @@ -1,6 +1,6 @@ # Makefile for preForth and seedForth # -# make bootstrap should produce two identical files: preForth1.asm and preForth.asm +# make bootstrap should produce two identical files: preForth1.$(ASM) and preForth.$(ASM) # Set HOSTFORTH to the Forth system that generates the initial preForth # ------------------------------------------------------------------------ @@ -10,6 +10,7 @@ HOSTFORTH=gforth .PHONY: all all: \ +preForthDemo \ preForth \ seedForth \ seedForthDemo.seed \ @@ -28,9 +29,33 @@ runseedforthinteractive: seedForth seedForthInteractive.seed ./seed UNIXFLAVOUR=$(shell uname -s) -EXT=asm +ASM=asm -preForth.asm: \ +# build preForthDemo via the host Forth first, so that it +# can be used for basic debugging of the preForth runtime +preForthDemo.$(ASM): \ +../common/preForth-bootstrap.fs \ +../common/preForth-cold.fs \ +preForth-i386-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth-i386-backend.pre \ +../common/preForth.pre \ +../common/preForthDemo.pre + cat \ +preForth-i386-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +../common/preForthDemo.pre \ +|$(HOSTFORTH) \ +../common/preForth-bootstrap.fs \ +../common/preForth-rts-nonstandard.pre \ +preForth-i386-backend.pre \ +../common/preForth.pre \ +../common/preForth-cold.fs \ +>$@ + +preForth.$(ASM): \ ../common/preForth-bootstrap.fs \ ../common/preForth-cold.fs \ preForth-i386-rts.pre \ @@ -52,7 +77,7 @@ preForth-i386-backend.pre \ ../common/preForth-cold.fs \ >$@ -%.asm: \ +%.$(ASM): \ %.pre \ preForth-i386-rts.pre \ ../common/preForth-rts-nonstandard.pre \ @@ -67,7 +92,7 @@ $< \ ifeq ($(UNIXFLAVOUR),Linux) # assemble and link executable on linux -%: %.asm +%: %.$(ASM) fasm $< $@.o LDEMULATION=elf_i386 ld -arch i386 -o $@ \ -dynamic-linker /lib32/ld-linux.so.2 \ @@ -78,7 +103,7 @@ $@.o \ else ifeq ($(UNIXFLAVOUR),Darwin) # assemble and link executable on MacOS -%: %.asm +%: %.$(ASM) fasm $< $@.o objconv -fmacho32 -nu $@.o $@_m.o ld -arch i386 -macosx_version_min 10.6 -o $@ \ @@ -97,15 +122,15 @@ preForth-i386-rts.pre \ preForth-i386-backend.pre \ ../common/preForth.pre \ preForth \ -preForth.$(EXT) +preForth.$(ASM) ./preForth \ preForth-i386-rts.pre \ ../common/preForth-rts-nonstandard.pre \ ../common/preForth-rts.pre \ preForth-i386-backend.pre \ ../common/preForth.pre \ ->preForth1.$(EXT) - cmp preForth.$(EXT) preForth1.$(EXT) +>preForth1.$(ASM) + cmp preForth.$(ASM) preForth1.$(ASM) # preForth connected to stdin - output to stdout .PHONY: visible-bootstrap @@ -129,7 +154,7 @@ rundocker: docker-image # ------------------------------------------------------------------------ # seedForth # ------------------------------------------------------------------------ -seedForth.$(EXT): \ +seedForth.$(ASM): \ seedForth-i386-header.pre \ preForth-i386-rts.pre \ seedForth-i386-rts.pre \ @@ -144,7 +169,7 @@ seedForth-i386-rts.pre \ seedForth-i386.pre \ ../common/seedForth32bit.pre \ ../common/seedForth.pre \ ->seedForth.$(EXT) +>seedForth.$(ASM) # a little ugly, because gforth insists upon echoing anything read from # stdin, and also does not allow parsing words to cross a file boundary, @@ -182,4 +207,4 @@ seedForthRuntimei386.seedsource \ .PHONY: clean clean: - rm -f *.asm *.o *.seed preForthdemo preForth seedForth __temp__.fs + rm -f *.$(ASM) *.o *.seed preForthDemo preForth seedForth __temp__.fs diff --git a/z80/Makefile b/z80/Makefile index 37d9a28..60831cd 100644 --- a/z80/Makefile +++ b/z80/Makefile @@ -1,6 +1,6 @@ # Makefile for preForth and seedForth # -# make bootstrap should produce two identical files: preForth1.asm and preForth.asm +# make bootstrap should produce two identical files: preForth1.$(ASM) and preForth.$(ASM) # Set HOSTFORTH to the Forth system that generates the initial preForth # ------------------------------------------------------------------------ @@ -19,6 +19,7 @@ EMU_Z80=../emu_z80/emu_z80 .PHONY: all all: \ +preForthDemo.bin \ preForth.bin \ seedForth.bin \ seedForthDemo.seed \ @@ -37,9 +38,33 @@ runseedforthinteractive: seedForth seedForthInteractive.seed ./seed UNIXFLAVOUR=$(shell uname -s) -EXT=asm +ASM=asm -preForth.asm: \ +# build preForthDemo via the host Forth first, so that it +# can be used for basic debugging of the preForth runtime +preForthDemo.$(ASM): \ +../common/preForth-bootstrap.fs \ +../common/preForth-cold.fs \ +preForth-z80-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth-z80-backend.pre \ +../common/preForth.pre \ +../common/preForthDemo.pre + cat \ +preForth-z80-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +../common/preForthDemo.pre \ +|$(HOSTFORTH) \ +../common/preForth-bootstrap.fs \ +../common/preForth-rts-nonstandard.pre \ +preForth-z80-backend.pre \ +../common/preForth.pre \ +../common/preForth-cold.fs \ +>$@ + +preForth.$(ASM): \ ../common/preForth-bootstrap.fs \ ../common/preForth-cold.fs \ preForth-z80-rts.pre \ @@ -61,7 +86,7 @@ preForth-z80-backend.pre \ ../common/preForth-cold.fs \ >$@ -%.asm: \ +%.$(ASM): \ %.pre \ preForth-z80-rts.pre \ ../common/preForth-rts-nonstandard.pre \ @@ -74,10 +99,10 @@ preForth-z80-rts.pre \ $< \ >$@ -%.bin: %.asm +%.bin: %.$(ASM) $(ASZ80) -l -o $< - $(ASLINK) -n -m -u -i $(<:.asm=.ihx) $(<:.asm=.rel) - $(HEX2BIN) $(<:.asm=.ihx) $@ + $(ASLINK) -n -m -u -i $(<:.$(ASM)=.ihx) $(<:.$(ASM)=.rel) + $(HEX2BIN) $(<:.$(ASM)=.ihx) $@ # run preForth on its own source code to perform a bootstrap # should produce identical results @@ -88,15 +113,15 @@ preForth-z80-rts.pre \ preForth-z80-backend.pre \ ../common/preForth.pre \ preForth.bin \ -preForth.$(EXT) +preForth.$(ASM) $(EMU_Z80) preForth.bin \ preForth-z80-rts.pre \ ../common/preForth-rts-nonstandard.pre \ ../common/preForth-rts.pre \ preForth-z80-backend.pre \ ../common/preForth.pre \ ->preForth1.$(EXT) - cmp preForth.$(EXT) preForth1.$(EXT) +>preForth1.$(ASM) + cmp preForth.$(ASM) preForth1.$(ASM) # preForth connected to stdin - output to stdout .PHONY: visible-bootstrap @@ -120,7 +145,7 @@ rundocker: docker-image # ------------------------------------------------------------------------ # seedForth # ------------------------------------------------------------------------ -seedForth.$(EXT): \ +seedForth.$(ASM): \ seedForth-z80-header.pre \ preForth-z80-rts.pre \ seedForth-z80-rts.pre \ @@ -135,7 +160,7 @@ seedForth-z80-rts.pre \ seedForth-z80.pre \ ../common/seedForth16bit.pre \ ../common/seedForth.pre \ ->seedForth.$(EXT) +>seedForth.$(ASM) # a little ugly, because gforth insists upon echoing anything read from # stdin, and also does not allow parsing words to cross a file boundary, @@ -173,4 +198,4 @@ seedForthRuntimez80.seedsource \ .PHONY: clean clean: - rm -f *.asm *.o *.seed preForthdemo preForth seedForth __temp__.fs + rm -f *.$(ASM) *.o *.seed preForthDemo preForth seedForth __temp__.fs diff --git a/z80/preForth-z80-rts.pre b/z80/preForth-z80-rts.pre index 3825a54..0475322 100644 --- a/z80/preForth-z80-rts.pre +++ b/z80/preForth-z80-rts.pre @@ -170,7 +170,6 @@ code lit ( -- ) \ 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 .area bss From ced4375ba723a127aa3235b90eb4425c1e0751fc Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Thu, 28 Apr 2022 14:54:45 +1000 Subject: [PATCH 39/41] Fix some missing tests in seedForthDemo after separating machine dependent part --- common/seedForthDemo.seedsource | 11 +++-------- i386/seedForthDemoi386.seedsource | 2 ++ z80/seedForthDemoz80.seedsource | 2 ++ 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/common/seedForthDemo.seedsource b/common/seedForthDemo.seedsource index e25a071..805b0a7 100644 --- a/common/seedForthDemo.seedsource +++ b/common/seedForthDemo.seedsource @@ -381,12 +381,7 @@ Definer Array ( n -- ) t{ 60 5 a ! 0 a @ 1 a @ 2 a @ 3 a @ 4 a @ 5 a @ -> 10 20 30 40 50 60 }t -: done ( -- ) cr ." done" cr ; done +: done ( -- ) cr ." done" cr ; -\ How to compile bye that normally exits the compile and interpret loop -\ : goodbye lit [ key bye , ] execute ; - -\ cr 'd' emit 'o' emit 'n' emit 'e' emit cr - -\ hi -bye +\ seedForthDemoXXX.seedsource in XXX directory does some more tests then: +\ done bye diff --git a/i386/seedForthDemoi386.seedsource b/i386/seedForthDemoi386.seedsource index 87139ac..9de29c3 100644 --- a/i386/seedForthDemoi386.seedsource +++ b/i386/seedForthDemoi386.seedsource @@ -10,3 +10,5 @@ Defer d1 t{ d1 d1 d1 -> ten ten ten }t ' five is d1 t{ d1 d1 d1 -> five five five }t + +done bye diff --git a/z80/seedForthDemoz80.seedsource b/z80/seedForthDemoz80.seedsource index 72d2fac..921385c 100644 --- a/z80/seedForthDemoz80.seedsource +++ b/z80/seedForthDemoz80.seedsource @@ -11,3 +11,5 @@ Defer d1 t{ d1 d1 d1 -> ten ten ten }t ' five is d1 t{ d1 d1 d1 -> five five five }t + +done bye From 9e622d7c2a267335157c112aad33ad13d73eda8c Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Thu, 28 Apr 2022 19:27:41 +1000 Subject: [PATCH 40/41] In /z80 fix 32/16 bit divide bug and optimize multiply/divide, general tidy ups --- common/preForth-rts.pre | 2 +- common/seedForthDemo.seedsource | 22 +++++++ i386/seedForth-i386-rts.pre | 5 +- z80/preForth-z80-rts.pre | 2 +- z80/seedForth-z80-header.pre | 4 +- z80/seedForth-z80-rts.pre | 100 ++++++++++++++++++-------------- 6 files changed, 84 insertions(+), 51 deletions(-) diff --git a/common/preForth-rts.pre b/common/preForth-rts.pre index 490fe37..eb088c3 100644 --- a/common/preForth-rts.pre +++ b/common/preForth-rts.pre @@ -72,7 +72,7 @@ : (/mod ( n d q0 -- r d q ) >r over over < r> swap ?exit - >r swap over - swap r> 1+ (/mod ; + >r swap over - swap r> 1+ tail (/mod ; : (10u/mod ( n q d -- r q d ) 2 pick over > 0= ?exit \ ( n q d ) diff --git a/common/seedForthDemo.seedsource b/common/seedForthDemo.seedsource index 805b0a7..b976fa9 100644 --- a/common/seedForthDemo.seedsource +++ b/common/seedForthDemo.seedsource @@ -9,6 +9,28 @@ \ cat seedForthDemo.seed | ./seedForth \ +\ multiply debug: emits '0000' +\ 0x1234 * 0x5678 = 0x06260060 +\ 4660 22136 um* 1574 - 0= '1' + emit 96 - 0= '1' + emit +\ 0xffff * 0xffff = 0xfffe0001 +\ 65535 65535 um* 65534 - 0= '1' + emit 1 - 0= '1' + emit + +\ divide debug: emits '000000' +\ 0x06260060 / 0x5678 = 0x1234 rem 0x0000 +\ 96 1574 22136 um/mod 4660 - 0= '1' + emit 0= '1' + emit +\ 0x06260060 / 0x1234 = 0x5678 rem 0x0000 +\ 96 1574 4660 um/mod 22136 - 0= '1' + emit 0= '1' + emit +\ 0xfffe0001 / 0xffff = 0xffff rem 0x0000 +\ 1 65534 65535 um/mod 65535 - 0= '1' + emit 0= '1' + emit + +\ divide debug: emits '000000' +\ 0x062656d7 / 0x5678 = 0x1234 rem 0x5677 +\ 22231 1574 22136 um/mod 4660 - 0= '1' + emit 22135 - 0= '1' + emit +\ 0x06261293 / 0x1234 = 0x5678 rem 0x1233 +\ 4755 1574 4660 um/mod 22136 - 0= '1' + emit 4659 - 0= '1' + emit +\ 0xfffeffff / 0xffff = 0xffff rem 0xfffe +\ 65535 65534 65535 um/mod 65535 - 0= '1' + emit 65534 - 0= '1' + emit + Definer Variable create ( x ) drop 0 , ; \ Missing primitives diff --git a/i386/seedForth-i386-rts.pre b/i386/seedForth-i386-rts.pre index 6c69035..3664cf1 100644 --- a/i386/seedForth-i386-rts.pre +++ b/i386/seedForth-i386-rts.pre @@ -8,6 +8,7 @@ extrn poll extrn usleep _enter = _nest +_exit = _unnest _dodoes: ; ( -- addr ) lea ebp,[ebp-4] ; push IP @@ -82,10 +83,6 @@ code and ( x1 x2 -- x3 ) next ; -pre -_exit = _unnest -; - code @ ( addr -- x ) pop eax mov eax,[eax] diff --git a/z80/preForth-z80-rts.pre b/z80/preForth-z80-rts.pre index 0475322..7c1d6c9 100644 --- a/z80/preForth-z80-rts.pre +++ b/z80/preForth-z80-rts.pre @@ -1,4 +1,4 @@ -\ preForth runtime system - i386 (16 bit) dependent part +\ preForth runtime system - z80 (16 bit) dependent part \ -------------------------- \ \ - registers: diff --git a/z80/seedForth-z80-header.pre b/z80/seedForth-z80-header.pre index 2f97d33..a0528ef 100644 --- a/z80/seedForth-z80-header.pre +++ b/z80/seedForth-z80-header.pre @@ -1,8 +1,8 @@ \ 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) +\ it is then followed by preForth-z80-rts.pre (primitive asm words) +\ and then by seedForth-z80.pre (additional primitive asm words) \ and then by seedForth.pre (high level words and the interpreter) pre diff --git a/z80/seedForth-z80-rts.pre b/z80/seedForth-z80-rts.pre index 2eaf38d..6f5646f 100644 --- a/z80/seedForth-z80-rts.pre +++ b/z80/seedForth-z80-rts.pre @@ -3,6 +3,12 @@ \ interpreter and basic asm primitives are taken from preForth-z80-rts.pre, \ and then this file defines additional primitives (arithmetic, memory, etc) +\ aliases for the user-visible versions of some internal routines +pre +_enter = _nest +_exit = _unnest +; + \ note: we arrive at _dodoes by a sequence of 2 calls, the return \ address stacked by first call points to some instance data, and \ the return address stacked by second call (to _dodoes) points to @@ -10,19 +16,22 @@ \ data -- we simply leave the instance data's address stacked for \ the high level forth code and then "execute" the high level forth \ code, which means that _dodoes is the same as _enter in our case -\ note: similarly, arriving at _dovar we just leave address stacked pre -_enter = _nest -_exit = _unnest - _dodoes = _nest +; + +\ note: similarly, arriving at _dovar we just leave address stacked +pre _dovar = next ; code key? ( -- f ) in a,(STDIN_STATUS) - ld l,a - ld h,0 + or a + jr z,1$ + ld a,0xff +1$: ld l,a + ld h,a push hl jr next ; @@ -159,32 +168,32 @@ code um* ( u1 u2 -- ud ) ; ld l,c ; ld h,b ; call print_hexw -; ld a,0x2a +; ld a,'* ; call print_char ; ld l,e ; ld h,d ; call print_hexw +; ld a,'= +; call print_char - sub a ; clears cf + sub a ld l,a ld h,a ld a,b ld b,16 - or a -umul_loop: + ; cf does not matter here (shift in a random bit that isn't used) rra rr c +umul_loop: jr nc,umul_skip - add hl,de ; can't overflow, leaves cf = 0 + add hl,de umul_skip: rr h rr l - djnz umul_loop rra rr c + djnz umul_loop ld b,a -; ld a,0x3d -; call print_char ; push hl ; call print_hexw ; ld l,c @@ -198,7 +207,15 @@ umul_skip: push hl ; push ud hi exx - jr next1 + ;jr next1 + +next1: ld a,(bc) + ld l,a + inc bc + ld a,(bc) + ld h,a + inc bc + jp (hl) ; code um/mod ( ud u1 -- u2 u3 ) @@ -212,43 +229,46 @@ code um/mod ( ud u1 -- u2 u3 ) ; ld l,e ; ld h,d ; call print_hexw -; ld a,0x2f +; ld a,'/ ; call print_char ; ld l,c ; ld h,b ; call print_hexw ; pop hl +; ld a,'= +; call print_char ld a,16 - or a + ; cf does not matter here (shift in a random bit that isn't used) + jr udiv_loop +udiv_test: + ; shift left has not overflowed, try to subtract bc, leaves cf=0 + ; only if subtraction went, record complement of cf in quotient + sbc hl,bc + jr nc,udiv_goes + add hl,bc ; preserves cf +udiv_goes: + ccf + dec a + jr z,udiv_done udiv_loop: ex de,hl adc hl,hl ex de,hl adc hl,hl jr nc,udiv_test - ; shift left has overflowed, so we can always subtract bc, and - ; always cf=1 to indicate subtraction went, record cf in quotient - sbc hl,bc - jr udiv_cont -udiv_test: - ; shift left has not overflowed, see if we can subtract bc, cf=0 - ; indicates subtraction went, record complement of cf in quotient + ; shift left has overflowed, so we can always subtract bc, always + ; leaves cf=1 to indicate subtraction went, record cf in quotient + or a sbc hl,bc - jr nc,udiv_goes - add hl,bc -udiv_goes: - ccf -udiv_cont: dec a jr nz,udiv_loop +udiv_done: ex de,hl adc hl,hl ; record final quotient bit -; ld a,0x3d -; call print_char ; push hl ; call print_hexw -; ld a,0x72 +; ld a,'r ; call print_char ; ld l,e ; ld h,d @@ -270,13 +290,7 @@ code usleep ( c -- ) out (USLEEP_LO),a ld a,h out (USLEEP_HI),a -next1: ld a,(bc) - ld l,a - inc bc - ld a,(bc) - ld h,a - inc bc - jp (hl) + jr next1 ; \ we want the text section to be first and bss last (for linkers that output @@ -298,12 +312,12 @@ pre ; pop af ;print_hexn: ; and 0xf -; add a,0x30 -; cp 0x3a +; add a,'0 +; cp '0 + 10 ; jr c,print_char -; add a,0x41 - 0x3a +; add a,'a - '0 - 10 ;print_char: -; out (STDOUT_PORT),a +; out (STDERR_DATA),a ; ret .area data From 20f084da87b1688452fdd6f16ac094e023407ec6 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Thu, 28 Apr 2022 20:45:10 +1000 Subject: [PATCH 41/41] Add copyright notice (required for the GPLv3 license to be effective) --- COPYRIGHT | 16 ++++++++++++++++ README.md | 3 +++ z80/seedForth-z80-rts.pre | 4 +--- 3 files changed, 20 insertions(+), 3 deletions(-) create mode 100644 COPYRIGHT diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 index 0000000..9197608 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,16 @@ +preForth, seedForth, seedForthInteractive +Copyright 2018-2020 Ulrich Hoffman +Copyright 2022 Nick Downing + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see . diff --git a/README.md b/README.md index 9102921..900850f 100644 --- a/README.md +++ b/README.md @@ -83,3 +83,6 @@ Inspect sources and generated files. *Have fun. May the Forth be with you.* +# Copyright and license + +Please see the files `COPYRIGHT` and `LICENSE` in the root of this repository. diff --git a/z80/seedForth-z80-rts.pre b/z80/seedForth-z80-rts.pre index 6f5646f..e972e8b 100644 --- a/z80/seedForth-z80-rts.pre +++ b/z80/seedForth-z80-rts.pre @@ -176,9 +176,7 @@ code um* ( u1 u2 -- ud ) ; ld a,'= ; call print_char - sub a - ld l,a - ld h,a + ld hl,0 ld a,b ld b,16 ; cf does not matter here (shift in a random bit that isn't used)