--- /dev/null
+*.asm
+*.bin
+*.hlr
+*.ihx
+*.lst
+*.map
+*.o
+*.rel
+*.rst
+/preForth/asxxxx_build
+/preForth/asxs5p30.zip
+/preForth/bin
+/preForth/include
+/preForth/lib
+/preForth/libz80_build
+/preForth/libz80-2.1.0.tar.gz
+/preForth/preForth-z80
+/preForth/seedForth-z80
+/preForth/z80
# 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$(DOTASM) and preForth$(DOTASM)
-# Set HOSTFORTH to the Forth system that generates the initial preForth
# ------------------------------------------------------------------------
+
+# Set HOSTFORTH to the Forth system that generates the initial preForth
HOSTFORTH=gforth
# HOSTFORTH=sf # SwiftForth >3.7
+
+#UNIXFLAVOUR=$(shell uname -s)
+#DOTASM=.asm
+#DOTEXE=
+#DOTSLASH=./
+
+UNIXFLAVOUR=z80
+DOTASM=.asm
+DOTEXE=.bin
+# note: below definition has a trailing space
+DOTSLASH=LD_LIBRARY_PATH=lib ./z80
+
+# for compiling Z80 emulator
+CFLAGS=-g -Wall -Iinclude
+LDFLAGS=-g -Llib
+
# ------------------------------------------------------------------------
.PHONY=all
-all: preForth seedForth seedForthDemo.seed seedForthInteractive.seed
+all: z80 preForth$(DOTEXE) seedForth$(DOTEXE) seedForthDemo.seed seedForthInteractive.seed
.PHONY=test
test: runseedforthdemo runseedforthinteractive
.PHONY=runseedforthdemo
-runseedforthdemo: seedForth seedForthDemo.seed
- cat seedForthDemo.seed | ./seedForth
+runseedforthdemo: seedForth$(DOTEXE) seedForthDemo.seed
+ cat seedForthDemo.seed | $(DOTSLASH)seedForth$(DOTEXE)
.PHONY=runseedfortinteractive
-runseedforthinteractive: seedForth seedForthInteractive.seed
- ./seed
+runseedforthinteractive: seedForth$(DOTEXE) seedForthInteractive.seed
+ ./seed$(DOTEXE)
-UNIXFLAVOUR=$(shell uname -s)
-EXT=asm
+z80: z80.o
+ ${CC} ${LDFLAGS} -o $@ $^ -lz80
-seedForth-i386.asm: seedForth-i386.pre preForth
- cat seedForth-i386.pre | ./preForth >seedForth-i386.asm
+seedForth-z80$(DOTASM): seedForth-z80.pre preForth$(DOTEXE)
+ cat seedForth-z80.pre | $(DOTSLASH)preForth$(DOTEXE) >seedForth-z80$(DOTASM)
-# preForth connected to stdin - output to preForth.asm
-preForth.asm: preForth.pre preForth-i386-backend.pre load-i386-preForth.fs
- cat preForth-i386-rts.pre preForth-rts.pre preForth-i386-backend.pre preForth.pre \
- | $(HOSTFORTH) load-i386-preForth.fs >preForth.asm
+# preForth connected to stdin - output to preForth$(DOTASM)
+preForth$(DOTASM): preForth.pre preForth-z80-backend.pre load-z80-preForth.fs
+ cat preForth-z80-rts.pre preForth-rts.pre preForth-z80-backend.pre preForth.pre \
+ | $(HOSTFORTH) load-z80-preForth.fs >preForth$(DOTASM)
-preForth: preForth.$(UNIXFLAVOUR)
- cp preForth.$(UNIXFLAVOUR) preForth
+%$(DOTASM): %.pre preForth$(DOTEXE) preForth-z80-rts.pre preForth-rts.pre
+ cat preForth-z80-rts.pre preForth-rts.pre $< | $(DOTSLASH)preForth$(DOTEXE) >$@
-%.asm: %.pre preForth preForth-i386-rts.pre preForth-rts.pre
- cat preForth-i386-rts.pre preForth-rts.pre $< | ./preForth >$@
-
-%: %.$(UNIXFLAVOUR)
+%$(DOTEXE): %-$(UNIXFLAVOUR)
cp $< $@
# assemble and link executable on linux
-%.Linux: %.asm
+%-Linux: %$(DOTASM)
fasm $< $@.o
LDEMULATION=elf_i386 ld -arch i386 -o $@ \
-dynamic-linker /lib32/ld-linux.so.2 \
# rm $@.o
# assemble and link executable on MacOS
-%.Darwin: %.asm
+%-Darwin: %$(DOTASM)
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
+# assemble and link executable on z80
+%-z80: %$(DOTASM)
+ cp $< $@$(DOTASM)
+ bin/asz80 -l -o $@$(DOTASM)
+ bin/aslink -n -m -u -i $@.ihx $@.rel
+ python3 ~/.local/bin/hex2bin.py $@.ihx $@
+ # rm $@.ihx $@.map $@.rst $@.hlr $@.lst $@.rel $@$(DOTASM)
+
# run preForth on its own source code to perform a bootstrap
# should produce identical results
-bootstrap: preForth preForth-i386-backend.pre preForth.pre preForth.$(EXT)
- cat preForth-i386-rts.pre preForth-rts.pre preForth-i386-backend.pre preForth.pre\
- | ./preForth >preForth1.$(EXT)
- cmp preForth.$(EXT) preForth1.$(EXT)
+bootstrap: preForth preForth-z80-backend.pre preForth.pre preForth$(DOTASM)
+ cat preForth-z80-rts.pre preForth-rts.pre preForth-z80-backend.pre preForth.pre\
+ | $(DOTSLASH)preForth$(DOTEXE) >preForth1$(DOTASM)
+ cmp preForth$(DOTASM) preForth1$(DOTASM)
# 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
+visible-bootstrap: preForth$(DOTEXE) preForth-z80-backend.pre preForth.pre
+ cat preForth-z80-backend.pre preForth.pre | $(DOTSLASH)preForth$(DOTEXE)
# ------------------------------------------------------------------------
# Docker support (for Linux version)
# ------------------------------------------------------------------------
# seedForth
# ------------------------------------------------------------------------
-seedForth.$(EXT): seedForth-i386.pre preForth
- cat seedForth-i386.pre | ./preForth >seedForth.$(EXT)
+seedForth$(DOTASM): seedForth-z80.pre preForth$(DOTEXE)
+ cat seedForth-z80.pre | $(DOTSLASH)preForth$(DOTEXE) >seedForth$(DOTASM)
seedForth: seedForth.$(UNIXFLAVOUR)
cp seedForth.$(UNIXFLAVOUR) seedForth
.PHONY=clean
clean:
- rm -f *.asm *.o *.fas *.s *.c *.Darwin *.Linux preForthdemo preForth forth seedForth seedForthDemo.seed seedForthInteractive.seed
+ rm -f *$(DOTASM) *.o *.fas *.s *.c *-Darwin *-Linux preForthdemo preForth forth seedForth seedForthDemo.seed seedForthInteractive.seed
--- /dev/null
+#!/bin/sh
+
+# put asxs5p30.zip in current directory first
+# wget http://shop-pdp.net/_ftp/asxxxx/asxs5p30.zip
+
+rm -rf asxxxx_build
+mkdir asxxxx_build
+(cd asxxxx_build && unzip -L -a ../asxs5p30)
+(cd asxxxx_build/asxv5pxx/asxmak/linux/build && make asz80 aslink)
+mkdir --parents bin
+cp asxxxx_build/asxv5pxx/asxmak/linux/exe/as* bin
--- /dev/null
+#!/bin/sh
+
+# put lib80-2.1.0.tar.gz in current directory first
+# wget https://sourceforge.net/settings/mirror_choices?projectname=libz80&filename=libz80/2.1/libz80-2.1.0.tar.gz&selected=master
+
+rm -rf libz80_build
+mkdir libz80_build
+(cd libz80_build && gunzip <../libz80-2.1.0.tar.gz |tar xvf -)
+(cd libz80_build/libz80 && make)
+mkdir --parents include lib
+cp libz80_build/libz80/z80.h include
+cp libz80_build/libz80/libz80.so lib
--- /dev/null
+\ load z80 preForth on top of a host Forth system
+
+include load-preForth.fs
+include preForth-z80-rts.pre
+include preForth-rts.pre
+include preForth-z80-backend.pre
+include preForth.pre
+
+cold
+
+bye
--- /dev/null
+\ --------------------------
+\ 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
+ 'X' swap '@' case? ?exit nip \ z80 does not use '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 and >"xxx" to output xxx on a new line indented by a tab.
+
+: ."dw" ( -- )
+ tab '.' emit 'd' emit 'w' emit tab ;
+
+: >"dw" ( -- )
+ cr ."dw" ;
+
+: ."db" ( -- )
+ tab '.' emit 'd' emit 'b' emit tab ;
+
+: >"db" ( -- )
+ cr ."db" ;
+
+: >"ds" ( -- )
+ cr tab '.' emit 'd' emit 's' emit tab ;
+
+: ."call" ( -- )
+ tab 'c' emit 'a' emit 'l' emit 'l' emit tab ;
+
+: >"call" ( -- )
+ cr ."call" ;
+
+\ note: "nest" is not a defined word accessed via "dw", it's accessed via
+\ "call" and hence does not get altered which would prepend an underscore
+: ."nest" ( -- )
+ 'n' emit 'e' emit 's' emit 't' emit ;
+
+: ."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 -- )
+ \ ."ds" show ;
+ ?dup 0= ?exit
+ dup roll >"db" u. \ 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 ;
+
+\ compile a reference to an invoked word on a new line
+\ NO -- put newline after (as don't want newline after ...X: label)
+: ,>word ( S -- )
+ \ >"dw" alter show ;
+ ."dw" alter show cr ;
+
+\ compile reference to nest primitive
+: ,nest ( -- )
+ ."call" ."nest" ;
+
+\ compile reference to unnest primitive
+: ,unnest ( -- )
+ \ >"dw" ."unnest"
+ \ cr ;
+ ."dw" ."unnest" cr ;
+
+\ compile signed number
+: ,n ( n -- )
+ >"dw" . ;
+
+\ compile unsigned number
+: ,u ( u -- )
+ >"dw" u. ;
+
+\ compile literal
+: ,_lit ( S -- )
+ \ >"dw" ."lit" ,>word ;
+ ."dw" ."lit" cr ,>word ;
+
+\ compile literal
+: ,lit ( x -- )
+ \ >"dw" ."lit" ,n ;
+ ."dw" ."lit" ,n cr ;
+
+\ output string as comment
+: ,comment ( S -- )
+ cr tab ';' emit space show ;
+
+\ create a new symbolic label
+\ if label is 6 characters or less, following code is on same line
+: label ( S -- )
+ \ cr alter show ':' emit tab ;
+ cr 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 ;
+ label ;
+
+: ,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 ;
+
--- /dev/null
+\ preForth runtime system - z80 dependent part
+\ --------------------------
+\
+\ - registers:
+\ HL, DE general purpose
+\ BC instruction pointer
+\ IX return stack pointer
+\ SP data stack pointer
+
+pre
+; This is a preForth generated file using preForth-z80-backend.
+; Only modify it, if you know what you are doing.
+
+; I/O ports for communication with unix host
+STDIN_PORT = 0
+STDOUT_PORT = 1
+STDERR_PORT = 2
+SYSTEM_PORT = 3
+
+; readable status bits
+SYSTEM_STDIN_EOF = 1
+SYSTEM_STDIN_READY = 2
+SYSTEM_STDOUT_READY = 4
+SYSTEM_STDERR_READY = 8
+
+; writeable command bits
+SYSTEM_EXITCODE = 0x3f
+SYSTEM_EXIT = 0x40
+SYSTEM_YIELD = 0x80
+
+DATA_STACK_SIZE = 0x1000
+RETURN_STACK_SIZE = 0x1000
+
+ .area text
+
+main: ld ix,return_stack + RETURN_STACK_SIZE
+ ld sp,data_stack + DATA_STACK_SIZE
+ ld bc,main1
+ jp next
+
+main1: .dw _cold
+ .dw _bye
+
+ .area bss
+
+return_stack:
+ .ds RETURN_STACK_SIZE
+data_stack:
+ .ds DATA_STACK_SIZE
+
+ .area text
+;
+
+code bye ( -- )
+ ld a,SYSTEM_EXIT
+ out (SYSTEM_PORT),a
+;
+
+pre
+
+emit_loop:
+ ld a,SYSTEM_YIELD
+ out (SYSTEM_PORT),a
+;
+
+code emit ( c -- )
+ in a,(SYSTEM_PORT)
+ and SYSTEM_STDOUT_READY
+ jr z,emit_loop
+ pop hl
+ ld a,l
+ out (STDOUT_PORT),a
+ jr next
+;
+
+pre
+
+key_loop:
+ ld a,SYSTEM_YIELD
+ out (SYSTEM_PORT),a
+;
+
+code key ( -- c )
+ in a,(SYSTEM_PORT)
+
+ ; test SYSTEM_STDIN_EOF bit
+ rra
+ ld l,4 ; eot
+ jr c,key_done
+
+ ; test SYSTEM_STDIN_READY bit
+ rra
+ jr nc,key_loop
+
+ in a,(STDIN_PORT)
+ ld l,a
+key_done:
+ ld h,0
+ push hl
+ jr next
+;
+
+code dup ( x -- x x )
+ pop hl
+ push hl
+ push hl
+ jr next
+;
+
+code swap ( x y -- y x )
+ pop de
+ pop hl
+ push de
+ push hl
+ jr next
+;
+
+code drop ( x -- )
+ pop hl
+ jr next
+;
+
+code 0< ( x -- flag )
+ pop hl
+ add hl,hl
+ ld hl, 0
+ jr nc,zless1
+ dec hl
+zless1: push hl
+ jr next
+;
+
+code ?exit ( f -- )
+ pop hl
+ ld a,l
+ or h
+ jr z,next
+ ld c,(ix)
+ inc ix
+ ld b,(ix)
+ inc ix
+ jr next
+;
+
+code >r ( x -- ) ( R -- x )
+ pop hl
+ dec ix
+ ld (ix),h
+ dec ix
+ ld (ix),l
+ jr next
+;
+
+code r> ( R x -- ) ( -- x )
+ ld l,(ix)
+ inc ix
+ ld h,(ix)
+ inc ix
+ push hl
+ jr next
+;
+
+code - ( x1 x2 -- x3 )
+ 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
+pre
+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 unnest ( -- )
+ ld c,(ix)
+ inc ix
+ ld b,(ix)
+ inc ix
+ jr next
+;
+
+code lit ( -- )
+ ld a,(bc)
+ ld l,a
+ inc bc
+ ld a,(bc)
+ ld h,a
+ inc bc
+ push hl
+ jr next
+;
#!/bin/bash
stty raw -echo
-cat seedForthInteractive.seed hi.forth - | ./seedForth
+cat seedForthInteractive.seed hi.forth - |LD_LIBRARY_PATH=lib ./z80 seedForth.bin
+echo "exitcode $?"
stty sane
dup + ;
: cells ( x1 -- x2 )
- 2* 2* ;
+ 2* ; / 2* 2* ;
: +! ( x addr -- )
swap >r dup @ r> + swap ! ;
--- /dev/null
+\ seedForth - seed it, feed it, grow it - z80 flavour uho 2018-04-13
+\ ----------------------------------------------------------------------------------
+\
+\ - registers:
+\ HL, DE general purpose
+\ BC instruction pointer
+\ IX return stack pointer
+\ SP data stack pointer
+
+pre
+; This is seedForth - a small, potentially interactive Forth, that dynamically
+; bootstraps from a minimal kernel.
+
+; I/O ports for communication with unix host
+STDIN_PORT = 0
+STDOUT_PORT = 1
+STDERR_PORT = 2
+SYSTEM_PORT = 3
+
+; readable status bits
+SYSTEM_STDIN_EOF = 1
+SYSTEM_STDIN_READY = 2
+SYSTEM_STDOUT_READY = 4
+SYSTEM_STDERR_READY = 8
+
+; writeable command bits
+SYSTEM_EXITCODE = 0x3f
+SYSTEM_EXIT = 0x40
+SYSTEM_YIELD = 0x80
+
+DATA_STACK_SIZE = 0x1000
+RETURN_STACK_SIZE = 0x1000
+HEAD_SIZE = 0x1000
+
+ .area text
+
+main: ld ix,return_stack + RETURN_STACK_SIZE
+ ld sp,data_stack + DATA_STACK_SIZE
+ ld bc,main1
+ jp next
+
+main1: .dw _cold
+ .dw _bye
+
+ .area bss
+
+return_stack:
+ .ds RETURN_STACK_SIZE
+data_stack:
+ .ds DATA_STACK_SIZE
+
+ ; dictionary pointer: points to next free location in memory
+ ; free memory starts at _start
+_dp: .dw _start
+
+ ; head pointer: index of first unused head
+__hp: .dw 0
+_head: .ds HEAD_SIZE ; note: must be initialized to 0
+
+_start:
+
+_memtop = 0 ; memory is available from start until wraps around to here
+
+ .area text
+;
+
+code bye ( -- )
+ ld a,SYSTEM_EXIT
+ out (SYSTEM_PORT),a
+;
+
+pre
+
+emit_loop:
+ ld a,SYSTEM_YIELD
+ out (SYSTEM_PORT),a
+;
+
+code emit ( c -- )
+ in a,(SYSTEM_PORT)
+ and SYSTEM_STDOUT_READY
+ jr z,emit_loop
+ pop hl
+ ld a,l
+ out (STDOUT_PORT),a
+ jr next
+;
+
+pre
+
+key_loop:
+ ld a,SYSTEM_YIELD
+ out (SYSTEM_PORT),a
+;
+
+code key ( -- c )
+ in a,(SYSTEM_PORT)
+
+ ; test SYSTEM_STDIN_EOF bit
+ rra
+ ld l,4 ; eot
+ jr c,key_done
+
+ ; test SYSTEM_STDIN_READY bit
+ rra
+ jr nc,key_loop
+
+ in a,(STDIN_PORT)
+ ld l,a
+key_done:
+ ld h,0
+ push hl
+ jr next
+;
+
+code key? ( -- f )
+ in a,(SYSTEM_PORT)
+ and SYSTEM_STDIN_EOF | SYSTEM_STDIN_READY
+ jr z,keyQ_done
+ ld a,1
+keyQ_done:
+ ld l,a
+ ld h,0
+ push hl
+ jr next
+;
+
+code dup ( x -- x x )
+ pop hl
+ push hl
+ push hl
+ jr next
+;
+
+code swap ( x y -- y x )
+ pop de
+ pop hl
+ push de
+ push hl
+ jr next
+;
+
+code drop ( x -- )
+ pop hl
+ jr next
+;
+
+code 0< ( x -- flag )
+ pop hl
+ add hl,hl
+ ld hl, 0
+ jr nc,zless1
+ dec hl
+zless1: push hl
+ jr next
+;
+
+code ?exit ( f -- )
+ pop hl
+ ld a,l
+ or h
+ jr z,next
+ ld c,(ix)
+ inc ix
+ ld b,(ix)
+ inc ix
+ jr next
+;
+
+code >r ( x -- ) ( R -- x )
+ pop hl
+ dec ix
+ ld (ix),h
+ dec ix
+ ld (ix),l
+ jr next
+;
+
+code r> ( R x -- ) ( -- x )
+ ld l,(ix)
+ inc ix
+ ld h,(ix)
+ inc ix
+ push hl
+ jr next
+;
+
+code - ( x1 x2 -- x3 )
+ 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 enter ( -- )
+
+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 dodoes ( -- addr )
+ dec ix
+ ld (ix),b
+ dec ix
+ ld (ix),c
+ ;mov esi,[eax-4] ; set IP
+ ; fall into dovar
+ ld a,SYSTEM_EXIT | 1
+ out (SYSTEM_PORT),a
+;
+
+code dovar ( -- addr )
+ ;lea eax,[eax+4] ; to parameter field
+ ;push eax
+ ld a,SYSTEM_EXIT | 2
+ out (SYSTEM_PORT),a
+ jr next
+;
+
+code or ( x1 x2 -- x3 )
+ 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 de
+ pop hl
+ ld a,l
+ and e
+ ld l,a
+ ld a,h
+ and d
+ ld h,a
+ push hl
+ jr next
+;
+
+code unnest ( -- )
+_exit: ld c,(ix)
+ inc ix
+ ld b,(ix)
+ inc ix
+ jr next
+;
+
+code lit ( -- )
+ ld a,(bc)
+ ld l,a
+ inc bc
+ ld a,(bc)
+ ld h,a
+ inc bc
+ push hl
+ jr next
+;
+
+code @ ( addr -- x )
+ pop hl
+ ld e,(hl)
+ inc hl
+ ld d,(hl)
+ push de
+ jr next
+;
+
+code c@ ( c-addr -- c )
+ pop hl
+ ld e,(hl)
+ ld d,0
+ push de
+ jr next
+;
+
+code ! ( x addr -- )
+ pop hl
+ pop de
+ ld (hl),e
+ inc hl
+ ld (hl),d
+ jr next
+;
+
+code c! ( c c-addr -- )
+ 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 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 ;
+ 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 hl
+ ld a,l
+ or h
+ jr z,_branch
+ inc bc
+ inc bc
+ jr next
+;
+
+code depth ( -- n )
+ ld hl,data_stack + DATA_STACK_SIZE
+ or a
+ sbc hl,sp ; should leave cf = 0
+ ld a,h
+ rra
+ ld h,a
+ ld a,l
+ rra
+ ld l,a
+ push hl
+ jr next1
+;
+
+code sp@ ( -- x )
+ ld hl,0
+ add hl,sp
+ push hl
+ jr next1
+;
+
+code sp! ( x -- )
+ pop hl
+ ld sp,hl
+ jr next1
+;
+
+code rp@ ( -- x )
+ push ix
+ jr next1
+;
+
+code rp! ( x -- )
+ pop ix
+ jr next1
+;
+
+code um* ( u1 u2 -- ud )
+ exx ; preserve bc
+
+ pop de ; pop u2
+ pop bc ; pop u1
+
+ ld hl,0
+ ld a,b
+ ld b,16
+ or a
+umul_loop:
+ rr h
+ rr l
+ rra
+ rr c
+ jr nc,umul_skip
+ add hl,de ; can't overflow, leaves cf = 0
+umul_skip:
+ djnz umul_loop
+ ld b,a
+
+ push bc ; push ud lo
+ push hl ; push ud hi
+
+ exx
+ jr next1
+;
+
+code um/mod ( ud u1 -- u2 u3 )
+ exx ; preserve bc
+
+ pop bc ; pop u1
+ pop hl ; pop ud hi
+ pop de ; pop ud lo
+
+ ld a,16
+ or a
+udiv_loop:
+ ex de,hl
+ adc hl,hl
+ ex de,hl
+ adc hl,hl ; can't overflow, leaves cf = 0
+ sbc hl,bc
+ jr nc,udiv_skip
+ add hl,bc
+udiv_skip:
+ dec a
+ jr nz,udiv_loop
+ ex de,hl
+ adc hl,hl
+
+ push de ; push u2 (remainder)
+ push hl ; push u1 (quotient)
+
+ exx
+ jr next1
+;
+
+code usleep ( c -- )
+ pop hl
+ ; ignore argument for now
+ ld a,SYSTEM_YIELD
+ out (SYSTEM_PORT),a
+next1: ld a,(bc)
+ ld l,a
+ inc bc
+ ld a,(bc)
+ ld h,a
+ inc bc
+ jp (hl)
+;
+
+: 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 ;
+
+\ pre
+\ _start: DB 43
+\ DD 100000 dup (0)
+\ _memtop: DD 0
+\ ;
--- /dev/null
+#include <fcntl.h>
+#include <stdbool.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <unistd.h>
+#include "z80.h"
+
+// I/O ports for communication with unix host
+#define STDIN_PORT 0
+#define STDOUT_PORT 1
+#define STDERR_PORT 2
+#define SYSTEM_PORT 3
+
+// readable status bits
+#define SYSTEM_STDIN_EOF 1
+#define SYSTEM_STDIN_READY 2
+#define SYSTEM_STDOUT_READY 4
+#define SYSTEM_STDERR_READY 8
+
+// writeable command bits
+#define SYSTEM_EXITCODE 0x3f
+#define SYSTEM_EXIT 0x40
+#define SYSTEM_YIELD 0x80
+
+uint8_t mem[0x10000];
+
+#define STDIN_FILENO 0
+#define STDOUT_FILENO 1
+#define STDERR_FILENO 2
+#define N_STDIO_FILENO 3
+
+#define STDIO_BUFFER_SIZE 0x100
+struct stdio_buffer {
+ uint8_t data[STDIO_BUFFER_SIZE];
+ int head;
+ int count;
+} stdin_buffer, stdout_buffer, stderr_buffer;
+bool stdin_eof;
+
+byte memRead(int param, ushort address) {
+ return mem[address];
+}
+
+void memWrite(int param, ushort address, byte data) {
+ mem[address] = data;
+}
+
+// single-character reads from buffer
+bool stdio_buffer_read(struct stdio_buffer *self, uint8_t *c) {
+ if (self->count == 0)
+ return false;
+ *c = self->data[self->head];
+ --self->count;
+ self->head =
+ self->count ? (self->head + 1) & (STDIO_BUFFER_SIZE - 1) : 0;
+ return true;
+}
+
+// bulk reads from buffer, done in two calls
+// first call gets pointer to contiguous data and how much available
+// second call says how much available data was taken
+uint8_t *stdio_buffer_read0(struct stdio_buffer *self, int *count) {
+ *count = self->count;
+ return self->data + self->head;
+}
+
+void stdio_buffer_read1(struct stdio_buffer *self, int count) {
+ self->count -= count;
+ self->head =
+ self->count ? (self->head + count) & (STDIO_BUFFER_SIZE - 1) : 0;
+}
+
+// single-character writes to buffer
+bool stdio_buffer_write(struct stdio_buffer *self, uint8_t c) {
+ if (self->count >= STDIO_BUFFER_SIZE)
+ return false;
+ self->data[(self->head + self->count++) & (STDIO_BUFFER_SIZE - 1)] = c;
+ return true;
+}
+
+// bulk writes to buffer, done in two calls
+// first call gets pointer to contiguous space and how much available
+// second call says how much available space was filled
+uint8_t *stdio_buffer_write0(struct stdio_buffer *self, int *count) {
+ *count = STDIO_BUFFER_SIZE - (
+ self->head > self->count ? self->head : self->count
+ );
+ return self->data + ((self->head + self->count) & (STDIO_BUFFER_SIZE - 1));
+}
+
+void stdio_buffer_write1(struct stdio_buffer *self, int count) {
+ self->count += count;
+}
+
+void stdio_service(int in_thres, int out_thres) {
+ if (
+ stdin_buffer.count < in_thres ||
+ stdout_buffer.count >= out_thres ||
+ stderr_buffer.count >= out_thres
+ ) {
+ fd_set readfds, writefds;
+ FD_ZERO(&readfds);
+ FD_SET(STDIN_FILENO, &readfds);
+ FD_ZERO(&writefds);
+ FD_SET(STDOUT_FILENO, &writefds);
+ FD_SET(STDERR_FILENO, &writefds);
+ struct timeval timeout;
+ timeout.tv_sec = 0;
+ timeout.tv_usec = 0;
+ if (select(N_STDIO_FILENO, &readfds, &writefds, NULL, &timeout) == -1) {
+ perror("select()");
+ exit(EXIT_FAILURE);
+ }
+
+ if (
+ stdin_buffer.count < in_thres &&
+ FD_ISSET(STDIN_FILENO, &readfds)
+ ) {
+ int count;
+ uint8_t *data = stdio_buffer_write0(&stdin_buffer, &count);
+ ssize_t result = read(STDIN_FILENO, data, count);
+ if (result == -1) {
+ perror("read()");
+ exit(EXIT_FAILURE);
+ }
+ if (result == 0)
+ stdin_eof = true;
+ stdio_buffer_write1(&stdin_buffer, (int)result);
+ }
+
+ if (
+ stdout_buffer.count >= out_thres &&
+ FD_ISSET(STDOUT_FILENO, &writefds)
+ ) {
+ int count;
+ uint8_t *data = stdio_buffer_read0(&stdout_buffer, &count);
+ ssize_t result = write(STDOUT_FILENO, data, count);
+ if (result == -1) {
+ perror("write()");
+ exit(EXIT_FAILURE);
+ }
+ stdio_buffer_read1(&stdout_buffer, (int)result);
+ }
+
+ if (
+ stderr_buffer.count >= out_thres &&
+ FD_ISSET(STDERR_FILENO, &writefds)
+ ) {
+ int count;
+ uint8_t *data = stdio_buffer_read0(&stdout_buffer, &count);
+ ssize_t result = write(STDERR_FILENO, data, count);
+ if (result == -1) {
+ perror("write()");
+ exit(EXIT_FAILURE);
+ }
+ stdio_buffer_read1(&stderr_buffer, (int)result);
+ }
+ }
+}
+
+byte ioRead(int param, ushort address) {
+ switch (address & 0xff) {
+ case STDIN_PORT:
+ {
+ stdio_service(1, STDIO_BUFFER_SIZE);
+ uint8_t c = 0;
+ stdio_buffer_read(&stdin_buffer, &c);
+ return c;
+ }
+ case SYSTEM_PORT:
+ {
+ stdio_service(1, STDIO_BUFFER_SIZE);
+ uint8_t status = 0;
+ if (stdin_eof)
+ status |= SYSTEM_STDIN_EOF;
+ if (stdin_buffer.count)
+ status |= SYSTEM_STDIN_READY;
+ if (stdout_buffer.count < STDIO_BUFFER_SIZE)
+ status |= SYSTEM_STDOUT_READY;
+ if (stderr_buffer.count < STDIO_BUFFER_SIZE)
+ status |= SYSTEM_STDERR_READY;
+ return status;
+ }
+ }
+ return 0;
+}
+
+void ioWrite(int param, ushort address, byte data) {
+ switch (address & 0xff) {
+ case STDOUT_PORT:
+ stdio_service(1, STDIO_BUFFER_SIZE);
+ stdio_buffer_write(&stdout_buffer, data);
+ break;
+ case STDERR_PORT:
+ stdio_service(1, STDIO_BUFFER_SIZE);
+ stdio_buffer_write(&stderr_buffer, data);
+ break;
+ case SYSTEM_PORT:
+ stdio_service(1, 1); // flush everything first
+ if (data & SYSTEM_EXIT) {
+ while (stdout_buffer.count || stderr_buffer.count) {
+ usleep(1000);
+ stdio_service(1, 1);
+ }
+ exit(data & SYSTEM_EXITCODE);
+ }
+ if (data & SYSTEM_YIELD)
+ usleep(1000);
+ break;
+ }
+}
+
+int main(int argc, char **argv) {
+ if (argc < 2) {
+ printf("usage: %s filename.com\n", argv[0]);
+ exit(EXIT_FAILURE);
+ }
+
+ int fd = open(argv[1], O_RDONLY);
+ if (fd == -1) {
+ perror(argv[1]);
+ exit(EXIT_FAILURE);
+ }
+
+ ssize_t result = read(fd, mem, 0x10000);
+ if (result == -1) {
+ perror("read()");
+ exit(EXIT_FAILURE);
+ }
+#if 0
+ ushort len = result;
+ printf("len=%04x\n", len);
+#endif
+
+ close(fd);
+
+ Z80Context ctx;
+ memset(&ctx, 0, sizeof(Z80Context));
+ ctx.memRead = memRead;
+ ctx.memWrite = memWrite;
+ ctx.ioRead = ioRead;
+ ctx.ioWrite = ioWrite;
+
+ Z80RESET(&ctx);
+#if 0
+ while (true) {
+ printf(
+ "pc=%04x af=%04x bc=%04x de=%04x hl=%04x ix=%04x iy=%04x sp=%04x\n",
+ ctx.PC,
+ ctx.R1.wr.AF,
+ ctx.R1.wr.BC,
+ ctx.R1.wr.DE,
+ ctx.R1.wr.HL,
+ ctx.R1.wr.IX,
+ ctx.R1.wr.IY,
+ ctx.R1.wr.SP
+ );
+ fflush(stdout);
+ if (ctx.PC >= len) {
+ fprintf(stderr, "pc %04x out of bounds\n", ctx.PC);
+ exit(EXIT_FAILURE);
+ }
+ Z80Execute(&ctx);
+ }
+#else
+ while (true)
+ Z80ExecuteTStates(&ctx, 1000);
+#endif
+}
public / preForth.git / commitdiff