mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-29 05:49:26 +00:00
579 lines
37 KiB
Plaintext
579 lines
37 KiB
Plaintext
|
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
|