VolksForth/sources/cpm/target.fth

579 lines
36 KiB
Forth
Raw Normal View History

\ *** Block No. 0 Hexblock 0
\ 05Jul86
\ *** Block No. 1 Hexblock 1
\ Target compiler loadscr UH 07Jun86
\ Idea and first Implementation by ks/bp
\ Implemented on 6502 by ks/bp
\ ultraFORTH83-Version by bp/we
\ Atari 520 ST - Version by we
\ CP/M 2.2 Version by UH
Onlyforth hex Assembler nonrelocate
Vocabulary Ttools
Vocabulary Defining
1 10 +thru \ Target compiler
11 13 +thru \ Target Tools
14 16 +thru \ Redefinitions
save 17 20 +thru \ Predefinitions
Onlyforth
\ *** Block No. 2 Hexblock 2
\ Target header pointers UH 26Mar88
Create lastname $20 allot
Variable tdp : there tdp @ ;
Variable displace
Variable image
Variable ?thead ?thead off
Variable tlast tlast off
Variable glast' glast' off
Variable tdoes>
Variable >in:
Variable tvoc tvoc off
Variable tvoc-link tvoc-link off
0 | Constant <forw>
0 | Constant <res>
| : Is> ( cfa -- ) [compile] Does> here 3 - swap >body ! 0 ] ;
\ *** Block No. 3 Hexblock 3
\ Image and byteorder UH 26Mar88
Code c+! ( 8b addr -- )
H pop D pop E A mov M add A M mov Next end-code
Code /block ( addr -- +n blk )
H pop L E mov H A mov 3 ani A D mov
H A mov $FC ani rrc rrc A L mov 0 H mvi dpush jmp
end-code
: >image ( addr1 - addr2 )
displace @ ( - /block image @ + block ) + ;
: >heap ( from quan - ) dup hallot heap swap cmove ;
\\ : c+! ( 8b addr -- ) dup c@ rot + swap c! ;
: /block ( addr -- +n blk ) b/blk /mod ;
\ *** Block No. 4 Hexblock 4
\ Ghost-creating UH 26Mar88
| : (make.ghost ( str -- cfa.ghost ) dp push
count dup 1 $1F uwithin not Abort" invalid Ghostname"
here 2+ place
here state @ \ address of link field
IF context @ ELSE current THEN @ under @ , \ link
1 here c+! here c@ allot bl c, \ name
here over - swap \ offset to codefield
<forw> , 0 , 0 , \ code and parameter field
here over - >heap \ move to heap
heap rot ! \ link
heap + ; \ codefield address
| : Make.Ghost ( -- cfa.ghost ) name (make.ghost ;
\ *** Block No. 5 Hexblock 5
\ ghost words UH 28Apr88
: gfind ( string - cfa tf / string ff )
>r bl r@ count + c! 1 r@ c+! r@ find -1 r> c+! ;
: (ghost ( string -- cfa ) gfind ?exit (make.ghost ;
: ghost ( -- cfa ) name (ghost ;
: gdoes> ( cfa.ghost - cfa.does ) dp push
4+ dup @ IF @ exit THEN \ defined
here <forw> , 0 , 4 >heap \ forward-chain
heap dup rot ! ; \ forward-link
\ *** Block No. 6 Hexblock 6
\ ghost utilities 2UH 26Mar88
: g' ( -- cfa.ghost ) name gfind 0= abort" ?" ;
| : .ghost-type ( cfa.ghost -- ) @
<forw> case? IF ." forward" exit THEN
<res> - Abort" type unknown" ." resolved " ;
| : .does-type ( cfa.does -- ) @
<forw> case? IF ." forward-define" exit THEN
<res> - Abort" does-type unknown" ." resolved-define" ;
: '. ( -- ) g' dup .ghost-type dup 2+ @ 5 u.r
4+ @ ?dup 0=exit dup .does-type 2+ @ 5 u.r ;
' ' Alias h'
\ *** Block No. 7 Hexblock 7
\ .unresolved UH 26Mar88
| : forward? ( cfa -- f ) dup @ <forw> = swap 2+ @ and ;
| : ghost? ( nfa -- f ) count $1F and + 1- c@ bl = ;
| : unresolved? ( addr - f ) 2+
dup ghost? not IF drop false exit THEN
name> dup forward? IF drop true exit THEN
4+ @ forward? ;
| : unresolved-words ( thread -- ) BEGIN @ ?dup WHILE
dup unresolved? IF dup 2+ .name ?cr THEN REPEAT ;
: .unresolved ( -- ) voc-link @
BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ;
\ *** Block No. 8 Hexblock 8
\ Extending Vocabularys for Target-Compilation 2UH 26Mar88
: Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ;
Vocabulary Transient tvoc off
Root definitions
: T Transient ; immediate
: H Forth ; immediate
OnlyForth
\ *** Block No. 9 Hexblock 9
\ Transient primitives UH 26Mar88
Code byte> ( 8bl 8bh -- 16b )
D pop H pop E H mov hpush jmp end-code
Code >byte ( 16b -- 8bh 8bl )
H pop H E mov 0 H mvi H D mov dpush jmp end-code
Transient definitions
: c@ ( addr -- 8b ) H >image c@ ;
: c! ( 8b addr -- ) H >image c! ( update ) ;
: @ ( addr -- n ) dup T c@ H swap 1+ T c@ H byte> ;
: ! ( n addr -- ) >r >byte r@ T c! H r> 1+ T c! H ;
: cmove ( from.mem to.target quan -)
bounds ?DO dup H c@ I T c! H 1+ LOOP drop ;
: on ( addr -- ) true swap T ! H ;
: off ( addr -- ) false swap T ! H ;
\ *** Block No. 10 Hexblock A
\ Transient primitives UH 26Mar88
: here ( -- taddr ) there ;
: allot ( n -- ) Tdp +! ;
: c, ( c -- ) T here c! 1 allot H ;
: , ( n -- ) T here ! 2 allot H ;
: ," ( -- ) Ascii " parse
dup T c, under here swap cmove allot H ;
: fill ( addr len c -- )
-rot bounds ?DO dup I T c! H LOOP drop ;
: erase ( addr len -- ) 0 T fill H ;
: blank ( addr len -- ) bl T fill H ;
: here! ( addr -- ) H tdp ! ;
\ *** Block No. 11 Hexblock B
\ Resolving UH 26Mar88
Forth definitions
: resolve ( cfa.ghost cfa.target -- )
2dup swap >body dup @ >r ! over @ <res> =
IF drop >name space .name ." exists" ?cr rdrop exit THEN
r> swap >r <res> rot ! ?dup 0= IF rdrop exit THEN
BEGIN dup T @ H 2dup = abort" resolve loop"
r@ rot T ! H ?dup 0= UNTIL rdrop ;
: resdoes> ( cfa.ghost cfa.target -- )
swap gdoes> dup @ <res> = IF 2+ ! exit THEN swap resolve ;
' <forw> Is> ( -- ) dup @ there rot ! T , H ; \ forward link
' <res> Is> ( -- ) @ T , H ; \ compile target.cfa
\ *** Block No. 12 Hexblock C
\ move-threads UH 26Mar88
: move-threads Tvoc @ Tvoc-link @
BEGIN over ?dup
WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT
error" some undef. Target-Vocs left" drop ;
| : tlatest ( - addr) Current @ 6 + ;
: save-target \ filename
$100 dup >image there rot - savefile ;
\ *** Block No. 13 Hexblock D
\ compiling names into targ. UH 26Mar88
| : viewfield ( -- n ) H blk @ $200 + ; \ in File #1
: (theader ( -- ) ?thead @ IF 1 ?thead +! exit THEN
>in push
name dup c@ 1 $20 uwithin not abort" invalid Targetname"
viewfield T ,
H there tlatest @ T , H tlatest ! \ link
there dup tlast !
over c@ 1+ dup T allot cmove H ;
: Theader ( -- ) tlast off
(theader Ghost dup glast' ! there resolve ;
\ *** Block No. 14 Hexblock E
\ prebuild defining words bp2UH 26Mar88
| : executable? ( adr - adr f ) dup ;
| : tpfa, there , ;
| : (prebuild ( cfa.adr -- ) >in push Create here 2- ! ;
: prebuild ( adr 0.from.: - 0 ) 0 ?pairs
executable? dup >r
IF [compile] Literal compile (prebuild ELSE drop THEN
compile Theader Ghost gdoes> ,
r> IF compile tpfa, THEN 0 ; immediate restrict
\ *** Block No. 15 Hexblock F
\ code portion of def.words bp2UH 26Mar88
: dummy 0 ;
: DO> ( - adr.of.jmp.dodoes> 0 )
[compile] Does> here 3 - compile @ 0 ] ;
\ *** Block No. 16 Hexblock 10
\ The Target-Assembler UH 26Mar88
Forth definitions
| Create relocate ] T c, , c@ here allot ! c! H [
Transient definitions
: Assembler H [ Assembler ] relocate >codes ! Assembler ;
: >label ( 16b -) H >in @ name gfind rot >in !
IF over resolve dup THEN drop Constant ;
: Label H there T >label Assembler H ;
: Code H Theader there 2+ T , Assembler H ;
\ *** Block No. 17 Hexblock 11
\ immed. restr. ' \ compile bp2UH 26Mar88
: ?pairs ( n1 n2 -- ) H - abort" unstructured" ;
: >mark ( - addr) H there T 0 , H ;
: >resolve ( addr -) H there over - swap T ! H ;
: <mark ( - addr) H there ;
: <resolve ( addr -) H there - T , H ;
: immediate H Tlast @ ?dup 0=exit dup T c@ $40 or swap c! H ;
: restrict H Tlast @ ?dup 0=exit dup T c@ $80 or swap c! H ;
: ' ( <name> - cfa) H g' dup @ <res> - abort" ?" 2+ @ ;
: | H ?thead @ ?exit ?thead on ;
: compile H Ghost , ; immediate restrict
\ *** Block No. 18 Hexblock 12
\ Target tools UH 26Mar88
Onlyforth Ttools also definitions
| : ttype ( adr n -) bounds ?DO I T c@ H dup
bl > IF emit ELSE drop ascii . emit THEN LOOP ;
: .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype
ELSE ." ??? " THEN space ?cr ;
| : nfa? ( cfa lfa - nfa / cfa ff)
BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ =
IF 2+ nip exit THEN T @ H REPEAT ;
: >name ( cfa - nfa / ff)
Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup
IF nip exit THEN swap REPEAT nip ;
\ *** Block No. 19 Hexblock 13
\ Ttools for decompiling ks29jun85we
| : ?: dup 4 u.r ." :" ;
| : @? dup T @ H 6 u.r ;
| : c? dup T c@ H 3 .r ;
: s ( adr - adr+) ?: space c? 3 spaces
dup 1+ over T c@ H ttype dup T c@ H + 1+ ;
: n ( adr - adr+2) ?: @? 2 spaces
dup T @ H [ Ttools ] >name .name H 2+ ;
: d ( adr n - adr+n) 2dup swap ?: swap 0 DO c? 1+ LOOP
2 spaces -rot ttype ;
\ *** Block No. 20 Hexblock 14
\ Tools for decompiling bp204dec85we
: l ( adr - adr+2) ?: 5 spaces @? 2+ ;
: c ( adr - adr+1) 1 d ;
: b ( adr - adr+1) ?: @? dup T @ H over + 5 u.r 2+ ;
: dump ( adr n -) bounds ?DO cr I 10 d drop stop?
IF LEAVE THEN 10 +LOOP ;
: view T ' H [ Ttools ] >name ?dup
IF 4 - T @ H list THEN ;
\ *** Block No. 21 Hexblock 15
\ reinterpretation def.-words UH 26Mar88
Onlyforth
: redefinition ( -- ) tdoes> @ 0=exit
>in push [ ' parser >body ] Literal push
state push context push
>in: @ >in ! name [ ' Transient 2+ ] Literal (find nip ?exit
cr ." Redefinition: " here .name
>in: @ >in ! : Defining interpret tdoes> off ;
\ *** Block No. 22 Hexblock 16
\ Create..does> structure 27Apr86
| : (;tcode Tlast @ dup T c@ + 1+ ! H rdrop ;
| : changecfa compile lit tdoes> @ , compile (;tcode ;
Defining definitions
: ;code 0 ?pairs changecfa reveal rdrop rdrop ;
immediate restrict
Defining ' ;code Alias does> immediate restrict
: ; [compile] ; rdrop rdrop ; immediate restrict
\ *** Block No. 23 Hexblock 17
\ redefinition conditionals bp27jun85we
' DO Alias DO immediate restrict
' ?DO Alias ?DO immediate restrict
' LOOP Alias LOOP immediate restrict
' IF Alias IF immediate restrict
' THEN Alias THEN immediate restrict
' ELSE Alias ELSE immediate restrict
' BEGIN Alias BEGIN immediate restrict
' UNTIL Alias UNTIL immediate restrict
' WHILE Alias WHILE immediate restrict
' REPEAT Alias REPEAT immediate restrict
\ *** Block No. 24 Hexblock 18
\ clear Liter. Ascii ['] ." UH 26Mar88
Onlyforth Transient definitions
: clear True abort" There are ghosts" ;
: Literal ( n -) H dup $FF00 and IF T compile lit , H exit THEN
T compile clit c, H ; immediate
: Ascii H bl word 1+ c@
state @ 0=exit T [compile] Literal H ; immediate
: ['] T ' [compile] Literal H ; immediate restrict
: " T compile (" ," H ; immediate restrict
: ." T compile (." ," H ; immediate restrict
: even H ; immediate \ machen nichts beim 8080
: align H ; immediate
: halign H ; immediate
\ *** Block No. 25 Hexblock 19
\ Target compilation ] [ bp0UH 26Mar88
Forth definitions
: tcompile ( str -- ) count lastname place
lastname find ?dup
IF 0> IF execute exit THEN drop lastname THEN
gfind IF execute exit THEN
number? ?dup
IF 0> IF swap T [compile] Literal THEN
[compile] Literal H exit THEN
(ghost execute ;
Transient definitions
: ] H State on ['] tcompile is parser ;
\ *** Block No. 26 Hexblock 1A
\ Target conditionals bp27jun85we
: IF T compile ?branch >mark H 1 ; immediate restrict
: THEN abs 1 T ?pairs >resolve H ; immediate restrict
: ELSE T 1 ?pairs compile branch >mark swap >resolve
H -1 ; immediate restrict
: BEGIN T <mark H 2 ; immediate restrict
: WHILE T 2 ?pairs 2 compile ?branch >mark -2 H 2swap ;
immediate restrict
| : (repeat T 2 ?pairs <resolve H BEGIN dup -2 =
WHILE drop T >resolve H REPEAT ;
: UNTIL T compile ?branch (repeat H ; immediate restrict
: REPEAT T compile branch (repeat H ; immediate restrict
\ *** Block No. 27 Hexblock 1B
\ Target conditionals bp27jun85we
: DO T compile (do >mark H 3 ; immediate restrict
: ?DO T compile (?do >mark H 3 ; immediate restrict
: LOOP T 3 ?pairs compile (loop compile endloop
>resolve H ; immediate restrict
: +LOOP T 3 ?pairs compile (+loop compile endloop
>resolve H ; immediate restrict
\ *** Block No. 28 Hexblock 1C
\ predefinitions bp27jun85we
: abort" T compile (abort" ," H ; immediate
: error" T compile (err" ," H ; immediate
Forth definitions
Variable torigin
Variable tudp 0 tudp !
: >user T c@ H torigin @ + ;
\ *** Block No. 29 Hexblock 1D
\ Datatypes bp2UH 07Nov87
Transient definitions
: origin! H torigin ! ;
: user' ( - 8b) T ' 2 + c@ H ;
: uallot ( n -) H tudp @ swap tudp +! ;
DO> >user ;
: User prebuild User 2 T uallot c, ;
DO> ;
: Create prebuild (create ;
DO> T @ H ;
: Constant prebuild Constant T , ;
: Variable Create 2 T allot ;
\ *** Block No. 30 Hexblock 1E
\ Datatypes UH 07Nov87
dummy
: Vocabulary
H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 ,
here H tvoc-link @ T , H tvoc-link ! ;
dummy
: (create prebuild (create ;
\ *** Block No. 31 Hexblock 1F
\ target defining words 27Apr86
Do> ;
: Defer prebuild Defer 2 T allot ;
: Is T ' H >body State @ IF T compile (is , H
ELSE T ! H THEN ; immediate
| : dodoes> T compile (;code H Glast' @
there resdoes> there tdoes> ! ;
: ;code 0 T ?pairs dodoes> Assembler H [compile] [
redefinition ; immediate restrict
: does> T dodoes> $CD c,
compile (dodoes> H ; immediate restrict
\ *** Block No. 32 Hexblock 20
\ : Alias ; bUH 07Jun86
dummy
: : H tdoes> off >in @ >in: ! T prebuild :
H current @ context ! T ] H 0 ;
: Create: Create H current @ context ! T ] H 0 ;
: Alias ( n -- ) H Tlast off (theader Ghost over resolve
tlast @ T c@ H 20 or tlast @ T c! , H ;
: ; T 0 ?pairs compile unnest [compile] [ H redefinition ;
immediate restrict
\ *** Block No. 33 Hexblock 21
\ predefinitions UH 26Mar88
: compile T compile compile H ; immediate restrict
: Host H Onlyforth Ttools also ;
: Compiler T Host H Transient also definitions ;
: [compile] H ghost execute ; immediate restrict
\ : Onlypatch H there 3 - 0 tdoes> ! 0 ;
Onlyforth
: Target Onlyforth Transient also definitions ;
Transient definitions
Ghost c, drop