\ --------------------------
-\ preForth backend for i386 (32 bit) FASM
+\ preForth backend for z80 as-z80
\ --------------------------
\ alter substitutes non-letter characters by upper case letters (to aid assemblers to deal with labels).
'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
+ 'X' swap '@' case? ?exit nip \ may clash with 'X' suffix for machine code
'Y' swap ')' case? ?exit nip
'Z' swap ';' case? ?exit nip
;
: >"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
+\ note: for z80 we have renamed "nest" to "enter" for standardization
: ."nest" ( -- )
- 'n' emit 'e' emit 's' emit 't' emit ;
+ 'e' 'n' 't' 'e' 'r' 5 alter show ;
+\ note: for z80 we have renamed "unnest" to "exit" for standardization
: ."unnest" ( -- )
- 'u' 'n' 'n' 'e' 's' 't' 6 alter show ;
+ 'e' 'x' 'i' 't' 4 alter show ;
: ."lit" ( -- )
'l' 'i' 't' 3 alter show ;
; dictionary pointer: points to next free location in memory
; free memory starts at _start
-_dp: .dw _start
+_dp: .dw _start
; head pointer: index of first unused head
__hp: .dw 0
-_head: .ds HEAD_SIZE ; note: must be initialized to 0
+_head: .ds HEAD_SIZE ; note: must be initialized to 0
_start:
ld l,4 ; eot
jr c,key_done
- ; test SYSTEM_STDIN_READY bit
+ ; test SYSTEM_STDIN_READY bit
rra
jr nc,key_loop
ld a,l
or h
jr z,next
+ ; fall into _exit
+;
+
+code exit ( -- )
ld c,(ix)
inc ix
ld b,(ix)
;
\ put this in middle of the primitives to make it reachable by jr
-code enter ( -- )
-
-nest: dec ix
+\ 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
+code dodoes ( -- )
+_enter: dec ix
ld (ix),b
dec ix
ld (ix),c
pop bc
+_dovar:
next: ld a,(bc)
ld l,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
;
code and ( x1 x2 -- x3 )
- pop de
+ pop de
pop hl
ld a,l
and e
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
ld e,(hl)
ld d,0
push de
- jr next
+ jr next
;
code ! ( x addr -- )
pop hl
ld a,l
or h
- jr z,_branch
+ jr z,_branch
inc bc
inc bc
jr next
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
+ rr h
+ rr l
push hl
jr next1
;
ld hl,0
add hl,sp
push hl
- jr next1
+ jr next1
;
code sp! ( x -- )
pop hl
ld sp,hl
- jr next1
+ jr next1
;
code rp@ ( -- x )
push de ; push u2 (remainder)
push hl ; push u1 (quotient)
- exx
+ exx
jr next1
;
dup + ;
: cells ( x1 -- x2 )
- 2* 2* ;
+ 2* ; \ 2* 2* ;
: +! ( x addr -- )
swap >r dup @ r> + swap ! ;
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 h@ lit num - ?exit \ not num token: exit i.e. normal compile action
+ drop lit lit , num , \ generate lit x num call puts x on stack
+ r> drop tail compiler ;
+
+\ for z80 dtc implementation, 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 ?dup 0= ?exit ?lit
+ token ?dup 0= ?exit ?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 , ;
: fun ( -- )
new drop compiler ;
: $lit ( -- addr u )
r> dup 1 + dup >r swap c@ dup r> + >r ;
+\ 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 + ! ;
: unused ( -- u )
lit memtop here - ;
: cold ( -- )
- \ 's' emit 'e' dup emit emit 'd' emit 10 emit
+ '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
public / preForth.git / commitdiff