Screen 0 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 1 not modified 0 \ Target compiler loadscr ks cas 09jun20 1 Onlyforth \needs Assembler 2 loadfrom asm.fb 2 3 : c+! ( 8b addr -- ) dup c@ rot + swap c! ; 4 5 ' find $22 + @ Alias found 6 7 : search ( string 'vocab -- acf n / string ff ) 8 dup @ [ ' Forth @ ] Literal - Abort" no vocabulary" 9 >body (find IF found exit THEN false ; 10 11 3 &27 thru Onlyforth savesystem meta.com 12 13 cr .( Metacompiler saved as META.COM ) 14 15 Screen 2 not modified 0 \ Predefinitions loadscreen ks 30 apr 88 1 2 &28 load 3 4 cr .( Predefinitions geladen ...) cr 5 6 7 8 9 10 11 12 13 14 15 Screen 3 not modified 0 \ Target header pointers ks 29 jun 87 1 2 Variable tfile tfile off \ handle of target file 3 Variable tdp tdp off \ target dp 4 Variable displace displace off \ diplacement of code 5 Variable ?thead ?thead off \ for headerless code 6 Variable tlast tlast off \ last name in target 7 Variable glast' glast' off \ acf of latest ghost 8 Variable tdoes> tdoes> off \ code addr of last does 9 Variable tdodo tdodo off \ location of dodo 10 Variable >in: >in: off \ last :-def 11 Variable tvoc tvoc off \ 12 Variable tvoc-link tvoc-link off \ voc-link in target 13 Variable tnext-link tnext-link off \ link for tracer 14 15 Screen 4 not modified 0 \ Target header pointers ks 10 okt 87 1 2 : there ( -- taddr ) tdp @ ; 3 4 : new pushfile makefile isfile@ tfile ! 5 tvoc-link off tnext-link off 6 $100 tdp ! $100 displace ! ; 7 8 9 10 11 12 13 14 15 Screen 5 not modified 0 \ Ghost-creating ks 07 dez 87 1 2 0 | Constant 0 | Constant 3 4 | Create gname $21 allot 5 6 | : >heap ( from quan -- ) \ heap over - 1 and + \ align 7 dup hallot heap swap cmove ; 8 9 : symbolic ( string -- cfa.ghost ) 10 count dup 1 $1F uwithin not Abort" invalid Gname" 11 gname place BL gname append align here >r makeview , 12 state @ IF context ELSE current THEN @ @ dup @ , 13 gname count under here place 1+ allot align 14 here r@ - , 0 , 0 , r@ here over - >heap 15 heap 2+ rot ! r> dp ! heap + ; Screen 6 not modified 0 \ ghost words ks 07 dez 87 1 2 : gfind ( string -- cfa tf / string ff ) 3 >r 1 r@ c+! r@ find -1 r> c+! ; 4 5 : ghost ( -- cfa ) name gfind ?exit symbolic ; 6 7 : gdoes> ( cfa.ghost -- cfa.does ) 8 4 + dup @ IF @ exit THEN 9 here , 0 , dup 4 >heap 10 dp ! heap swap ! heap ; 11 12 13 14 15 Screen 7 not modified 0 \ ghost utilities ks 29 jun 87 1 2 : g' ( -- acf ) name gfind 0= Abort" ?T?" ; 3 4 : '. g' dup @ case? 5 IF ." forw" ELSE - Abort" ??" ." res" THEN 6 2+ dup @ 5 u.r 2+ @ ?dup 7 IF dup @ case? 8 IF ." fdef" ELSE - Abort" ??" ." rdef" THEN 9 2+ @ 5 u.r THEN ; 10 11 ' ' Alias h' 12 13 14 15 Screen 8 not modified 0 \ .unresolved ks 29 jun 87 1 2 | : forward? ( cfa -- cfa / exit&true ) 3 dup @ = 0=exit dup 2+ @ 0=exit drop true rdrop ; 4 5 | : unresolved? ( addr -- f ) 2+ 6 dup count $1F and + 1- c@ bl = 7 IF name> forward? 4+ @ dup IF forward? THEN 8 THEN drop false ; 9 10 | : unresolved-words ( thread -- ) 11 BEGIN @ ?dup WHILE dup unresolved? 12 IF dup 2+ .name ?cr THEN REPEAT ; 13 14 : .unresolved voc-link @ 15 BEGIN dup 4 - unresolved-words @ ?dup 0= UNTIL ; Screen 9 not modified 0 \ Extending Vocabularys for Target-Compilation ks 29 jun 87 1 2 Vocabulary Ttools 3 Vocabulary Defining 4 5 : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; 6 7 Vocabulary Transient tvoc off 8 9 Root definitions 10 11 : T Transient ; immediate 12 : H Forth ; immediate 13 : D Defining ; immediate 14 15 Forth definitions Screen 10 not modified 0 \ Image and byteorder ks 02 jul 87 1 2 | Code >byte ( 16b -- 8b- 8b+ ) A A xor 3 D- A- xchg D+ D- xchg A push Next end-code 4 5 | Code byte> ( 8b- 8b+ -- 16b ) 6 A pop D- D+ mov A- D- xchg Next end-code 7 8 | : >target ( addr1 -- daddr fcb ) displace @ - 0 tfile @ ; 9 10 Transient definitions 11 12 : c@ ( addr -- 8b ) [ Dos ] 13 >target file@ dup 0< Abort" nie abgespeichert" ; 14 15 : c! ( 8b addr -- ) [ Dos ] >target file! ; Screen 11 not modified 0 \ Transient primitives ks 09 jul 87 1 : @ ( addr -- n ) H dup T c@ swap 1+ c@ byte> ; 2 : ! ( n addr -- ) H >r >byte r@ 1+ T c! r> c! H ; 3 4 : cmove ( from.mem to.target quan -- ) [ Dos ] 5 >r >target fseek ds@ swap r> tfile @ lfputs ; 6 \ bounds ?DO dup c@ I T c! H 1+ LOOP drop ; 7 8 : here ( -- taddr ) H tdp @ ; 9 : here! ( taddr -- ) H tdp ! ; 10 : allot ( n -- ) H tdp +! ; 11 : c, ( 8b -- ) T here c! 1 allot H ; 12 : , ( 16b -- ) T here ! 2 allot H ; 13 : align ( -- ) H ; immediate 14 : even ( addr1 -- addr2 ) H ; immediate 15 : halign H ; immediate Screen 12 not modified 0 \ Transient primitives ks 29 jun 87 1 2 : count ( addr1 -- addr2 len ) H dup 1+ swap T c@ H ; 3 4 : ," H here ," here over dp ! 5 over - T here swap dup allot cmove H ; 6 7 : fill ( addr quan 8b -- ) H 8 -rot bounds ?DO dup I T c! H LOOP drop ; 9 : erase ( addr quan -- ) H 0 T fill H ; 10 : blank ( addr quan -- ) H bl T fill H ; 11 12 : move-threads H tvoc @ tvoc-link @ 13 BEGIN over ?dup 14 WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT 15 Error" some undef. Target-Vocs left" drop ; Screen 13 not modified 0 \ Resolving ks 29 jun 87 1 Forth definitions 2 3 : resolve ( cfa.ghost cfa.target -- ) over dup @ = 4 IF space dup >name .name ." exists " ?cr 5 2+ ! drop exit THEN >r >r 2+ @ ?dup 6 IF BEGIN dup T @ H 2dup = Abort" resolve loop" 7 r@ rot T ! H ?dup 0= UNTIL 8 THEN r> r> over ! 2+ ! ; 9 10 : resdoes> ( acf.ghost acf.target -- ) swap gdoes> 11 dup @ = IF 2+ ! exit THEN swap resolve ; 12 13 here 2+ 0 ] Does> dup @ there rot ! T , H ; ' >body ! 14 here 2+ 0 ] Does> @ T , H ; ' >body ! 15 Screen 14 not modified 0 \ compiling names into targ. ks 10 okt 87 1 2 | : tlatest ( -- addr ) current @ 6 + ; 3 4 : (theader ?thead @ IF 1 ?thead +! exit THEN 5 >in @ bl word swap >in ! dup count upper 6 dup c@ 1 $20 uwithin not Abort" inval. Tname" 7 blk @ $8400 or T align , H 8 there tlatest @ T , H tlatest ! there tlast ! 9 there over c@ 1+ dup T allot cmove align H ; 10 11 : theader tlast off 12 (theader ghost dup glast' ! there resolve ; 13 14 15 Screen 15 not modified 0 \ prebuild defining words ks 29 jun 87 1 2 | : (prebuild >in @ Create >in ! 3 r> dup 2+ >r @ here 2- ! ; 4 5 | : tpfa, there , ; 6 7 : prebuild ( addr check# -- check# ) 0 ?pairs 8 dup IF compile (prebuild dup , THEN 9 compile theader ghost gdoes> , 10 IF compile tpfa, THEN 0 ; immediate 11 12 : dummy 0 ; 13 14 : DO> [compile] Does> here 3 - compile @ 0 ] ; 15 Screen 16 not modified 0 \ Constructing defining words in Host kks 07 dez 87 1 2 | : defcomp ( string -- ) dup ['] Defining search ?dup 3 IF 0> IF nip execute exit THEN drop dup THEN 4 find ?dup IF 0< IF nip , exit THEN THEN 5 drop ['] Forth search ?dup 6 IF 0< IF , exit THEN execute exit THEN 7 number? ?dup 0= Abort" ?" 8 0> IF swap [compile] Literal THEN [compile] Literal ; 9 10 | : definter ( string -- ) dup ['] Defining search ?dup 11 IF 0< IF nip execute exit THEN THEN drop 12 find ?dup IF 1 and 0= Abort" compile only" execute exit 13 THEN number? 0= Error" ?" ; 14 15 Screen 17 not modified 0 \ Constructing defining words in Host ks 22 dez 87 1 2 | : (;tcode r> @ tlast @ T count + ! H ; 3 4 Defining definitions 5 6 : ] H ] ['] defcomp Is parser ; 7 8 : [ H [compile] [ ['] definter Is parser ; immediate 9 10 : ; H [compile] ; [compile] \\ ; immediate 11 12 : Does> H compile (;tcode tdoes> @ , 13 [compile] ; -2 allot [compile] \\ ; immediate 14 D ' Does> Alias ;Code immediate H 15 Screen 18 not modified 0 \ reinterpreting defining words ks 22 dez 87 1 Forth definitions 2 3 : ?reinterpret ( f -- ) 0=exit 4 state @ >r >in @ >r adr parser @ >r 5 >in: @ >in ! : D ] H interpret 6 r> Is parser r> >in ! r> state ! ; 7 8 : undefined? ( -- f ) glast' @ 4+ @ 0= ; 9 10 | : flag! ( 8b -- ) tlast @ ?dup 0= IF drop exit THEN 11 dup T c@ rot or swap c! H ; 12 13 | : nfa? ( acf alf -- anf / acf ff ) 14 BEGIN dup WHILE 2dup 2+ T count $1F and + even H = 15 IF 2+ nip exit THEN T @ H REPEAT ; Screen 19 not modified 0 \ the 8086 Assembler ks 29 jun 87 1 2 | Create relocate ] T c, , here ! c! H [ 3 4 Transient definitions 5 6 : Assembler H [ Assembler ] relocate >codes ! Assembler ; 7 8 : >label ( 16b -- ) H >in @ name gfind rot >in ! 9 IF over resolve dup THEN drop Constant ; 10 11 : Label T here >label Assembler H ; 12 13 : Code H theader T here 2+ , Assembler H ; 14 15 Screen 20 not modified 0 ( Transient primitives ks 17 dec 83 ) 1 2 ' exit Alias exit ' load Alias load 3 ' / Alias / ' thru Alias thru 4 ' swap Alias swap ' * Alias * 5 ' dup Alias dup ' drop Alias drop 6 ' /mod Alias /mod ' rot Alias rot 7 ' -rot Alias -rot ' over Alias over 8 ' 2* Alias 2* ' + Alias + 9 ' - Alias - ' 1+ Alias 1+ 10 ' 2+ Alias 2+ ' 1- Alias 1- 11 ' 2- Alias 2- ' negate Alias negate 12 ' 2swap Alias 2swap ' 2dup Alias 2dup 13 14 15 Screen 21 not modified 0 \ Transient primitives kks 29 jun 87 1 2 ' also Alias also ' words Alias words 3 ' definitions Alias definitions ' hex Alias hex 4 ' decimal Alias decimal ' ( Alias ( immediate 5 ' \ Alias \ immediate ' \\ Alias \\ immediate 6 ' .( Alias .( immediate ' [ Alias [ immediate 7 ' cr Alias cr 8 ' end-code Alias end-code ' Transient Alias Transient 9 ' +thru Alias +thru ' +load Alias +load 10 ' .s Alias .s 11 12 Tools ' trace Alias trace immediate 13 14 15 Screen 22 not modified 0 \ immediate words and branch primitives ks 29 jun 87 1 2 : >mark ( -- addr ) T here 0 , H ; 3 : >resolve ( addr -- ) T here over - swap ! H ; 4 : name ks 29 jun 87 1 2 : ' ( -- acf ) H g' dup @ - 3 IF Error" undefined" THEN 2+ @ ; 4 5 : compile H ghost , ; immediate restrict 6 7 : >name ( acf -- anf / ff ) H tvoc 8 BEGIN @ dup WHILE under 2- @ nfa? ?dup IF nip exit THEN 9 swap REPEAT nip ; 10 11 12 13 14 15 Screen 24 not modified 0 \ >name Alias ks 29 jun 87 1 2 : >body ( acf -- apf ) H 2+ ; 3 4 : Alias ( n -- ) H tlast off 5 (theader ghost over resolve T , H $20 flag! ; 6 7 : on ( addr -- ) H true swap T ! H ; 8 : off ( addr -- ) H false swap T ! H ; 9 10 11 12 13 14 15 Screen 25 not modified 0 \ Target tools ks 9 sep 86 1 Onlyforth 2 3 | : .tfield ( taddr len quan -) >r under Pad swap 4 bounds ?DO dup T c@ I H c! 1+ LOOP drop 5 Pad over type r> swap - 0 max spaces ; 6 7 ' view Alias hview 8 9 Ttools also definitions 10 11 | : ?: ( addr -- addr ) dup 4 u.r ." :" ; 12 | : @? ( addr -- addr ) dup T @ H 6 u.r ; 13 | : c? ( addr -- addr ) dup T c@ H 3 .r ; 14 15 Screen 26 not modified 0 \ Ttools for decompiling ks 9 sep 86 1 2 : s ( addr -- addr+ ) ?: space c? 4 spaces 3 T count 2dup + even -rot 18 .tfield ; 4 5 : n ( addr -- addr+2 ) ?: @? 2 spaces dup T @ >name H 6 ?dup IF T count H ELSE 0 0 THEN 7 $1F and $18 .tfield 2+ ; 8 9 : d ( addr n -- addr+n ) 2dup swap ?: 3 spaces 10 swap 0 DO c? 1+ LOOP 4 spaces -rot dup .tfield ; 11 12 : l ( addr -- addr+2 ) ?: 6 spaces @? 2+ 14 spaces ; 13 14 : c ( addr -- addr+1 ) 1 d 15 spaces ; 15 Screen 27 not modified 0 \ Tools for decompiling ks 29 jun 87 1 2 : b ( addr -- addr+2 ) ?: @? dup T @ H 3 over + 6 u.r 2+ 14 spaces ; 4 5 : dump ( addr n -- ) 6 bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; 7 8 : view T ' >name H ?dup 0=exit 4 - T @ H ?dup 0=exit edit ; 9 10 11 12 13 14 15 Screen 28 not modified 0 \ Predefinitions loadscreen ks 29 jun 87 1 Onlyforth 2 3 : clear H true Abort" There are ghosts" ; 4 5 6 1 $B +thru 7 8 9 10 11 12 13 14 15 Screen 29 not modified 0 \ Literal ['] ?" ." " ks 29 jun 87 1 Transient definitions Forth 2 3 : Literal ( n -- ) H dup $FF00 and 4 IF T compile lit , H exit THEN T compile clit c, H ; 5 immediate 6 7 : Ascii H bl word 1+ c@ state @ 0=exit 8 T [compile] Literal H ; immediate 9 10 : ['] T compile lit H ; immediate 11 : ." T compile (." ," align H ; immediate 12 : " T compile (" ," align H ; immediate 13 14 15 Screen 30 not modified 0 \ Target compilation ] ks 07 dez 87 1 Forth definitions 2 3 | : tcompile ( string -- ) dup find ?dup 4 IF 0> IF nip execute exit THEN THEN 5 drop gfind IF execute exit THEN number? ?dup 6 IF 0> IF swap T [compile] Literal THEN 7 [compile] Literal H exit THEN 8 symbolic execute ; 9 10 Transient definitions 11 12 : ] H ] ['] tcompile Is parser ; 13 14 15 Screen 31 not modified 0 \ Target conditionals ks 10 sep 86 1 2 : IF T compile ?branch >mark H 1 ; immediate restrict 3 : THEN abs 1 ?pairs T >resolve H ; immediate restrict 4 : ELSE 1 ?pairs T compile branch >mark 5 swap >resolve H -1 ; immediate restrict 6 7 : BEGIN T mark H -2 2swap ; 9 immediate restrict 10 11 | : (repeat 2 ?pairs T resolve H REPEAT ; 13 14 : UNTIL T compile ?branch (repeat H ; immediate restrict 15 : REPEAT T compile branch (repeat H ; immediate restrict Screen 32 not modified 0 \ Target conditionals Abort" etc. ks 09 feb 88 1 2 : DO T compile (do >mark H 3 ; immediate restrict 3 : ?DO T compile (?do >mark H 3 ; immediate restrict 4 : LOOP 3 ?pairs T compile (loop 5 compile endloop >resolve H ; immediate restrict 6 : +LOOP 3 ?pairs T compile (+loop 7 compile endloop >resolve H ; immediate restrict 8 9 : Abort" T compile (abort" ," align H ; immediate restrict 10 : Error" T compile (error" ," align H ; immediate restrict 11 12 13 14 15 Screen 33 not modified 0 \ Target does> ;code ks 29 jun 87 1 2 | : dodoes> T compile (;code 3 H glast' @ there resdoes> there tdoes> ! ; 4 5 : Does> H undefined? T dodoes> 6 $E9 c, H tdodo @ there - 2- T , 7 H ?reinterpret ; immediate restrict 8 9 : ;Code H 0 ?pairs undefined? T dodoes> H ?reinterpret 10 T [compile] [ Assembler H ; immediate restrict 11 12 13 14 15 Screen 34 not modified 0 \ User ks 09 jul 87 1 Forth definitions 2 3 Variable torigin torigin off \ cold boot vector 4 Variable tudp tudp off \ user variable counter 5 : >user ( addr1 -- addr2 ) T c@ H torigin @ + ; 6 7 Transient definitions Forth 8 9 : origin! ( taddr -- ) H torigin ! tudp off ; 10 : uallot ( n -- offset ) H tudp @ swap tudp +! ; 11 12 DO> >user ; 13 : User T prebuild User 2 uallot c, H ; 14 15 Screen 35 not modified 0 \ Variable Constant Create ks 01 okt 87 1 2 DO> ; 3 : Variable T prebuild Create 2 allot H ; 4 5 DO> T @ H ; 6 : Constant T prebuild Constant , H ; 7 8 DO> ; 9 : Create T prebuild Create H ; 10 11 : Create: T Create ] H end-code 0 ; 12 13 14 15 Screen 36 not modified 0 \ Defer Is Vocabulary ks 29 jun 87 1 2 DO> ; 3 : Defer T prebuild Defer 2 allot ; 4 : Is T ' >body H state @ 5 IF T compile (is , H exit THEN T ! H ; immediate 6 7 dummy 8 : Vocabulary H >in @ Vocabulary >in ! 9 T prebuild Vocabulary 0 , 0 , 10 H there tvoc-link @ T , H tvoc-link ! ; 11 12 13 14 15 Screen 37 not modified 0 \ File ks 19 m„r 88 1 Forth definitions 2 3 Variable tfile-link tfile-link off 4 Variable tfileno tfileno off 5 &45 Constant tb/fcb 6 7 Transient definitions Forth 8 9 dummy 10 : File T prebuild File here tb/fcb 0 fill 11 here H tfile-link @ T , H tfile-link ! 12 1 tfileno +! tfileno @ T c, 0 , 0 , 0 , 0 , 0 , 13 here dup >r 1+ tb/fcb &13 - allot H tlast @ 14 T count dup r> c! 15 H bounds ?DO I T c@ over c! H 1+ LOOP drop ; Screen 38 not modified 0 \ : ; compile Host [compile] ks 29 jun 87 1 2 dummy 3 : : H >in @ >in: ! T prebuild : ] H end-code 0 ; 4 5 : ; 0 ?pairs T compile unnest 6 [compile] [ H ; immediate restrict 7 8 : compile T compile compile H ; immediate restrict 9 10 : Host H Onlyforth ; 11 12 : Compiler H Onlyforth Transient also definitions ; 13 14 : [compile] H ghost execute ; immediate restrict 15 Screen 39 not modified 0 \ Target ks 29 jun 87 1 2 Onlyforth 3 4 : Target H vp off Transient also definitions ; 5 6 Transient definitions 7 8 ghost c, drop 9 10 11 12 13 14 15 Screen 40 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 41 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 42 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 43 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 44 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 45 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 46 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 47 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 48 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 49 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 50 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 51 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 52 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15