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 14 0 | Constant 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 , 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 , 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 case? IF ." forward" exit THEN 6 - Abort" type unknown" ." resolved " ; 7 8 | : .does-type ( cfa.does -- ) @ 9 case? IF ." forward-define" exit THEN 10 - 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 @ = 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 @ = 6 IF drop >name space .name ." exists" ?cr rdrop exit THEN 7 r> swap >r 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 @ = IF 2+ ! exit THEN swap resolve ; 13 14 ' Is> ( -- ) dup @ there rot ! T , H ; \ forward link 15 ' 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 : - cfa) H g' dup @ - 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 -2 H 2swap ; 8 immediate restrict 9 | : (repeat T 2 ?pairs 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