mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-03 07:05:57 +00:00
902 lines
58 KiB
Plaintext
902 lines
58 KiB
Plaintext
|
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
|