From df227c795a94b62c6788ee8c09630e8e8d065f75 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Fri, 22 Apr 2022 13:40:34 +1000 Subject: [PATCH 01/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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/51] 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) From a1821f941aa153210f4d3ee0ca483ce97dd006e4 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Wed, 27 Apr 2022 19:08:17 +1000 Subject: [PATCH 42/51] Add /emu_65c02 directory, based on /emu_z80 with backend taken from https://github.com/visrealm/vrEmu6502.git --- .gitignore | 1 + .gitmodules | 3 + Makefile | 8 +- emu_65c02/Makefile | 30 +++++++ emu_65c02/emu_65c02.c | 205 ++++++++++++++++++++++++++++++++++++++++++ emu_65c02/test.asm | 66 ++++++++++++++ emu_65c02/vrEmu6502 | 1 + 7 files changed, 312 insertions(+), 2 deletions(-) create mode 100644 emu_65c02/Makefile create mode 100644 emu_65c02/emu_65c02.c create mode 100644 emu_65c02/test.asm create mode 160000 emu_65c02/vrEmu6502 diff --git a/.gitignore b/.gitignore index 9722f3a..dac2622 100644 --- a/.gitignore +++ b/.gitignore @@ -8,6 +8,7 @@ *.rst *.seed /common/crc10.forth +/emu_65c02/emu_65c02 /emu_z80/emu_z80 /i386/preForth /i386/preForth.asm diff --git a/.gitmodules b/.gitmodules index edcd001..0e1a669 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,3 +4,6 @@ [submodule "asxv5pxx"] path = asxv5pxx url = https://github.com/nickd4/asxv5pxx.git +[submodule "emu_65c02/vrEmu6502"] + path = emu_65c02/vrEmu6502 + url = https://github.com/nickd4/vrEmu6502.git diff --git a/Makefile b/Makefile index b481a8f..9358d73 100644 --- a/Makefile +++ b/Makefile @@ -1,14 +1,18 @@ .PHONY: all -all: asxv5pxx common emu_z80 i386 z80 +all: asxv5pxx common emu_65c02 emu_z80 i386 z80 .PHONY: asxv5pxx asxv5pxx: - $(MAKE) $(MAKEFLAGS) -C asxv5pxx/asxmak/linux/build asz80 aslink + $(MAKE) $(MAKEFLAGS) -C asxv5pxx/asxmak/linux/build asz80 as6500 aslink .PHONY: common common: $(MAKE) $(MAKEFLAGS) -C common +.PHONY: emu_65c02 +emu_65c02: asxv5pxx + $(MAKE) $(MAKEFLAGS) -C emu_65c02 + .PHONY: emu_z80 emu_z80: asxv5pxx $(MAKE) $(MAKEFLAGS) -C emu_z80 diff --git a/emu_65c02/Makefile b/emu_65c02/Makefile new file mode 100644 index 0000000..a807161 --- /dev/null +++ b/emu_65c02/Makefile @@ -0,0 +1,30 @@ +CFLAGS=-g -Wall -O3 -DVR_6502_EMU_STATIC=1 +LDFLAGS=-g + +AS6500=../asxv5pxx/asxmak/linux/exe/as6500 +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 + +LOAD_ADDR=0x300 + +.PHONY: all +all: emu_65c02 test.bin + +emu_65c02: emu_65c02.o vrEmu6502/src/vrEmu6502.o + $(CC) $(LDFLAGS) -o $@ $^ + +test.bin: test.ihx + $(HEX2BIN) $< $@ + +test.ihx: test.rel + $(ASLINK) -n -m -u -i -b text=$(LOAD_ADDR) $@ $^ + +test.rel: test.asm + $(AS6500) -l -o $< + +.PHONY: clean +clean: + rm -f *.bin *.hlr *.ihx *.lst *.map *.o *.rel *.rst emu_65c02 z80/*.o diff --git a/emu_65c02/emu_65c02.c b/emu_65c02/emu_65c02.c new file mode 100644 index 0000000..f1f8de5 --- /dev/null +++ b/emu_65c02/emu_65c02.c @@ -0,0 +1,205 @@ +#include +#include +#include +#include +#include +#include +#include +#include "vrEmu6502/src/vrEmu6502.h" + +#define IO_PAGE 0x200 +#define STDIN_DATA 0x200 +#define STDOUT_DATA 0x201 +#define STDERR_DATA 0x202 +#define STDIN_STATUS 0x203 +#define STDOUT_STATUS 0x204 +#define STDERR_STATUS 0x205 +#define USLEEP_LO 0x206 +#define USLEEP_HI 0x207 +#define SYS_EXIT 0x208 + +#define LOAD_ADDRESS 0x300 +#define RESET_VECTOR 0xfffc + +VrEmu6502 *cpu; + +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; +int exit_flag; + +// 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 mem_read(uint16_t addr, bool isDbg) { + if ((addr & 0xff00) != IO_PAGE) + return memory[addr]; + + switch (addr) { + case STDIN_DATA: + { + uint8_t data = 4; // EOT + 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 (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; +} + +void mem_write(uint16_t addr, uint8_t val) { + if ((addr & 0xff00) != IO_PAGE) { + memory[addr] = val; + return; + } + + switch (addr) { + 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 USLEEP_LO: + usleep_lo = val; + break; + case USLEEP_HI: + usleep(usleep_lo | (val << 8)); + break; + case SYS_EXIT: + exit_flag = val | 0x100; + break; + } +} + +int main(int argc, char **argv) { + int argn = 1; + bool timing = false; + 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 + LOAD_ADDRESS, MEMORY_SIZE - LOAD_ADDRESS) == -1) { + perror("read()"); + exit(EXIT_FAILURE); + } + 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(); + + // do this before creating the CPU + memory[RESET_VECTOR] = (uint8_t)(LOAD_ADDRESS & 0xff); + memory[RESET_VECTOR + 1] = (uint8_t)(LOAD_ADDRESS >> 8); + + cpu = vrEmu6502New(CPU_65C02, mem_read, mem_write); + if (cpu == NULL) { + perror("malloc()"); + exit(EXIT_FAILURE); + } + + long nb_ticks = 0; + while (!exit_flag) { + vrEmu6502Tick(cpu); + ++nb_ticks; + } + + vrEmu6502Destroy(cpu); + + if (timing) + fprintf( + stderr, + "%lu ticks executed\n", + nb_ticks + ); + exit(exit_flag & 0xff); +} diff --git a/emu_65c02/test.asm b/emu_65c02/test.asm new file mode 100644 index 0000000..d345960 --- /dev/null +++ b/emu_65c02/test.asm @@ -0,0 +1,66 @@ +STDIN_DATA = 0x200 +STDOUT_DATA = 0x201 +STDERR_DATA = 0x202 +STDIN_STATUS = 0x203 +STDOUT_STATUS = 0x204 +STDERR_STATUS = 0x205 +USLEEP_LO = 0x206 +USLEEP_HI = 0x207 +SYS_EXIT = 0x208 + + .r65c02 + + .area text + + cld + + ldx #0 + ldy #message_end - message +print_message: + lda message,x + sta STDERR_DATA + inx + dey + bne print_message + +in_wait: + lda STDIN_STATUS + bne in_char + + lda #<1000 + sta USLEEP_LO + lda #>1000 + sta USLEEP_HI + bra in_wait + +in_char: + lda STDIN_DATA + clc + cmp #4 ; EOT + beq done + + tax + +out_wait: + lda STDOUT_STATUS + bne out_char + + lda #<1000 + sta USLEEP_LO + lda #>1000 + sta USLEEP_HI + bra out_wait + +out_char: + stx STDOUT_DATA + bra in_wait + +done: lda #0 + sta SYS_EXIT + + .area text + +message: + .ascii /hello, world!/ + .db 0xa +message_end: diff --git a/emu_65c02/vrEmu6502 b/emu_65c02/vrEmu6502 new file mode 160000 index 0000000..a8e2da6 --- /dev/null +++ b/emu_65c02/vrEmu6502 @@ -0,0 +1 @@ +Subproject commit a8e2da6d3f4a35784f28f4e2fff5e7271890c7b5 From 28d441fe97d0ad1cfe42372ed4ae5cd72bc48cf3 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Thu, 28 Apr 2022 11:21:10 +1000 Subject: [PATCH 43/51] Add /65c02 directory with working preForth and seedForth, add a sophisticated tracing and symbolic debug (via annotated trace) system used to debug the 65C02 port, the trace is also available for the Z80 port and can be used for comparison --- .gitignore | 4 + 65c02/Makefile | 203 ++++++++ 65c02/preForth-65c02-backend.pre | 158 ++++++ 65c02/preForth-65c02-rts.pre | 383 +++++++++++++++ 65c02/seed | 4 + 65c02/seedForth-65c02-header.pre | 22 + 65c02/seedForth-65c02-rts.pre | 635 +++++++++++++++++++++++++ 65c02/seedForth-65c02.pre | 31 ++ 65c02/seedForth-tokenizer | 2 + 65c02/seedForthDemo65c02.seedsource | 15 + 65c02/seedForthRuntime65c02.seedsource | 22 + Makefile | 6 +- common/seedForthDemo.seedsource | 8 + emu_65c02/annotate_trace.py | 44 ++ emu_65c02/emu_65c02.c | 27 ++ emu_z80/annotate_trace.py | 44 ++ emu_z80/emu_z80.c | 29 ++ i386/seedForth-i386-rts.pre | 1 + z80/preForth-z80-rts.pre | 5 + z80/seedForth-z80-rts.pre | 1 + 20 files changed, 1643 insertions(+), 1 deletion(-) create mode 100644 65c02/Makefile create mode 100644 65c02/preForth-65c02-backend.pre create mode 100644 65c02/preForth-65c02-rts.pre create mode 100755 65c02/seed create mode 100644 65c02/seedForth-65c02-header.pre create mode 100644 65c02/seedForth-65c02-rts.pre create mode 100644 65c02/seedForth-65c02.pre create mode 100755 65c02/seedForth-tokenizer create mode 100644 65c02/seedForthDemo65c02.seedsource create mode 100644 65c02/seedForthRuntime65c02.seedsource create mode 100755 emu_65c02/annotate_trace.py create mode 100755 emu_z80/annotate_trace.py diff --git a/.gitignore b/.gitignore index dac2622..91e2317 100644 --- a/.gitignore +++ b/.gitignore @@ -7,6 +7,10 @@ *.rel *.rst *.seed +/65c02/preForth.asm +/65c02/preForthDemo.asm +/65c02/seedForth.asm +/65c02/__temp__.fs /common/crc10.forth /emu_65c02/emu_65c02 /emu_z80/emu_z80 diff --git a/65c02/Makefile b/65c02/Makefile new file mode 100644 index 0000000..3648189 --- /dev/null +++ b/65c02/Makefile @@ -0,0 +1,203 @@ +# 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 +# ------------------------------------------------------------------------ + +AS6500=../asxv5pxx/asxmak/linux/exe/as6500 +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 + +LOAD_ADDR=0x300 + +EMU_65C02=../emu_65c02/emu_65c02 + +.PHONY: all +all: \ +preForthDemo.bin \ +preForth.bin \ +seedForth.bin \ +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) +ASM=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-65c02-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth-65c02-backend.pre \ +../common/preForth.pre \ +../common/preForthDemo.pre + cat \ +preForth-65c02-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-65c02-backend.pre \ +../common/preForth.pre \ +../common/preForth-cold.fs \ +>$@ + +preForth.$(ASM): \ +../common/preForth-bootstrap.fs \ +../common/preForth-cold.fs \ +preForth-65c02-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth-65c02-backend.pre \ +../common/preForth.pre + cat \ +preForth-65c02-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth-65c02-backend.pre \ +../common/preForth.pre \ +|$(HOSTFORTH) \ +../common/preForth-bootstrap.fs \ +../common/preForth-rts-nonstandard.pre \ +preForth-65c02-backend.pre \ +../common/preForth.pre \ +../common/preForth-cold.fs \ +>$@ + +%.$(ASM): \ +%.pre \ +preForth-65c02-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth.bin + $(EMU_65C02) preForth.bin \ +preForth-65c02-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +$< \ +>$@ + +%.bin: %.$(ASM) + $(AS6500) -l -o $< + $(ASLINK) -n -m -u -i -b zpage=0 -b text=$(LOAD_ADDR) $(<:.$(ASM)=.ihx) $(<:.$(ASM)=.rel) + $(HEX2BIN) $(<:.$(ASM)=.ihx) $@ + +# run preForth on its own source code to perform a bootstrap +# should produce identical results +bootstrap: \ +preForth-65c02-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth-65c02-backend.pre \ +../common/preForth.pre \ +preForth.bin \ +preForth.$(ASM) + $(EMU_65C02) preForth.bin \ +preForth-65c02-rts.pre \ +../common/preForth-rts-nonstandard.pre \ +../common/preForth-rts.pre \ +preForth-65c02-backend.pre \ +../common/preForth.pre \ +>preForth1.$(ASM) + cmp preForth.$(ASM) preForth1.$(ASM) + +# preForth connected to stdin - output to stdout +.PHONY: visible-bootstrap +visible-bootstrap: preForth.bin preForth-65c02-backend.pre ../common/preForth.pre + $(EMU_65C02) preForth.bin preForth-65c02-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.$(ASM): \ +seedForth-65c02-header.pre \ +preForth-65c02-rts.pre \ +seedForth-65c02-rts.pre \ +seedForth-65c02.pre \ +../common/seedForth16bit.pre \ +../common/seedForth.pre \ +preForth.bin + $(EMU_65C02) preForth.bin \ +seedForth-65c02-header.pre \ +preForth-65c02-rts.pre \ +seedForth-65c02-rts.pre \ +seedForth-65c02.pre \ +../common/seedForth16bit.pre \ +../common/seedForth.pre \ +>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, +# 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 \ +seedForthDemo65c02.seedsource + cat $^ >__temp__.fs + $(HOSTFORTH) __temp__.fs -e bye >$@ + rm __temp__.fs + +seedForthBoot.seed: \ +../common/crc10.forth \ +../common/../common/seedForth-tokenizer.fs \ +../common/seedForthRuntime16bit.seedsource \ +../common/seedForthRuntime.seedsource \ +seedForthRuntime65c02.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/seedForthRuntime16bit.seedsource \ +../common/seedForthRuntime.seedsource \ +seedForthRuntime65c02.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/65c02/preForth-65c02-backend.pre b/65c02/preForth-65c02-backend.pre new file mode 100644 index 0000000..138db4d --- /dev/null +++ b/65c02/preForth-65c02-backend.pre @@ -0,0 +1,158 @@ +\ -------------------------- +\ preForth backend for 65c02 (16 bit) as-65c02 +\ -------------------------- + +\ 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 + 'X' swap '@' case? ?exit nip \ may clash with 'X' suffix 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) + +: ."dw" ( -- ) + tab '.' emit 'd' emit 'w' emit tab ; + +: ."db" ( -- ) + tab '.' emit 'd' emit 'b' emit tab ; + +: ."jsr" ( -- ) + tab 'j' emit 's' emit 'r' 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 -- ) + ."dw" alter show cr ; + +\ compile reference to nest primitive +: ,nest ( -- ) + ."jsr" ."nest" cr ; + +\ compile reference to unnest primitive +: ,unnest ( -- ) + ."dw" ."unnest" cr cr ; + +\ compile signed number +: ,n ( n -- ) + ."dw" . cr ; + +\ compile unsigned number +: ,u ( u -- ) + ."dw" u. cr ; + +\ compile literal +: ,_lit ( S -- ) + ."dw" ."lit" cr ,word ; + +\ compile literal +: ,lit ( x -- ) + ."dw" ."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 +\ for 65c02, 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 ; + +: ,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/65c02/preForth-65c02-rts.pre b/65c02/preForth-65c02-rts.pre new file mode 100644 index 0000000..60e3557 --- /dev/null +++ b/65c02/preForth-65c02-rts.pre @@ -0,0 +1,383 @@ +\ preForth runtime system - 65c02 (16 bit) dependent part +\ -------------------------- +\ +\ - registers: +\ A, X general purpose +\ Y zero +\ - zero page: +\ ip instruction pointer +\ dsp data stack pointer +\ rsp return stack pointer + +pre +;;; This is a preForth generated file using preForth-65c02-backend. +;;; Only modify it, if you know what you are doing. + +DATA_STACK_SIZE = 0x1000 +RETURN_STACK_SIZE = 0x1000 + +STDIN_DATA = 0x200 +STDOUT_DATA = 0x201 +STDERR_DATA = 0x202 +STDIN_STATUS = 0x203 +STDOUT_STATUS = 0x204 +STDERR_STATUS = 0x205 +USLEEP_LO = 0x206 +USLEEP_HI = 0x207 +SYS_EXIT = 0x208 + +EXIT_SUCCESS = 0 +EXIT_FAILURE = 1 + + .r65c02 + + ; define load order + .area zpage + .area text + .area data + .area bss + + .area zpage + .setdp ; set direct (zero) page -- makes instructions shorter + + ; instruction and stack pointers +ip: .ds 2 +dsp: .ds 2 +rsp: .ds 2 + + ; scratch +temp: .ds 3 ; was 4, but we can use x-register instead of last one + + .area text + +main: cld + ldx #0xff + txs + lda #<(data_stack + DATA_STACK_SIZE) + sta dsp + ;lda #<(return_stack + RETURN_STACK_SIZE) + sta rsp + lda #>(data_stack + DATA_STACK_SIZE) + sta dsp+1 + lda #>(return_stack + RETURN_STACK_SIZE) + sta rsp+1 + lda #main1 + sta ip+1 + ldy #0 + jmp next + +main1: .dw _cold + .dw _bye + +; + +code bye ( -- ) + lda #EXIT_SUCCESS + sta SYS_EXIT +; + +code emit ( c -- ) + lda [dsp],y + sta STDOUT_DATA + + inc dsp + inc dsp + bne 1$ ;next + inc dsp+1 +1$: jmp next ;bra next +; + +code eemit ( c -- ) + lda [dsp],y + sta STDERR_DATA + + inc dsp + inc dsp + bne 1$ ;next + inc dsp+1 +1$: jmp next ;bra next +; + +code key ( -- c ) + ldx dsp + bne 1$ + dec dsp+1 +1$: dec dsp + tya + sta [dsp],y + dec dsp + lda STDIN_DATA + sta [dsp],y + jmp next ;bra next +; + +code dup ( x -- x x ) + ldx dsp + bne 1$ + dec dsp+1 +1$: dec dsp + dec dsp + ldy #2 + lda [dsp],y + tax + iny + lda [dsp],y + ldy #1 + sta [dsp],y + dey + txa + sta [dsp],y + bra next +; + +code swap ( x y -- y x ) + lda [dsp],y + sta temp + iny + lda [dsp],y + sta temp+1 + iny + lda [dsp],y + sta temp+2 + iny + lda [dsp],y + tax ; sta temp+3 + lda temp+1 + sta [dsp],y + dey + lda temp + sta [dsp],y + dey + txa ; lda temp+3 + sta [dsp],y + dey + lda temp+2 + sta [dsp],y + bra next +; + +code drop ( x -- ) + inc dsp + inc dsp + bne next + inc dsp+1 + bra next +; + +\ put this in middle of the primitives to make it reachable by bra +code nest ( -- ) +; tya +; cmp #0 +; beq 5$ +; sta SYS_EXIT +;5$: + ldx rsp + bne 1$ + dec rsp+1 +1$: dec rsp + lda ip+1 + sta [rsp],y + dec rsp + lda ip + sta [rsp],y + + pla + sta ip + pla + sta ip+1 + inc ip + bne next + inc ip+1 + +next: +; tya +; cmp #0 +; beq 5$ +; sta SYS_EXIT +;5$: + lda [ip],y + sta 2$+1 ; self modifying code + inc ip + bne 1$ + inc ip+1 +1$: lda [ip],y + sta 2$+2 ; self modifying code + inc ip + bne 2$ + inc ip+1 +2$: jmp 0 +; + +code 0< ( x -- flag ) + iny + lda [dsp],y + bmi 1$ + + lda #0 + sta [dsp],y + dey + sta [dsp],y + bra next + +1$: lda #0xff + sta [dsp],y + dey + sta [dsp],y + bra next +; + +code ?exit ( f -- ) + lda [dsp],y + inc dsp + ora [dsp],y + bne 1$ + inc dsp + bne next + inc dsp+1 + bra next + +1$: inc dsp + bne _unnest + inc dsp+1 + ; fall into unnest +; + +code unnest ( -- ) +; tya +; cmp #0 +; beq 5$ +; sta SYS_EXIT +;5$: + lda [rsp],y + sta ip + inc rsp + lda [rsp],y + sta ip+1 + inc rsp + bne next + inc rsp+1 + bra next +; + +code >r ( x -- ) ( R -- x ) + ldx rsp + bne 1$ + dec rsp+1 +1$: dec rsp + dec rsp + + lda [dsp],y + sta [rsp],y + iny + lda [dsp],y + sta [rsp],y + dey + + inc dsp + inc dsp + bne next1 + inc dsp+1 + bra next1 +; + +code r> ( R x -- ) ( -- x ) + ldx dsp + bne 1$ + dec dsp+1 +1$: dec dsp + dec dsp + + lda [rsp],y + sta [dsp],y + iny + lda [rsp],y + sta [dsp],y + dey + + inc rsp + inc rsp + bne next1 + inc rsp+1 + bra next1 +; + +code - ( x1 x2 -- x3 ) + ldy #2 + lda [dsp],y + ldy #0 + sec + sbc [dsp],y + ldy #2 + sta [dsp],y + iny + lda [dsp],y + ldy #1 + sbc [dsp],y + inc dsp + inc dsp + bne 1$ + inc dsp+1 +1$: sta [dsp],y + dey + bra next1 +; + +code lit ( -- ) + ldx dsp + bne 1$ + dec dsp+1 +1$: dec dsp + dec dsp + + lda [ip],y + sta [dsp],y + inc ip + bne 2$ + inc ip+1 +2$: lda [ip],y + iny + sta [dsp],y + dey + inc ip + bne next1 + inc ip+1 + ;bra next1 + +next1: +; tya +; cmp #0 +; beq 5$ +; sta SYS_EXIT +;5$: + lda [ip],y + sta 2$+1 ; self modifying code + inc ip + bne 1$ + inc ip+1 +1$: lda [ip],y + sta 2$+2 ; self modifying code + inc ip + bne 2$ + inc ip+1 +2$: jmp 0 +; + +\ 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 + .area bss + + .even + +return_stack: + .ds RETURN_STACK_SIZE +data_stack: + .ds DATA_STACK_SIZE + + .area text + +; diff --git a/65c02/seed b/65c02/seed new file mode 100755 index 0000000..db29ac9 --- /dev/null +++ b/65c02/seed @@ -0,0 +1,4 @@ +#!/bin/bash +stty raw -echo +../emu_65c02/emu_65c02 seedForth.bin seedForthInteractive.seed ../common/runtime.forth ../common/hi16bit.forth ../common/hi.forth - +stty sane diff --git a/65c02/seedForth-65c02-header.pre b/65c02/seedForth-65c02-header.pre new file mode 100644 index 0000000..d6cb393 --- /dev/null +++ b/65c02/seedForth-65c02-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-65c02-rts.pre (primitive asm words) +\ and then by seedForth-65c02.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 - | ../65c02_emu/65c02_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 = 4000 +MEM_SIZE = 40000 + +; diff --git a/65c02/seedForth-65c02-rts.pre b/65c02/seedForth-65c02-rts.pre new file mode 100644 index 0000000..f8ead20 --- /dev/null +++ b/65c02/seedForth-65c02-rts.pre @@ -0,0 +1,635 @@ +\ seedForth: machine dependent portion + +\ interpreter and basic asm primitives are taken from preForth-65c02-rts.pre, +\ and then this file defines additional primitives (arithmetic, memory, etc) + +pre + .area zpage + + .ds 3 ; extend temp from 3 to 6 locations for mul/div + + .area text + +; + +\ 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 +\ high level forth code which is going to operate on that instance +\ data -- move the first pushed address to data stack and "nest" +\ the second pushed address, adding 1 because of 65c02's jsr/rts +code dodoes ( -- ) +; tya +; cmp #0 +; beq 5$ +; sta SYS_EXIT +;5$: + ldx rsp + bne 1$ + dec rsp+1 +1$: dec rsp + lda ip+1 + sta [rsp],y + dec rsp + lda ip + sta [rsp],y + + pla + sta ip + pla + sta ip+1 + inc ip + bne _dovar + inc ip+1 + ; fall into dovar +; + +\ note: arriving at _dovar, we just move one address to data stack +code dovar ( -- ) +; tya +; cmp #0 +; beq 5$ +; sta SYS_EXIT +;5$: + ldx dsp + bne 1$ + dec dsp+1 +1$: dec dsp + dec dsp + + pla + sec + adc #0 + sta [dsp],y + pla + adc #0 + iny + sta [dsp],y + dey + + bra next1 +; + +code key? ( -- f ) + ldx dsp + bne 1$ + dec dsp+1 +1$: dec dsp + lda STDIN_STATUS + beq 2$ + lda #0xff +2$: sta [dsp],y + dec dsp + lda STDIN_STATUS + sta [dsp],y + bra next2 +; + +code or ( x1 x2 -- x3 ) + lda [dsp],y + ldy #2 + ora [dsp],y + sta [dsp],y + dey + lda [dsp],y + ldy #3 + ora [dsp],y + sta [dsp],y + ldy #0 + + inc dsp + inc dsp + bne next2 + inc dsp+1 + bra next2 +; + +code and ( x1 x2 -- x3 ) + lda [dsp],y + ldy #2 + and [dsp],y + sta [dsp],y + dey + lda [dsp],y + ldy #3 + and [dsp],y + sta [dsp],y + ldy #0 + + inc dsp + inc dsp + bne next2 + inc dsp+1 + bra next2 +; + +code @ ( addr -- x ) + lda [dsp],y + sta temp + iny + lda [dsp],y + sta temp+1 + + lda [temp],y + sta [dsp],y + dey + lda [temp],y + sta [dsp],y + + bra next2 +; + +code c@ ( c-addr -- c ) + lda [dsp],y + sta temp + iny + lda [dsp],y + sta temp+1 + + lda #0 + sta [dsp],y + dey + lda [temp],y + sta [dsp],y + + ;bra next2 + +next2: +; tya +; cmp #0 +; beq 5$ +; sta SYS_EXIT +;5$: + lda [ip],y + sta 2$+1 ; self modifying code + inc ip + bne 1$ + inc ip+1 +1$: lda [ip],y + sta 2$+2 ; self modifying code + inc ip + bne 2$ + inc ip+1 +2$: jmp 0 +; + +code ! ( x addr -- ) + lda [dsp],y + sta temp + inc dsp + lda [dsp],y + sta temp+1 + inc dsp + bne 1$ + inc dsp+1 + +1$: lda [dsp],y + sta [temp],y + inc dsp + lda [dsp],y + iny + sta [temp],y + dey + inc dsp + bne next2 + inc dsp+1 + bra next2 +; + +code c! ( c c-addr -- ) + lda [dsp],y + sta temp + inc dsp + lda [dsp],y + sta temp+1 + inc dsp + bne 1$ + inc dsp+1 + +1$: lda [dsp],y + sta [temp],y + inc dsp + inc dsp + bne next2 + inc dsp+1 + bra next2 +; + +\ 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 + lda [dsp],y + asl a + sta temp + inc dsp + lda [dsp],y + rol a + tax ; sta temp+1 + inc dsp + bne 1$ + inc dsp+1 + +1$: lda temp + clc + adc #<_head + sta temp + txa ; lda temp+1 + adc #>_head + sta temp+1 + + lda [temp],y + sta 2$+1 ; self modifying code + iny + lda [temp],y + sta 2$+2 ; self modifying code + dey +2$: jmp 0 +; + +code branch ( -- ) \ threaded code: r> @ >r ; + lda [ip],y + tax + iny + lda [ip],y + dey + sta ip+1 + txa + sta ip + bra next3 +; + +\ is this misleading? I would have thought ?branch means branch on nonzero +code ?branch ( f -- ) \ threaded code: ?exit r> @ >r ; + lda [dsp],y + inc dsp + ora [dsp],y + bne 1$ + inc dsp + bne _branch + inc dsp+1 + bra _branch + +1$: inc dsp + bne 2$ + inc dsp+1 +2$: inc ip + bne 3$ + inc ip+1 +3$: inc ip + bne next3 + inc ip+1 + bra next3 +; + +code depth ( -- n ) + sec + lda #<(data_stack + DATA_STACK_SIZE) + sbc dsp + sta temp + lda #>(data_stack + DATA_STACK_SIZE) + sbc dsp+1 + lsr a + ror temp + + ldx dsp + bne 1$ + dec dsp+1 +1$: dec dsp + sta [dsp],y + dec dsp + lda temp + sta [dsp],y + bra next3 +; + +code sp@ ( -- x ) + lda dsp+1 + ldx dsp + bne 1$ + dec dsp+1 +1$: dec dsp + sta [dsp],y + dec dsp + txa + sta [dsp],y + bra next3 +; + +code sp! ( x -- ) + lda [dsp],y + tax + iny + lda [dsp],y + dey + sta dsp+1 + stx dsp + ;bra next3 + +next3: +; tya +; cmp #0 +; beq 5$ +; sta SYS_EXIT +;5$: + lda [ip],y + sta 2$+1 ; self modifying code + inc ip + bne 1$ + inc ip+1 +1$: lda [ip],y + sta 2$+2 ; self modifying code + inc ip + bne 2$ + inc ip+1 +2$: jmp 0 +; + +code rp@ ( -- x ) + ldx dsp + bne 1$ + dec dsp+1 +1$: dec dsp + lda rsp+1 + sta [dsp],y + dec dsp + lda rsp + sta [dsp],y + bra next3 +; + +code rp! ( x -- ) + lda [dsp],y + sta rsp + inc dsp + lda [dsp],y + sta rsp+1 + inc dsp + bne next3 + inc dsp+1 + bra next3 +; + +code um* ( u1 u2 -- ud ) + sty temp+4 + sty temp+5 + + lda [dsp],y + sta temp + iny + lda [dsp],y + sta temp+1 + iny + lda [dsp],y + sta temp+2 +; tax + iny + lda [dsp],y + sta temp+3 +; jsr print_hexw +; lda #'* +; jsr print_char +; lda temp+1 +; ldx temp +; jsr print_hexw +; lda #'= +; jsr print_char + + ldx #16 + ; cf does not matter here (shift in a random bit that isn't used) + ror temp+3 + ror temp+2 +1$: bcc 2$ + clc + lda temp+4 + adc temp + sta temp+4 + lda temp+5 + adc temp+1 + sta temp+5 +2$: ror temp+5 + ror temp+4 + ror temp+3 + ror temp+2 + dex + bne 1$ +; lda temp+5 +; ldx temp+4 +; jsr print_hexw +; lda temp+3 +; ldx temp+2 +; jsr print_hexw +; lda #0xa +; jsr print_char + + lda temp+3 + sta [dsp],y + dey + lda temp+2 + sta [dsp],y + dey + lda temp+5 + sta [dsp],y + dey + lda temp+4 + sta [dsp],y + + ;bra next4 + +next4: +; tya +; cmp #0 +; beq 5$ +; sta SYS_EXIT +;5$: + lda [ip],y + sta 2$+1 ; self modifying code + inc ip + bne 1$ + inc ip+1 +1$: lda [ip],y + sta 2$+2 ; self modifying code + inc ip + bne 2$ + inc ip+1 +2$: jmp 0 +; + +code um/mod ( ud u1 -- u2 u3 ) + lda [dsp],y + sta temp + inc dsp + lda [dsp],y + sta temp+1 + inc dsp + bne 1$ + inc dsp+1 + +1$: lda [dsp],y + sta temp+4 +; tax + iny + lda [dsp],y + sta temp+5 +; jsr print_hexw + iny + lda [dsp],y + sta temp+2 +; tax + iny + lda [dsp],y + sta temp+3 +; jsr print_hexw +; lda #'/ +; jsr print_char +; ldx temp +; lda temp+1 +; jsr print_hexw +; lda #'= +; jsr print_char + + ldx #16 + ; cf does not matter here (shift in a random bit that isn't used) + bra 4$ +2$: ; shift left has not overflowed, try to subtract divisor + sec + lda temp+4 + sbc temp + sta temp+4 + lda temp+5 + sbc temp+1 + sta temp+5 + bcs 3$ ; went, record 1 in quotient + lda temp+4 + adc temp + sta temp+4 + lda temp+5 + adc temp+1 + sta temp+5 + clc ; did not go, record 0 in quotient +3$: dex + beq 5$ +4$: ; loop entry + rol temp+2 + rol temp+3 + rol temp+4 + rol temp+5 + bcc 2$ + ; shift left has overflowed, so we can always subtract divisor + lda temp+4 + sbc temp + sta temp+4 + lda temp+5 + sbc temp+1 + sta temp+5 + sec ; went, record 1 in quotient + dex + bne 4$ +5$: ; loop done + rol temp+2 + rol temp+3 ; record final quotient bit +; lda temp+5 +; ldx temp+4 +; jsr print_hexw +; lda #'r +; jsr print_char +; lda temp+3 +; ldx temp+2 +; jsr print_hexw +; lda #0xa +; jsr print_char + + lda temp+5 + sta [dsp],y + dey + lda temp+4 + sta [dsp],y + dey + lda temp+3 + sta [dsp],y + dey + lda temp+2 + sta [dsp],y + + bra next5 +; + +code usleep ( c -- ) + lda [dsp],y + sta USLEEP_LO + inc dsp + lda [dsp],y + sta USLEEP_HI + inc dsp + bne next5 + inc dsp+1 + ;bra next5 + +next5: +; tya +; cmp #0 +; beq 5$ +; sta SYS_EXIT +;5$: + lda [ip],y + sta 2$+1 ; self modifying code + inc ip + bne 1$ + inc ip+1 +1$: lda [ip],y + sta 2$+2 ; self modifying code + inc ip + bne 2$ + inc ip+1 +2$: jmp 0 + +; + +\ 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 +;print_hexw: ; print a:x +; jsr print_hexb +; txa +;print_hexb: +; pha +; lsr a +; lsr a +; lsr a +; lsr a +; jsr print_hexn +; pla +; and #0xf +;print_hexn: +; ora #'0 +; cmp #'0 + 10 +; bcc print_char +; adc #'a - '0 - 10 - 1 +;print_char: +; sta STDERR_DATA +; rts + + .area data + + ; dictionary pointer: points to next free location in memory +_dp: .dw _mem + + .area bss + + ; head pointer: index of first unused head +__hp: .dw 0 +_head: .ds HEAD_SIZE*2 + + ; free memory starts at _mem +_mem: .ds MEM_SIZE +_memtop: + + .area text + +; diff --git a/65c02/seedForth-65c02.pre b/65c02/seedForth-65c02.pre new file mode 100644 index 0000000..daf7067 --- /dev/null +++ b/65c02/seedForth-65c02.pre @@ -0,0 +1,31 @@ +\ seedForth: less machine dependent portion +\ allows us to adjust things for direct threaded vs indirect threaded + +\ insert "jsr _dodoes" after each "does>" token +: ?does> ( xt -- xt | ) + dup h@ lit does> - ?exit \ not does> token: exit i.e. normal compile action + h@ , 32 c, lit dodoes , \ generate word of does> and instruction of call + r> drop tail compiler ; + +: compiler ( -- ) + token + ?eot + ?lit + ?does> + compile, tail compiler ; + +\ for 65c02 dtc implementation, compile "jsr _enter" before high level code +: new ( -- xt ) + hp @ here h, 32 c, lit enter , ; + +\ for 65c02 dtc implementation, compile "jsr _dovar" before data field of new +\ word, the "_dovar" will be changed the address of "call _dodoes" if needed +: create ( -- xt ) + hp @ here h, 32 c, lit dovar , ; + +\ 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 "jsr _dodoes") +: does> ( xt -- ) \ replace "_dovar" in "jsr _dovar" with return stack addr + r> swap h@ 1 + ! ; diff --git a/65c02/seedForth-tokenizer b/65c02/seedForth-tokenizer new file mode 100755 index 0000000..b651b20 --- /dev/null +++ b/65c02/seedForth-tokenizer @@ -0,0 +1,2 @@ +#!/bin/sh +../emu_65c02/emu_65c02 seedForth.bin seedForthBoot.seed ../common/runtime.forth ../common/crc10.forth ../common/seedForth-tokenizer.fs - diff --git a/65c02/seedForthDemo65c02.seedsource b/65c02/seedForthDemo65c02.seedsource new file mode 100644 index 0000000..58170cb --- /dev/null +++ b/65c02/seedForthDemo65c02.seedsource @@ -0,0 +1,15 @@ +\ machine dependent part of seedForthDemo.seedsource +\ allows us to adjust things for direct threaded vs indirect threaded + +\ we must index past the "jsr" instruction +: >body ( xt -- body ) h@ 1 + 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 + +done bye diff --git a/65c02/seedForthRuntime65c02.seedsource b/65c02/seedForthRuntime65c02.seedsource new file mode 100644 index 0000000..1130fa5 --- /dev/null +++ b/65c02/seedForthRuntime65c02.seedsource @@ -0,0 +1,22 @@ +\ machine dependent part of seedForthRuntime.seedsource +\ allows us to adjust things for direct threaded vs indirect threaded + +\ we must index past the "jsr" instruction +: >body ( xt -- body ) + h@ 1 + 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 + +\ insert "jsr _dodoes" after each "does>" token +: (Does>) ( -- ) + [ ' last-xt ] Literal compile, + [ ' does> ] Literal compile, + 32 c, [ ' dodoes ] Literal compile, ; +' (Does>) has-header Does> immediate diff --git a/Makefile b/Makefile index 9358d73..8751a54 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,9 @@ .PHONY: all -all: asxv5pxx common emu_65c02 emu_z80 i386 z80 +all: 65c02 asxv5pxx common emu_65c02 emu_z80 i386 z80 + +.PHONY: 65c02 +65c02: emu_65c02 common + $(MAKE) $(MAKEFLAGS) -C 65c02 .PHONY: asxv5pxx asxv5pxx: diff --git a/common/seedForthDemo.seedsource b/common/seedForthDemo.seedsource index b976fa9..a3ad1be 100644 --- a/common/seedForthDemo.seedsource +++ b/common/seedForthDemo.seedsource @@ -31,8 +31,16 @@ \ 0xfffeffff / 0xffff = 0xffff rem 0xfffe \ 65535 65534 65535 um/mod 65535 - 0= '1' + emit 65534 - 0= '1' + emit +\ stack debug: emits '00000' +\ depth 0= '1' + emit +\ 1234 sp@ @ 1234 - 0= '1' + emit sp@ 2345 swap ! 2345 - 0= '1' + emit +\ 3456 >r rp@ @ 3456 - 0= '1' + emit rp@ 4567 swap ! r> 4567 - 0= '1' + emit + Definer Variable create ( x ) drop 0 , ; +\ Variable debug: emits '0' +\ Variable dummy dummy 2 + here - 0= '1' + emit + \ Missing primitives : over ( x1 x2 -- x1 x2 x1 ) >r dup r> swap ; : /string ( x1 x2 x3 -- x4 x5 ) swap over - >r + r> ; diff --git a/emu_65c02/annotate_trace.py b/emu_65c02/annotate_trace.py new file mode 100755 index 0000000..7ebba61 --- /dev/null +++ b/emu_65c02/annotate_trace.py @@ -0,0 +1,44 @@ +#!/usr/bin/env python3 + +import bisect +import sys + +EXIT_SUCCESS = 0 +EXIT_FAILURE = 1 + +if len(sys.argv) < 2: + print(f'usage: {sys.argv[0]:s} program.rst annotated_trace.txt') + sys.exit(EXIT_FAILURE) + +symbol_table = [] +with open(sys.argv[1]) as fin: + i = 0 # fallback sort key (use symbol defined later in file) + for line in fin: + fields = line[32:].split() + if ( + len(fields) and + fields[0][-1:] == ':' and + fields[0][:1] != ';' and + fields[0][-2:] != '$:' + ): + addr = int(line[3:7], 16) + symbol = fields[0][:-1] + symbol_table.append((addr, i, symbol)) + i += 1 +symbol_table.sort() +symbol_table = ( + [addr for addr, _, _ in symbol_table], + [symbol for _, _, symbol in symbol_table] +) + +for line in sys.stdin: + fields = line.split('=') + for i in range(1, len(fields)): + addr = int(fields[i][:4], 16) + j = bisect.bisect_right(symbol_table[0], addr) + if j: + j -= 1 + offset = addr - symbol_table[0][j] + symbol = symbol_table[1][j] + fields[i] = fields[i][:4] + f'({symbol:s}+{offset:04x})' + fields[i][4:] + sys.stdout.write('='.join(fields)) diff --git a/emu_65c02/emu_65c02.c b/emu_65c02/emu_65c02.c index f1f8de5..757f417 100644 --- a/emu_65c02/emu_65c02.c +++ b/emu_65c02/emu_65c02.c @@ -21,6 +21,8 @@ #define LOAD_ADDRESS 0x300 #define RESET_VECTOR 0xfffc +#define TRACE 0 + VrEmu6502 *cpu; int stdin_fd; @@ -188,7 +190,32 @@ int main(int argc, char **argv) { } long nb_ticks = 0; +#if TRACE + int pc = -1; +#endif while (!exit_flag) { +#if TRACE + if (pc != vrEmu6502GetPC(cpu)) { + pc = vrEmu6502GetPC(cpu); + int ip = memory[0] | (memory[1] << 8); + int dsp = memory[2] | (memory[3] << 8); + int rsp = memory[4] | (memory[5] << 8); + fprintf( + stderr, + "pc=%04x:%02x,%02x,%02x ip=%04x:%04x dsp=%04x:%04x rsp=%04x:%04x\n", + pc, + memory[pc], + memory[(pc + 1) & 0xffff], + memory[(pc + 2) & 0xffff], + ip, + memory[ip] | (memory[(ip + 1) & 0xffff] << 8), + dsp, + memory[dsp] | (memory[(dsp + 1) & 0xffff] << 8), + rsp, + memory[rsp] | (memory[(rsp + 1) & 0xffff] << 8) + ); + } +#endif vrEmu6502Tick(cpu); ++nb_ticks; } diff --git a/emu_z80/annotate_trace.py b/emu_z80/annotate_trace.py new file mode 100755 index 0000000..7ebba61 --- /dev/null +++ b/emu_z80/annotate_trace.py @@ -0,0 +1,44 @@ +#!/usr/bin/env python3 + +import bisect +import sys + +EXIT_SUCCESS = 0 +EXIT_FAILURE = 1 + +if len(sys.argv) < 2: + print(f'usage: {sys.argv[0]:s} program.rst annotated_trace.txt') + sys.exit(EXIT_FAILURE) + +symbol_table = [] +with open(sys.argv[1]) as fin: + i = 0 # fallback sort key (use symbol defined later in file) + for line in fin: + fields = line[32:].split() + if ( + len(fields) and + fields[0][-1:] == ':' and + fields[0][:1] != ';' and + fields[0][-2:] != '$:' + ): + addr = int(line[3:7], 16) + symbol = fields[0][:-1] + symbol_table.append((addr, i, symbol)) + i += 1 +symbol_table.sort() +symbol_table = ( + [addr for addr, _, _ in symbol_table], + [symbol for _, _, symbol in symbol_table] +) + +for line in sys.stdin: + fields = line.split('=') + for i in range(1, len(fields)): + addr = int(fields[i][:4], 16) + j = bisect.bisect_right(symbol_table[0], addr) + if j: + j -= 1 + offset = addr - symbol_table[0][j] + symbol = symbol_table[1][j] + fields[i] = fields[i][:4] + f'({symbol:s}+{offset:04x})' + fields[i][4:] + sys.stdout.write('='.join(fields)) diff --git a/emu_z80/emu_z80.c b/emu_z80/emu_z80.c index 193141a..1bba91c 100644 --- a/emu_z80/emu_z80.c +++ b/emu_z80/emu_z80.c @@ -17,6 +17,8 @@ #define USLEEP_HI 7 #define SYS_EXIT 8 +#define TRACE 0 + z80 cpu; int stdin_fd; @@ -181,10 +183,37 @@ int main(int argc, char **argv) { cpu.port_out = out; long n, nb_instructions = 0; +#if TRACE + do { + int pc = cpu.pc; + int ip = cpu.c | cpu.b << 8; + int dsp = cpu.sp; + int rsp = cpu.ix; + fprintf( + stderr, + "pc=%04x:%02x,%02x,%02x,%02x ip=%04x:%04x dsp=%04x:%04x rsp=%04x:%04x\n", + pc, + memory[pc], + memory[(pc + 1) & 0xffff], + memory[(pc + 2) & 0xffff], + memory[(pc + 3) & 0xffff], + ip, + memory[ip] | (memory[(ip + 1) & 0xffff] << 8), + dsp, + memory[dsp] | (memory[(dsp + 1) & 0xffff] << 8), + rsp, + memory[rsp] | (memory[(rsp + 1) & 0xffff] << 8) + ); + + n = z80_step(&cpu, 1); + nb_instructions += n; + } while (n); +#else do { n = z80_step(&cpu, 1000); nb_instructions += n; } while (n >= 1000); +#endif if (timing) fprintf( diff --git a/i386/seedForth-i386-rts.pre b/i386/seedForth-i386-rts.pre index 3664cf1..0d8ed90 100644 --- a/i386/seedForth-i386-rts.pre +++ b/i386/seedForth-i386-rts.pre @@ -125,6 +125,7 @@ code branch ( -- ) \ threaded code: r> @ >r ; next ; +\ is this misleading? I would have thought ?branch means branch on nonzero code ?branch ( f -- ) \ threaded code: ?exit r> @ >r ; pop eax or eax,eax diff --git a/z80/preForth-z80-rts.pre b/z80/preForth-z80-rts.pre index 7c1d6c9..6eeb06a 100644 --- a/z80/preForth-z80-rts.pre +++ b/z80/preForth-z80-rts.pre @@ -27,6 +27,11 @@ SYS_EXIT = 8 EXIT_SUCCESS = 0 EXIT_FAILURE = 1 + ; define load order + .area text + .area data + .area bss + .area text main: ld ix,return_stack + RETURN_STACK_SIZE diff --git a/z80/seedForth-z80-rts.pre b/z80/seedForth-z80-rts.pre index e972e8b..b375ab6 100644 --- a/z80/seedForth-z80-rts.pre +++ b/z80/seedForth-z80-rts.pre @@ -117,6 +117,7 @@ code branch ( -- ) \ threaded code: r> @ >r ; jr next ; +\ is this misleading? I would have thought ?branch means branch on nonzero code ?branch ( f -- ) \ threaded code: ?exit r> @ >r ; pop hl ld a,l From a0c8eb9810394be22f3e525e4a2837c187afb59a Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Fri, 29 Apr 2022 11:07:55 +1000 Subject: [PATCH 44/51] Hack in /emu_65c02 to make multiple instructions executed, and fix warnings --- emu_65c02/emu_65c02.c | 65 +++++++++++++++++++++++-------------------- emu_65c02/vrEmu6502 | 2 +- 2 files changed, 36 insertions(+), 31 deletions(-) diff --git a/emu_65c02/emu_65c02.c b/emu_65c02/emu_65c02.c index 757f417..0b9add8 100644 --- a/emu_65c02/emu_65c02.c +++ b/emu_65c02/emu_65c02.c @@ -141,6 +141,7 @@ void mem_write(uint16_t addr, uint8_t val) { break; case SYS_EXIT: exit_flag = val | 0x100; + vrEmu6502Jam(cpu); break; } } @@ -189,44 +190,48 @@ int main(int argc, char **argv) { exit(EXIT_FAILURE); } - long nb_ticks = 0; + long nb_instructions = 0, nb_cycles = 0; + int i, j; #if TRACE - int pc = -1; -#endif - while (!exit_flag) { -#if TRACE - if (pc != vrEmu6502GetPC(cpu)) { - pc = vrEmu6502GetPC(cpu); - int ip = memory[0] | (memory[1] << 8); - int dsp = memory[2] | (memory[3] << 8); - int rsp = memory[4] | (memory[5] << 8); - fprintf( - stderr, - "pc=%04x:%02x,%02x,%02x ip=%04x:%04x dsp=%04x:%04x rsp=%04x:%04x\n", - pc, - memory[pc], - memory[(pc + 1) & 0xffff], - memory[(pc + 2) & 0xffff], - ip, - memory[ip] | (memory[(ip + 1) & 0xffff] << 8), - dsp, - memory[dsp] | (memory[(dsp + 1) & 0xffff] << 8), - rsp, - memory[rsp] | (memory[(rsp + 1) & 0xffff] << 8) - ); - } + do { + int pc = vrEmu6502GetPC(cpu); + int ip = memory[0] | (memory[1] << 8); + int dsp = memory[2] | (memory[3] << 8); + int rsp = memory[4] | (memory[5] << 8); + fprintf( + stderr, + "pc=%04x:%02x,%02x,%02x ip=%04x:%04x dsp=%04x:%04x rsp=%04x:%04x\n", + pc, + memory[pc], + memory[(pc + 1) & 0xffff], + memory[(pc + 2) & 0xffff], + ip, + memory[ip] | (memory[(ip + 1) & 0xffff] << 8), + dsp, + memory[dsp] | (memory[(dsp + 1) & 0xffff] << 8), + rsp, + memory[rsp] | (memory[(rsp + 1) & 0xffff] << 8) + ); + i = vrEmu6502Run(cpu, 1, &j); + nb_instructions += i; + nb_cycles += j; + } while (i); +#else + do { + i = vrEmu6502Run(cpu, 1000, &j); + nb_instructions += i; + nb_cycles += j; + } while (i >= 1000); #endif - vrEmu6502Tick(cpu); - ++nb_ticks; - } vrEmu6502Destroy(cpu); if (timing) fprintf( stderr, - "%lu ticks executed\n", - nb_ticks + "%lu instructions executed on %lu cycles\n", + nb_instructions, + nb_cycles ); exit(exit_flag & 0xff); } diff --git a/emu_65c02/vrEmu6502 b/emu_65c02/vrEmu6502 index a8e2da6..bf110f7 160000 --- a/emu_65c02/vrEmu6502 +++ b/emu_65c02/vrEmu6502 @@ -1 +1 @@ -Subproject commit a8e2da6d3f4a35784f28f4e2fff5e7271890c7b5 +Subproject commit bf110f7457f24a2dd4a6954565f6c676d86cc042 From 3627c1c3ae52becedfae45931346bd6292f2626e Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Fri, 29 Apr 2022 13:19:29 +1000 Subject: [PATCH 45/51] Change __hp to use .ds rather than .dw, removes padding from seedForth binaries --- 65c02/seedForth-65c02-rts.pre | 2 +- z80/seedForth-z80-rts.pre | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/65c02/seedForth-65c02-rts.pre b/65c02/seedForth-65c02-rts.pre index f8ead20..b2abd2f 100644 --- a/65c02/seedForth-65c02-rts.pre +++ b/65c02/seedForth-65c02-rts.pre @@ -623,7 +623,7 @@ _dp: .dw _mem .area bss ; head pointer: index of first unused head -__hp: .dw 0 +__hp: .ds 2 _head: .ds HEAD_SIZE*2 ; free memory starts at _mem diff --git a/z80/seedForth-z80-rts.pre b/z80/seedForth-z80-rts.pre index b375ab6..1836034 100644 --- a/z80/seedForth-z80-rts.pre +++ b/z80/seedForth-z80-rts.pre @@ -327,7 +327,7 @@ _dp: .dw _mem .area bss ; head pointer: index of first unused head -__hp: .dw 0 +__hp: .ds 2 _head: .ds HEAD_SIZE*2 ; free memory starts at _mem From bbb04e41d9a9aa0a7633bf46d44df78ac7bafed8 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Fri, 29 Apr 2022 18:05:08 +1000 Subject: [PATCH 46/51] Fix oops --- emu_65c02/vrEmu6502 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/emu_65c02/vrEmu6502 b/emu_65c02/vrEmu6502 index bf110f7..abce433 160000 --- a/emu_65c02/vrEmu6502 +++ b/emu_65c02/vrEmu6502 @@ -1 +1 @@ -Subproject commit bf110f7457f24a2dd4a6954565f6c676d86cc042 +Subproject commit abce43336301fa2bc4675f6d8d96fd8bd879192a From f12459163d3b43e348527581cd8987596976ca3e Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Fri, 29 Apr 2022 19:45:42 +1000 Subject: [PATCH 47/51] Move h@ to directly after token everywhere, change compile, to , --- 65c02/seedForth-65c02-rts.pre | 26 ++++-------------------- 65c02/seedForth-65c02.pre | 16 +++++++-------- 65c02/seedForthDemo65c02.seedsource | 2 +- 65c02/seedForthRuntime65c02.seedsource | 8 ++++---- common/hi.forth | 2 +- common/runtime.forth | 2 +- common/seedForth-tokenizer.fs | 4 ++-- common/seedForth.pre | 14 +++++-------- common/seedForthDemo.seedsource | 2 +- common/seedForthRuntime.seedsource | 28 +++++++++++++------------- i386/seedForth-i386-rts.pre | 6 ++---- i386/seedForth-i386.pre | 10 ++++----- i386/seedForthDemoi386.seedsource | 2 +- i386/seedForthRuntimei386.seedsource | 6 +++--- z80/seedForth-z80-rts.pre | 13 ++---------- z80/seedForth-z80.pre | 14 ++++++------- z80/seedForthDemoz80.seedsource | 2 +- z80/seedForthRuntimez80.seedsource | 8 ++++---- 18 files changed, 66 insertions(+), 99 deletions(-) diff --git a/65c02/seedForth-65c02-rts.pre b/65c02/seedForth-65c02-rts.pre index b2abd2f..450b231 100644 --- a/65c02/seedForth-65c02-rts.pre +++ b/65c02/seedForth-65c02-rts.pre @@ -221,34 +221,16 @@ code c! ( c c-addr -- ) bra next2 ; -\ 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 +code execute ( xt -- ) lda [dsp],y - asl a - sta temp + sta 1$+1 ; self modifying code inc dsp lda [dsp],y - rol a - tax ; sta temp+1 + sta 1$+2 ; self modifying code inc dsp bne 1$ inc dsp+1 - -1$: lda temp - clc - adc #<_head - sta temp - txa ; lda temp+1 - adc #>_head - sta temp+1 - - lda [temp],y - sta 2$+1 ; self modifying code - iny - lda [temp],y - sta 2$+2 ; self modifying code - dey -2$: jmp 0 +1$: jmp 0 ; code branch ( -- ) \ threaded code: r> @ >r ; diff --git a/65c02/seedForth-65c02.pre b/65c02/seedForth-65c02.pre index daf7067..7fe2b82 100644 --- a/65c02/seedForth-65c02.pre +++ b/65c02/seedForth-65c02.pre @@ -3,29 +3,29 @@ \ insert "jsr _dodoes" after each "does>" token : ?does> ( xt -- xt | ) - dup h@ lit does> - ?exit \ not does> token: exit i.e. normal compile action - h@ , 32 c, lit dodoes , \ generate word of does> and instruction of call + dup lit does> - ?exit \ not does> token: exit i.e. normal compile action + , 32 c, lit dodoes , \ generate word of does> and instruction of jsr r> drop tail compiler ; : compiler ( -- ) - token + token h@ ?eot ?lit ?does> - compile, tail compiler ; + , tail compiler ; \ for 65c02 dtc implementation, compile "jsr _enter" before high level code : new ( -- xt ) - hp @ here h, 32 c, lit enter , ; + here dup h, 32 c, lit enter , ; \ for 65c02 dtc implementation, compile "jsr _dovar" before data field of new -\ word, the "_dovar" will be changed the address of "call _dodoes" if needed +\ word, the "_dovar" will be changed the address of "jsr _dodoes" if needed : create ( -- xt ) - hp @ here h, 32 c, lit dovar , ; + here dup h, 32 c, lit dovar , ; \ 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 "jsr _dodoes") : does> ( xt -- ) \ replace "_dovar" in "jsr _dovar" with return stack addr - r> swap h@ 1 + ! ; + r> swap 1 + ! ; diff --git a/65c02/seedForthDemo65c02.seedsource b/65c02/seedForthDemo65c02.seedsource index 58170cb..48d1987 100644 --- a/65c02/seedForthDemo65c02.seedsource +++ b/65c02/seedForthDemo65c02.seedsource @@ -2,7 +2,7 @@ \ allows us to adjust things for direct threaded vs indirect threaded \ we must index past the "jsr" instruction -: >body ( xt -- body ) h@ 1 + 1 cells + ; +: >body ( xt -- body ) 3 + ; : is ( xt -- ) ' >body ! ; diff --git a/65c02/seedForthRuntime65c02.seedsource b/65c02/seedForthRuntime65c02.seedsource index 1130fa5..5d18023 100644 --- a/65c02/seedForthRuntime65c02.seedsource +++ b/65c02/seedForthRuntime65c02.seedsource @@ -3,7 +3,7 @@ \ we must index past the "jsr" instruction : >body ( xt -- body ) - h@ 1 + 1 cells + ; + 3 + ; ' >body has-header >body : is ( xt -- ) \ only interactive @@ -16,7 +16,7 @@ \ insert "jsr _dodoes" after each "does>" token : (Does>) ( -- ) - [ ' last-xt ] Literal compile, - [ ' does> ] Literal compile, - 32 c, [ ' dodoes ] Literal compile, ; + [ ' last-xt ] Literal , + [ ' does> ] Literal , + 32 c, [ ' dodoes ] Literal , ; ' (Does>) has-header Does> immediate diff --git a/common/hi.forth b/common/hi.forth index 43b4ad0..5223203 100644 --- a/common/hi.forth +++ b/common/hi.forth @@ -297,7 +297,7 @@ Defer %defer ' %defer >body 2 cells - @ Constant dodefer [ ' exit ] Literal >body 1 cells - r> cell+ ! ; : backpatch ( xt1 xt2 -- ) - here >r >body dp! compile, postpone exit r> dp! ; + here >r >body dp! , postpone exit r> dp! ; begin-tests diff --git a/common/runtime.forth b/common/runtime.forth index 8c9af88..535f4bb 100644 --- a/common/runtime.forth +++ b/common/runtime.forth @@ -96,7 +96,7 @@ false invert Constant true postpone UNTIL postpone drop ; immediate -: recurse ( -- ) last @ _xt @ compile, ; immediate +: recurse ( -- ) last @ _xt @ , ; immediate \ conditional compilation diff --git a/common/seedForth-tokenizer.fs b/common/seedForth-tokenizer.fs index e7dc889..687e21b 100644 --- a/common/seedForth-tokenizer.fs +++ b/common/seedForth-tokenizer.fs @@ -125,12 +125,12 @@ Variable #tokens 0 #tokens ! ( 28 $1C ) Token h@ Token h, Token here Token allot ( 32 $20 ) Token , Token c, Token fun Token interpreter ( 36 $24 ) Token compiler Token create Token does> Token cold -( 40 $28 ) Token depth Token compile, Token new Token couple +( 40 $28 ) Token depth Token dodoes Token new Token couple ( 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 key -( 60 $3C ) Token emit Token eemit Token dodoes +( 60 $3C ) Token emit Token eemit \ generate token sequences for numbers diff --git a/common/seedForth.pre b/common/seedForth.pre index 485eb5e..4a5b710 100644 --- a/common/seedForth.pre +++ b/common/seedForth.pre @@ -39,9 +39,6 @@ : c, ( c -- ) here 1 allot c! ; -: compile, ( x -- ) - h@ , ; - \ token are in the range 0 .. 1023: \ 0, 4 .. 255 are single byte tokens \ 256 .. 511 are double byte tokens of the form 01 xx @@ -53,21 +50,21 @@ key couple ; \ double byte token : interpreter ( -- ) - token execute tail interpreter ; \ executing exit will leave this loop + token h@ 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 + dup lit num - ?exit drop \ not num token: exit i.e. normal compile action + lit lit , num , \ generate lit x num call puts x on stack r> drop tail compiler ; : eot ( -- ) bye ; \ interpretive semantics: input exhausted, automatic bye : ?eot ( xt -- xt | ) - dup h@ lit eot - ?exit drop \ not eot token: exit i.e. normal compile action + dup lit eot - ?exit drop \ not eot token: exit i.e. normal compile action r> drop ; \ compilation semantics: return to interpretive state : fun ( -- ) @@ -125,7 +122,7 @@ lit does> h, \ 38 26 lit cold h, \ 39 27 lit depth h, \ 40 28 code - lit compile, h, \ 41 29 + lit dodoes h, \ 41 29 lit new h, \ 42 2A lit couple h, \ 43 2B lit and h, \ 44 2C code @@ -146,5 +143,4 @@ 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/common/seedForthDemo.seedsource b/common/seedForthDemo.seedsource index a3ad1be..98a8dfa 100644 --- a/common/seedForthDemo.seedsource +++ b/common/seedForthDemo.seedsource @@ -196,7 +196,7 @@ t{ person -> 3 cells }t \ size of structure \ Deferred words -: ' ( -- x ) key ; +: ' ( -- x ) token h@ ; : uninitialized ( -- ) cr s" uninitialized execution vector" type ; ' uninitialized Constant 'uninitialized diff --git a/common/seedForthRuntime.seedsource b/common/seedForthRuntime.seedsource index a8d7e97..5504a0b 100644 --- a/common/seedForthRuntime.seedsource +++ b/common/seedForthRuntime.seedsource @@ -252,7 +252,7 @@ end-macro \ Deferred words -: ' ( -- x ) token ; +: ' ( -- x ) token h@ ; : uninitialized ( -- ) cr s" uninitialized execution vector" type -1 throw ; @@ -585,7 +585,7 @@ end-macro ' does> has-header does> ' cold has-header cold ' depth has-header depth -' compile, has-header compile, +' , has-header , ' new has-header new ' couple has-header couple ' and has-header and @@ -754,19 +754,19 @@ Variable heads -1 heads ! ' _name has-header _name : (Literal) ( x -- ) - lit [ ' lit , ] compile, , ; + lit [ ' lit , ] , , ; ' (Literal) has-header Literal immediate : (s") ( ccc" -- ) - [ ' $lit ] Literal compile, + [ ' $lit ] Literal , '"' parse here over 1+ allot place ; ' (s") has-header s" immediate : (.") ( ccc" -- ) (s") - [ ' type ] Literal compile, ; + [ ' type ] Literal , ; ' (.") has-header ." immediate @@ -822,7 +822,7 @@ Variable heads -1 heads ! BEGIN dup WHILE ( xt wid ) - 2dup _xt @ h@ = IF nip exit THEN + 2dup _xt @ = IF nip exit THEN _link @ REPEAT ( xt wid ) 2drop 0 ; @@ -842,9 +842,9 @@ Variable heads -1 heads ! : (postpone) ( -- ) parse-name find-name dup 0= -13 and throw dup immediate? IF - _xt @ compile, + _xt @ , ELSE - [ ' lit ] Literal compile, _xt @ , [ ' compile, ] Literal compile, + [ ' lit ] Literal , _xt @ , [ ' , ] Literal , THEN ; @@ -857,7 +857,7 @@ Variable heads -1 heads ! ' tick has-header ' : ([']) ( -- xt ) - tick [ ' lit ] Literal compile, , ; + tick [ ' lit ] Literal , , ; ' ([']) has-header ['] immediate @@ -881,7 +881,7 @@ Variable heads -1 heads ! : ,# ( c-addr u -- 0 0 | c-addr u ) dup 0= ?exit ?# dup ?exit - lit [ ' lit , ] compile, rot , ; + lit [ ' lit , ] , rot , ; : ?'x' ( c-addr u -- x 0 0 | c-addr u ) dup 0= ?exit @@ -893,7 +893,7 @@ Variable heads -1 heads ! : ,'x' ( c-addr u -- 0 0 | c-addr u ) dup 0= ?exit ?'x' dup ?exit - lit [ ' lit , ] compile, rot , ; + lit [ ' lit , ] , rot , ; : ?word ( c-addr1 u1 | i*x c-addr2 u2 ) dup 0= ?exit @@ -913,7 +913,7 @@ Variable heads -1 heads ! dup 0= ?exit 2dup find-name ?dup IF - nip nip dup immediate? IF _xt @ execute ELSE _xt @ compile, THEN 0 0 + nip nip dup immediate? IF _xt @ execute ELSE _xt @ , THEN 0 0 THEN ; @@ -942,7 +942,7 @@ Variable handlers interpreters @ handlers ! Header new swap _xt ! hide (]) ; : (;) ( -- ) - lit [ ' exit , ] compile, reveal ([) ; + lit [ ' exit , ] , reveal ([) ; ' (]) has-header ] ' ([) has-header [ immediate @@ -1047,7 +1047,7 @@ Defer .status : noop ; \ ' noop is .status (done later) 0 UNTIL ; : warm ( -- ) - \ [ ' [ compile, ] + \ [ ' [ , ] empty-stack restart ; Create errormsg 0 , 0 , diff --git a/i386/seedForth-i386-rts.pre b/i386/seedForth-i386-rts.pre index 0d8ed90..ca1bf33 100644 --- a/i386/seedForth-i386-rts.pre +++ b/i386/seedForth-i386-rts.pre @@ -112,10 +112,8 @@ code c! ( c c-addr -- ) 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] +code execute ( xt -- ) + pop eax jmp dword [eax] ; diff --git a/i386/seedForth-i386.pre b/i386/seedForth-i386.pre index c21f5d8..37a2418 100644 --- a/i386/seedForth-i386.pre +++ b/i386/seedForth-i386.pre @@ -2,17 +2,17 @@ \ allows us to adjust things for direct threaded vs indirect threaded : compiler ( -- ) - token + token h@ ?eot ?lit - compile, tail compiler ; + , tail compiler ; : new ( -- xt ) - hp @ here h, lit enter , ; + here dup h, lit enter , ; : create ( -- xt ) 0 , \ dummy does> field - hp @ here h, lit dovar , ; + here dup h, lit dovar , ; : does> ( xt -- ) \ set code field of last defined word - r> swap h@ dup >r 1 cells - ! lit dodoes r> ! ; + r> swap dup >r 1 cells - ! lit dodoes r> ! ; diff --git a/i386/seedForthDemoi386.seedsource b/i386/seedForthDemoi386.seedsource index 9de29c3..a9b182d 100644 --- a/i386/seedForthDemoi386.seedsource +++ b/i386/seedForthDemoi386.seedsource @@ -1,7 +1,7 @@ \ machine dependent part of seedForthDemo.seedsource \ allows us to adjust things for direct threaded vs indirect threaded -: >body ( xt -- body ) h@ 1 cells + ; +: >body ( xt -- body ) 1 cells + ; : is ( xt -- ) ' >body ! ; diff --git a/i386/seedForthRuntimei386.seedsource b/i386/seedForthRuntimei386.seedsource index 0126e9b..de5ddc4 100644 --- a/i386/seedForthRuntimei386.seedsource +++ b/i386/seedForthRuntimei386.seedsource @@ -2,7 +2,7 @@ \ allows us to adjust things for direct threaded vs indirect threaded : >body ( xt -- body ) - h@ 1 cells + ; + 1 cells + ; ' >body has-header >body : is ( xt -- ) \ only interactive @@ -14,6 +14,6 @@ ' noop is .status : (Does>) ( -- ) - [ ' last-xt ] Literal compile, - [ ' does> ] Literal compile, ; + [ ' last-xt ] Literal , + [ ' does> ] Literal , ; ' (Does>) has-header Does> immediate diff --git a/z80/seedForth-z80-rts.pre b/z80/seedForth-z80-rts.pre index 1836034..75b3eb0 100644 --- a/z80/seedForth-z80-rts.pre +++ b/z80/seedForth-z80-rts.pre @@ -95,17 +95,8 @@ code c! ( c c-addr -- ) 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 hl - add hl,hl - ld de,_head - add hl,de - ld a,(hl) - inc hl - ld h,(hl) - ld l,a - jp (hl) +code execute ( xt -- ) + ret ; code branch ( -- ) \ threaded code: r> @ >r ; diff --git a/z80/seedForth-z80.pre b/z80/seedForth-z80.pre index b9b3e18..b334336 100644 --- a/z80/seedForth-z80.pre +++ b/z80/seedForth-z80.pre @@ -3,29 +3,29 @@ \ 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 + dup lit does> - ?exit \ not does> token: exit i.e. normal compile action + , 205 c, lit dodoes , \ generate word of does> and instruction of call r> drop tail compiler ; : compiler ( -- ) - token + token h@ ?eot ?lit ?does> - compile, tail compiler ; + , tail compiler ; \ for z80 dtc implementation, compile "call _enter" before high level code : new ( -- xt ) - hp @ here h, 205 c, lit enter , ; + here dup 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 ) - hp @ here h, 205 c, lit dovar , ; + here dup h, 205 c, lit dovar , ; \ 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 + ! ; + r> swap 1 + ! ; diff --git a/z80/seedForthDemoz80.seedsource b/z80/seedForthDemoz80.seedsource index 921385c..fffe0eb 100644 --- a/z80/seedForthDemoz80.seedsource +++ b/z80/seedForthDemoz80.seedsource @@ -2,7 +2,7 @@ \ allows us to adjust things for direct threaded vs indirect threaded \ we must index past the "call" instruction -: >body ( xt -- body ) h@ 1 + 1 cells + ; +: >body ( xt -- body ) 3 + ; : is ( xt -- ) ' >body ! ; diff --git a/z80/seedForthRuntimez80.seedsource b/z80/seedForthRuntimez80.seedsource index dc88646..17f6515 100644 --- a/z80/seedForthRuntimez80.seedsource +++ b/z80/seedForthRuntimez80.seedsource @@ -3,7 +3,7 @@ \ we must index past the "call" instruction : >body ( xt -- body ) - h@ 1 + 1 cells + ; + 3 + ; ' >body has-header >body : is ( xt -- ) \ only interactive @@ -16,7 +16,7 @@ \ insert "call _dodoes" after each "does>" token : (Does>) ( -- ) - [ ' last-xt ] Literal compile, - [ ' does> ] Literal compile, - 205 c, [ ' dodoes ] Literal compile, ; + [ ' last-xt ] Literal , + [ ' does> ] Literal , + 205 c, [ ' dodoes ] Literal , ; ' (Does>) has-header Does> immediate From c459f85cc613e91bb1af4dcbbdee9671e2cc4359 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sat, 30 Apr 2022 13:23:46 +1000 Subject: [PATCH 48/51] In tokenizer, improve consistency between :-definitions and Definer-definitions --- common/seedForth-tokenizer.fs | 57 ++++++++++++++++++++--------------- 1 file changed, 33 insertions(+), 24 deletions(-) diff --git a/common/seedForth-tokenizer.fs b/common/seedForth-tokenizer.fs index 687e21b..4854dc0 100644 --- a/common/seedForth-tokenizer.fs +++ b/common/seedForth-tokenizer.fs @@ -87,21 +87,30 @@ hash_table_size #hash_table * dup allot hash_table swap 0 fill \ VARIABLE OUTFILE -\ : submit ( c -- ) -\ PAD C! PAD 1 OUTFILE @ WRITE-FILE THROW ; -\ -\ : submit-token ( x -- ) -\ dup 255 > IF dup 8 rshift SUBMIT THEN SUBMIT ; : emit-token ( x -- ) dup xFF > IF dup 8 rshift emit THEN emit ; +\ The following words "Token", "Macro", "end-macro" and "seed" are the heart of +\ the tokenizer -- either "Token" or "Macro" makes an entry in the hash table, +\ and each hash table entry points to an anonymous function which is called by +\ "seed" when that token is encountered in the input stream. If you define it +\ with "Token", you get a canned routine that simply emits the corresponding +\ token into the *.seed file, but if you define it with "Macro" you specify the +\ routine to be executed when that token is compiled. So macros allows you to +\ compile control structures and so forth. "Macro" operates similarly to ":" in +\ that it switches to compilation mode. "end-macro" operates similarly to ";" +\ in that it finishes compilation, then it writes your routine into hash table. +\ Note that a difference between "Token" and "Macro" is that "Token" generates +\ a new token number (hence assuming we will emit a "fun" token to make the +\ seedForth kernel do the same at the other side), whereas "Macro" does not. Variable #tokens 0 #tokens ! : Token ( -- ) - :noname - #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 +! ; + :noname + #tokens @ postpone Literal + postpone emit-token + postpone ; + parse-name ?token ! + 1 #tokens +! ; : Macro ( -- ) parse-name ?token :noname xFEED ; @@ -135,7 +144,7 @@ Variable #tokens 0 #tokens ! \ generate token sequences for numbers : seed-byte ( c -- ) - seed key emit ; \ SUBMIT ; + seed key emit ; : 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 @@ -172,18 +181,11 @@ Variable #tokens 0 #tokens ! : seed-file ( -- ) BEGIN refill WHILE seed-line REPEAT ; -\ : PROGRAM ( -- ) -\ parse-name R/W CREATE-FILE THROW OUTFILE ! -\ seed-file ; - -\ Macro END ( -- ) -\ .S CR 0 SUBMIT OUTFILE @ CLOSE-FILE THROW BYE end-macro - \ eot is overloaded to either: \ - return from compilation state to interpretive state \ (used for compiling ; and various control flow constructs) \ - quit the interpreter if invoked in interpretive state -\ (can overloading because control flow is not allowed here) +\ (can overload it 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, @@ -192,7 +194,7 @@ Variable #tokens 0 #tokens ! Macro [ ( -- ) seed eot end-macro \ eot Macro ] ( -- ) seed compiler end-macro \ compiler -Macro : ( -- ) seed fun Token end-macro +Macro : ( -- ) Token seed fun end-macro Macro ; ( -- ) seed exit seed [ end-macro \ generate token sequences for strings @@ -310,14 +312,21 @@ Macro \ ( -- ) postpone \ end-macro +\ A Definer-definition is similar to a :-definition, see for reference: +\ Macro : ( -- ) Token seed fun end-macro +\ However, "Token" is replaced by "Macro", so that we will get control again +\ when the user invokes the Definer-definition, e.g. if user calls "Variable". +\ The "Token" routine compiles an anonymous function referring to the current +\ #token and then increments #token, and we do the same thing here -- we have +\ "# tokens @" in the Macro-body and then "1 #tokens +!" before the "seed fun". Macro Definer ( -- ) Macro postpone Token - #tokens @ 1 #tokens +! - postpone Literal - postpone emit-token \ SUBMIT-TOKEN - seed fun + #tokens @ postpone Literal + postpone emit-token postpone end-macro + 1 #tokens +! + seed fun end-macro \ for defining Macros later in seedForth From 298f5c8e506898e3430d9ab942e905f210029c3c Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sat, 30 Apr 2022 14:01:52 +1000 Subject: [PATCH 49/51] Move the creation of heads out of "new" and "create" so it becomes the caller's responsibility to do so if they need to, in the case of "new" this is done by replacing "new drop" with "new h," in the seedForth kernel, whereas in the case of "create" it is done by having the tokenizer prefix the body of the user's Definer-definition with "here h," -- or could make the latter a user responsibility --- 65c02/seedForth-65c02.pre | 4 ++-- common/seedForth-tokenizer.fs | 7 +++++++ common/seedForth.pre | 2 +- i386/seedForth-i386.pre | 4 ++-- z80/seedForth-z80.pre | 4 ++-- 5 files changed, 14 insertions(+), 7 deletions(-) diff --git a/65c02/seedForth-65c02.pre b/65c02/seedForth-65c02.pre index 7fe2b82..ad54502 100644 --- a/65c02/seedForth-65c02.pre +++ b/65c02/seedForth-65c02.pre @@ -16,12 +16,12 @@ \ for 65c02 dtc implementation, compile "jsr _enter" before high level code : new ( -- xt ) - here dup h, 32 c, lit enter , ; + here 32 c, lit enter , ; \ for 65c02 dtc implementation, compile "jsr _dovar" before data field of new \ word, the "_dovar" will be changed the address of "jsr _dodoes" if needed : create ( -- xt ) - here dup h, 32 c, lit dovar , ; + here 32 c, lit dovar , ; \ 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, diff --git a/common/seedForth-tokenizer.fs b/common/seedForth-tokenizer.fs index 4854dc0..55d6c61 100644 --- a/common/seedForth-tokenizer.fs +++ b/common/seedForth-tokenizer.fs @@ -321,12 +321,19 @@ end-macro \ "# tokens @" in the Macro-body and then "1 #tokens +!" before the "seed fun". Macro Definer ( -- ) Macro + \ take name of e.g. Variable being defined and create a token for it postpone Token + \ compile a call to the user's Definer-definition (original token no) #tokens @ postpone Literal postpone emit-token postpone end-macro 1 #tokens +! seed fun + \ user's code for Definer-body will begin with a call to "create", so + \ prefix their code with the sequence "here h," to give the token that + \ they create a header, and therefore keep the token numbering in sync + seed here + seed h, end-macro \ for defining Macros later in seedForth diff --git a/common/seedForth.pre b/common/seedForth.pre index 4a5b710..974f611 100644 --- a/common/seedForth.pre +++ b/common/seedForth.pre @@ -68,7 +68,7 @@ r> drop ; \ compilation semantics: return to interpretive state : fun ( -- ) - new drop compiler ; + new h, compiler ; : couple ( hi lo -- hilo ) >r 2* 2* 2* 2* 2* 2* 2* 2* r> + ; diff --git a/i386/seedForth-i386.pre b/i386/seedForth-i386.pre index 37a2418..ff14707 100644 --- a/i386/seedForth-i386.pre +++ b/i386/seedForth-i386.pre @@ -8,11 +8,11 @@ , tail compiler ; : new ( -- xt ) - here dup h, lit enter , ; + here lit enter , ; : create ( -- xt ) 0 , \ dummy does> field - here dup h, lit dovar , ; + here lit dovar , ; : does> ( xt -- ) \ set code field of last defined word r> swap dup >r 1 cells - ! lit dodoes r> ! ; diff --git a/z80/seedForth-z80.pre b/z80/seedForth-z80.pre index b334336..3383a3b 100644 --- a/z80/seedForth-z80.pre +++ b/z80/seedForth-z80.pre @@ -16,12 +16,12 @@ \ for z80 dtc implementation, compile "call _enter" before high level code : new ( -- xt ) - here dup h, 205 c, lit enter , ; + here 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 ) - here dup h, 205 c, lit dovar , ; + here 205 c, lit dovar , ; \ 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, From ba8d5dee0899c36906bf2ed8b474204360da42e6 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sat, 30 Apr 2022 19:51:12 +1000 Subject: [PATCH 50/51] Implement the Create macro in tokenizer, for a more Forth-like definer syntax --- common/seedForth-tokenizer.fs | 121 ++++++++++++++++++++++++---------- 1 file changed, 87 insertions(+), 34 deletions(-) diff --git a/common/seedForth-tokenizer.fs b/common/seedForth-tokenizer.fs index 55d6c61..c40ce6f 100644 --- a/common/seedForth-tokenizer.fs +++ b/common/seedForth-tokenizer.fs @@ -7,82 +7,82 @@ 65261 Constant xFEED \ exceptions -100 Constant except_hash_table_full +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 +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 +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-index ( entry -- addr ) + #hash-table * hash-table + ; -: hash_table_find ( name_addr name_len -- entry_addr found ) +: 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 + 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 ) + 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 + 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 + @ + 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 + r> 1+ hash-table-mask and LOOP \ not found, and no room for new entry - except_hash_table_full throw + except-hash-table-full throw ; : token@ ( c-addr u -- x ) \ get entry address and flag for found/empty - hash_table_find + hash-table-find - \ if found, return value of _xt, otherwise 0 - IF _hash_table_xt + @ ELSE drop 0 THEN + \ if found, return value of -xt, otherwise 0 + IF _hash-table-xt + @ ELSE drop 0 THEN ; : ?token ( c-addr u -- x ) \ get entry address and flag for found/empty - 2dup hash_table_find + 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 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 + + \ return address of -xt for caller to fill in + _hash-table-xt + ; \ VARIABLE OUTFILE @@ -104,12 +104,13 @@ hash_table_size #hash_table * dup allot hash_table swap 0 fill \ a new token number (hence assuming we will emit a "fun" token to make the \ seedForth kernel do the same at the other side), whereas "Macro" does not. Variable #tokens 0 #tokens ! +Variable last-xt-ptr \ will be copied to colon-xt-ptr during colon definition : Token ( -- ) :noname #tokens @ postpone Literal postpone emit-token postpone ; - parse-name ?token ! + parse-name ?token dup last-xt-ptr ! ! 1 #tokens +! ; : Macro ( -- ) @@ -191,11 +192,57 @@ Variable #tokens 0 #tokens ! \ 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 eot +end-macro +Macro ] ( -- ) + seed compiler +end-macro -Macro : ( -- ) Token seed fun end-macro -Macro ; ( -- ) seed exit seed [ end-macro +\ the colon-xt-ptr points into the hash table entry of the symbol +\ being defined during a colon-definition, indirecting through this +\ pointer gives the routine the tokenizer executes when compiling +\ that symbol later -- initially it just outputs the symbol's token, +\ but by editing the value at the colon-xt-ptr we can implement a +\ chain of actions to execute before outputting the symbol's token +Variable colon-xt-ptr 0 colon-xt-ptr ! +Macro : ( -- ) + Token last-xt-ptr @ colon-xt-ptr ! + seed fun +end-macro +Macro ; ( -- ) + 0 colon-xt-ptr ! + seed exit + seed [ +end-macro + +\ New style defining-words (regular Forth syntax) +\ Call the Create macro inside a definer-definition, e.g. +\ : Variable Create drop 0 , ; +\ This scheme can also handle SOME more complex cases, e.g. +\ : 2Variable Create drop 0 , Create drop 0 , ; +\ But, it does not have the full generality of Forth Create, since we cannot +\ properly handle arguments to Forth words when working via tokenizer +Macro Create + colon-xt-ptr @ 0= abort" Create outside of colon-definition" + + \ tokenizer side of creating a new defining-word + \ hook the routine at colon-xt-ptr to call Token then call the old routine, + \ so each time seed source calls e.g. Variable, we'll consume the name and + \ create the corresponding token (then the new variable can be referenced) + :noname + postpone Token + colon-xt-ptr @ @ postpone Literal postpone execute + postpone ; + colon-xt-ptr @ ! + + \ seedForth side of creating a new defining-word + \ compile "create dup h," instead of "Create" in body of new defining-word, + \ makes the corresponding token in seedForth heads table to keep us in sync + seed create + seed dup + seed h, +end-macro \ generate token sequences for strings @@ -312,6 +359,12 @@ Macro \ ( -- ) postpone \ end-macro +\ Old style defining-words (special seedForth syntax) +\ Use "Definer" instead of ":" for definition that begins with "create", e.g. +\ Definer Variable create drop 0 , ; +\ Note: above style is deprecated, please use the Create macro instead, e.g. +\ : Variable Create drop 0 , ; + \ A Definer-definition is similar to a :-definition, see for reference: \ Macro : ( -- ) Token seed fun end-macro \ However, "Token" is replaced by "Macro", so that we will get control again From 30e3ba81415472c22036c4f0d9d4afb9a530d9b9 Mon Sep 17 00:00:00 2001 From: Nick Downing Date: Sun, 1 May 2022 10:34:36 +1000 Subject: [PATCH 51/51] Fix a bug where hash table entry could be reused between Macro and end-macmro --- common/seedForth-tokenizer.fs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/common/seedForth-tokenizer.fs b/common/seedForth-tokenizer.fs index c40ce6f..b8749f0 100644 --- a/common/seedForth-tokenizer.fs +++ b/common/seedForth-tokenizer.fs @@ -37,7 +37,7 @@ hash-table-size #hash-table * dup allot hash-table swap 0 fill dup >r hash-table-index >r ( name-addr name-len R: entry entry-addr ) \ check for null entry - r@ _hash-table-xt + @ 0= IF + r@ _hash-table-name-len + @ 0= IF 2drop r> r> drop false UNLOOP exit THEN @@ -63,6 +63,8 @@ hash-table-size #hash-table * dup allot hash-table swap 0 fill hash-table-find \ if found, return value of -xt, otherwise 0 + \ note: value of -xt can be 0 if caller has not filled it in yet + \ (e.g. occurs between a Macro call and corresponding end-macro) IF _hash-table-xt + @ ELSE drop 0 THEN ;