VolksForth/sources/msdos/meta.fb.src
2020-06-19 23:07:40 +02:00

902 lines
58 KiB
Plaintext
Raw Blame History

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 <forw> 0 | Constant <res>
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@ - <forw> , 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 <forw> , 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 @ <forw> case?
5 IF ." forw" ELSE <res> - Abort" ??" ." res" THEN
6 2+ dup @ 5 u.r 2+ @ ?dup
7 IF dup @ <forw> case?
8 IF ." fdef" ELSE <res> - 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 @ <forw> = 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 @ <res> =
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> <res> over ! 2+ ! ;
9
10 : resdoes> ( acf.ghost acf.target -- ) swap gdoes>
11 dup @ <res> = IF 2+ ! exit THEN swap resolve ;
12
13 here 2+ 0 ] Does> dup @ there rot ! T , H ; ' <forw> >body !
14 here 2+ 0 ] Does> @ T , H ; ' <res> >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 : <mark ( -- addr ) H there ;
5 : <resolve ( addr -- ) T here - , H ;
6
7 : immediate H $40 flag! ;
8 : restrict H $80 flag! ;
9
10
11 : | H ?thead @ ?exit ?thead on ;
12 : internal H 1 ?thead ! ;
13 : external H ?thead off ;
14
15
Screen 23 not modified
0 \ ' | compile Alias >name ks 29 jun 87
1
2 : ' ( -- acf ) H g' dup @ <res> -
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 ; immediate restrict
8 : WHILE 2 ?pairs 2 T compile ?branch >mark H -2 2swap ;
9 immediate restrict
10
11 | : (repeat 2 ?pairs T <resolve H
12 BEGIN dup -2 = WHILE drop 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