VolksForth/sources/cpm/TARGET.FB.src

579 lines
37 KiB
Plaintext
Raw Normal View History

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