\\ ***  Target-Compiler f�r volksFORTH  ***          25aug87rewe                                                                Der Target-Compiler erzeugt f�r jedes Wort im Target-System     einen 'Ghost' mit folgendem Aufbau:                                                                                             | LFA | Name+bl | Ptr auf <forw>/<res> | TargetCFA | Ptr TDoes|                                                                 PtrDoes zeigt auf  | DoesCFA | TargetDoes |                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     \ Target compiler loadscr                              21dec08py\ Idea and first Implementation by ks/bp                        \ Implemented on 6502  by ks/bp                                 \ ultraFORTH83-Version by bp/we                                 \ Atari 520 ST - Version by we                                  \ bigFORTH Version by py                                        \ bigFORTH.386 Version by py                                    Onlyforth      Assembler nonrelocate Forth                      Vocabulary Ttools                                               Vocabulary Defining                                                                                                               1 $30 +thru                                                                                                                   Onlyforth                                                                                                                                                                                       \ Target header pointers                               11jul96py                                                                0 Constant NIL                                                  Variable tdp                  : there  tdp @ ;                  Variable tactModule                                             : >trel     tactModule @ - ;                                    Variable ?thead                                                 Variable tlast                Variable tlastcfa                 Variable tlastopt             Variable tlastdes                 Variable tstate                                                 Variable glast'               Variable >in:                     Variable tuser                Variable tvoc                     Variable tvoc-link            NIL tvoc-link !                   Variable tfile-link           NIL tfile-link !                  Variable tfileno              1 tfileno !                                                                                       \ Image and byteorder                                  01jan93py                                                                : c+!   (  8b addr -- )       dup c@  rot +  swap  c! ;                                                                         \ : >image    ( addr1 -- addr2 )      displace @  +  ;                                                                          : >heap  ( from quan -- )                                          dup hallot  heap swap move ;                                                                                                 4 Constant cell                                                 ' 4+ Alias cell+                                                ' 4- Alias cell-                                                ' 4* Alias cells                                                ' 4/ Alias cell/                                                                                                                                                                                \ Ghost-creating                                       17jun10py                                                                0 Constant dummy                                                $4711 Constant <forw>           $4712 Constant <res>                                                                            : Make_ghost  ( -- ghostbody )                                     here ( align ) here   state @  tstate @ or                      IF  context  ELSE  current  THEN  @  dup @ ,                    name capitalize dup c@  $1F 1 within abort" invalid Gname"      dup c@ 1+  over c!                                              c@ allot  bl c, ( align ) 0 w,                                  here 2 pick -  -rot                                             <forw> , NIL , NIL ,                                            swap   here over -  >heap                                       heap swap over cell+ over 'reveal !                             swap dp ! heap  +  ;                                         \ ghost words                                        2723jan05py                                                                : gfind  ( string -- ghostbody tf / string ff )                    dup  count + 1+  bl swap c!                                     dup >r  1 over c+!  find  -1 r> c+!  ;                                                                                       : ghost   ( -- cfa )                                               >in @  name gfind   IF nip exit THEN                            drop  >in !  Make_ghost ;                                                                                                    : gdoes>  ( ghostbody -- cfa.does )                                cell+ cell+ dup @   IF  @ exit  THEN                            here  dup <forw> ,  NIL ,   2 cells >heap                       dp !  heap tuck swap ! ;                                                                                                                                                                     \ ghost utilities                                    2518jun97py                                                                : g'   ( <name> -- cfa )   name gfind 0= abort" No ghost" ;                                                                     : '.   ( <name> -- )                                              g' dup @ <forw> case?                                            IF ." forw"  ELSE  <res> - abort" What's up?" ."  res"  THEN   cell+ dup @ 7 u.r                                               cell+ @ ?dup                                                     IF dup @ <forw> case?                                            IF ."  fdef"  ELSE <res> - abort" What ??" ."  rdef"  THEN    cell+ @ 7 u.r THEN ;                                                                                                          ' ' Alias h'                                                                                                                                                                                    \ .unresolved                                      26aug87marewe                                                                : forward? ( cfa -- cfa / exit&true )      \ h��lich !!!           dup @  <forw> =   over cell+ @ and                                    IF drop true rdrop exit THEN ;                         : unresolved? ( lfa -- f )                                         cell+ dup  c@ $1F and  over +  c@ bl =                           IF    name> forward?  cell+ cell+ @  dup IF  forward?  THEN     THEN  drop  false ;                                                                                                         : unresolved-words   ( thread -- )                                 BEGIN  @ ?dup  WHILE  dup unresolved?                                           IF  dup  cell+ .name ?cr  THEN  REPEAT ;                                                                     : .unresolved       voc-link @                                     BEGIN  dup cell- cell- unresolved-words  @ ?dup 0= UNTIL ;   \ Extending Vocabularys for Target-Compilation         22sep91py                                                                : Vocabulary       Vocabulary   NIL ,  here  tvoc @ ,  tvoc ! ;                                                                 Vocabulary Transient       NIL tvoc !                                                                                           Only definitions Forth also Root                                                                                                : T   Transient ;   immediate                                   : H   Forth     ;   immediate                                                                                                                                                                                                                                                                                                                                                                                                                                   \ Transient primitives                                 01jan93pyTransient definitions                                                                                                           \ : @  [ $205E w,     3 [FOR]  $1D18 w,  [NEXT] ] ;             \ : w@ [ $205E w,     1 [FOR]  $1D18 w,  [NEXT]  $4266 w, ] ;   \ : wx@ w@ wextend ;                                            \ : !  [ $205E5888 ,  3 [FOR]  $111E w,  [NEXT] ] ;             \ : w! [ $205E w, $5488548E ,  1 [FOR]  $111E w,  [NEXT] ] ;                                                                    : here     there ;                                              : allot    tdp +! ;                                             : htcmove ( from.mem to.target quan -)  move ;                                                                                  : trelinfo  H tactModule @ dup cell+ T @ H + ;                                                                                                                                                  \ [JSR] [BSR]                                      26au18jun97py                                                                  $E8 Constant [call]             $C3 Constant [ret]            $F487 Constant [s~r]                                                                                                            : cfa@   ( tcfa -- tcfa@ )        dup  T c@ H                        T [call] H = IF  1+ dup T @ H + cell+ exit THEN                 true abort" Neither nor...." ;                                                                                                                                                             : movebits ( B$s B$z s z # -- ) >r 2dup > IF  rot swap r>          0 ?DO 2over i + bit@ IF 2dup +bit ELSE 2dup -bit THEN 1+ LOOP  ELSE  rot swap r@ + r> ?dup IF 1-                                  FOR 1- 2over i + bit@ IF 2dup +bit ELSE 2dup -bit THEN NEXT     THEN  THEN  2drop 2drop ;                                                                                                  \ Transient primitives                                 17jun10py                                                                : c,     T here c! 1 allot H ;                                  : w,     T here w! 2 allot H ;                                  : ,      T here  ! 4 allot H ;                                  : A,     T here swap , trelinfo swap >trel +Bit H ;             : A!     T trelinfo over >trel +Bit ! H ;                       : align  T here dup aligned swap ?DO  bl c,  LOOP H ;           : ,"     Ascii " parse  dup T c,                                         under here swap  htcmove  allot H ;                    : ,0"    Ascii " parse      T                                            under here swap  htcmove  allot 0 c, H ;                                                                               \ : fill ( addr quan 8b -) >r >r >image r> r> fill ;            \        -rot bounds ?DO  dup I  T c! H  LOOP  drop ;           \ : erase        0 T fill ;                                     \ Resolving                                            28dec92py                                                                : >len         ( cfa -- lengthfield )    2- ;                                                                                   : call!    ( addr cfa.target -- )                                  over - 4-  swap T ! H ;                                                                                                      : call,    ( cfa.target -- )                                       T [call] c, here over call! 4 allot H                           tactModule @ there within                                       0= IF  T trelinfo here 4- >trel 2dup +Bit 1+ +Bit H  THEN ;                                                                  \ : cmove ( from to count -- ) >r >image >r >image r> r> cmove ;                                                                Defer (do_resolve                                                                                                               \ Resolving Part 2                                 26aug87marewe                                                                Forth definitions                                               : resolve ( ghostbody cfa.target -- )                              over dup @ <res> =                                              IF  space  dup >name .name  ." exists " ?cr                         cell+ !  drop exit  THEN                                    >r >r  cell+ @ ?dup                                             IF   BEGIN  dup  T @ H   2dup = abort" resolve loop"                        swap  r@ T call! H  ?dup 0= UNTIL                   THEN  r> r>  <res> over !  cell+ ! ;                                                                                         : resdoes> ( ghostbody cfa.target -- )                             swap gdoes>  dup @  <res> = IF  cell+ ! exit  THEN              swap resolve ;                                                                                                               \ Code-Body <forw> und <res>                           18jun97py: do_forward   ( ghostbody -- )  T [call] c, H                     cell+ dup @  there rot !  T , $80 tlastdes H ! ;             : do_resolve   ( ghostbody -- )                                    cell+ @   T  (do_resolve  H ;                                                                                                : gexecute   ( ghostbody  -- )   dup @                                       <forw> case? IF  do_forward  exit THEN                          <res>      = IF  do_resolve  exit THEN                          true abort" What's that, a CFA ??" ;               : ghost,     ghost  gexecute ;                                  : move-threads           Tvoc @   Tvoc-link @                      BEGIN  dup                                                      WHILE  over cell- @ over cell-  T ! @ H  swap @  swap  REPEAT   2drop ;                                                      : tlatest ( -- addr )       current @  cell+ cell+ cell+ cell+ ;\ Tabelle einrichten                                   27oct95py                                                                \needs troot Variable Troot                                     Dos also                                                        | : (inittab ( root -- )                                            BEGIN  dup , dup T @ H , 0 , dup 8+ T @ H ?dup                         IF recurse THEN $10 + T @ H  dup 0=  UNTIL  drop ;   | : inittab ( -- tab ) here troot @ (inittab 0 , $7FFF , 0 , ;  | : name, ( tab -- tab )  dup @ dup $30 + count  here place         here c@ 1+ allot $14 + @ , 0 , dup 8+ dup T @ H , off ;     | : >LinkTab ( tabstart module -- linktabstart )                    here  0 w,  >r  over                                            BEGIN  2dup @ = 0=  WHILE  $C +  REPEAT  name, 2drop            BEGIN  dup @  WHILE  dup 8+ @  IF name, THEN  $C +  REPEAT      [ " nil" @ ] Literal , 0 , 8+ dup T @ H , off                   here r@ - 2- r@ T w! H  r> ;                                \ Module umformen, auf Diskette sichern...             30jan97py| : tabsearch ( addr tab -- addr entry )                            BEGIN  2dup 2@ under + within  0= WHILE  dup >r $C + r> @       0= UNTIL  rdrop I . drop . true abort" No address!"  THEN ; | : ((savemod ( module tab handle -- return )  >r                   over dup T @ H >r dup cell+ T @ H + r> 0                        ?DO  dup I bit@                                                      IF  -rot 2 pick I 1+ bit@                                           IF    over I + dup >r T @ H r@ + 4+ over tabsearch                    under @ - r@ 2+ T w! H dup $A + w@ r> over 0=                   IF nip I swap THEN  T w! H I swap $A + w!                 ELSE  over I + dup >r T @ H over tabsearch                            under @ - r@ 2+ T w! H dup   8+ w@ r> over 0=                   IF nip I swap THEN  T w! H I swap 8+ w!                   THEN  rot  4  ELSE  1  THEN  +LOOP                     2drop dup T @ H r> fwrite ;                                 \ savemod savesystem                                   27dec92py                                                                | Variable handle                                               | Variable modtab                                               | : ?abort ( diskerr -- ) dup 0< IF r0 @ rp! ELSE drop THEN ;   | : (savemod ( back linkpos module -- )                             cr ." saving " dup $30 + .name                                  T dup 8+ @ >r  dup $C + @ >r  dup $10 + @ >r  >r H              dup  IF  0 handle @ 1 fseek >r handle @ 0 fseek ?abort                   rp@ T @ H sp@ 4 handle @ fwrite ?abort drop                     r@ handle @ 0 fseek ?abort r>  THEN  drop              r@ $C + T ! H r@ 8+ off  r@ $10 + off                           r@ modtab @ handle @ ((savemod                                  T r> r> over $10 + !  r> over $C + !  r> over 8+ ! >r H         ?abort  modtab @ r> >linktab                                    dup dup T w@ H 2+ handle @ fwrite ?abort dp !  ." saved" ;  \ savemod savesystem                                   20may00py                                                                \needs >len : >len dup $100 0 scan drop over - ;                                                                                | : getmodname ( -- addr ) Name  count pad place pad                0 over count + c!  count over + 4- dup c@ Ascii . =             IF  0 swap c!  ELSE  drop  THEN  >len over +                    S" .fi" >r over r> move  0 swap 3 + c! ;                                                                                    | : >savemod ( back linkpos module -- )  recursive >r               BEGIN  >r 0 handle @ 1 fseek over r> r@ (savemod                       r@ 8+ T @ H ?dup  IF  >r dup dup 8+ r> >savemod  THEN           over 0< 0= r> $10 + T @ H and                                   dup  WHILE  >r $10 +  REPEAT  drop 2drop ;                                                                                                                                           \ save-target                                          01jan01py                                                                : savedp  tactModule @ ?dup  IF  >r there r@ - r> T ! H           ELSE  EXIT  THEN                                                0 there tactModule @ ?DO I T @ H + dup 2* swap 0< - cell +LOOP  tactModule @ 5 cells + T ! H ;                                                                                                \needs ?diskabort : ?diskabort 0< abort" Disk error! " ;        : save-target ( -- )  clear                                       ['] ?diskabort >r r0 push dp push rp@ r0 !                      >in @ >r getmodname [IFDEF] go32 0 [ELSE] r/w [THEN] fcreate    dup ?abort  handle !                                            inittab modtab ! -1 0 troot @ >savemod handle @ fclose          ( r@ >in ! getmodname ) ( [ saving ] r> >in ! saveloader)       rdrop ;                                                       toss                                                            \ compiling names into targ.                           17jun10py                                                                Variable thead+ 7 thead+ !                                      Variable theadalign 3 theadalign !                              : (theader   >in @  name c@  swap >in !                            there + thead+ @ swap - theadalign @ and 0 ?DO bl T c, H LOOP   ?thead @ IF  1 ?thead +! exit  THEN                             >in @  name capitalize swap  >in !                              dup c@  $20 1 within abort" inval. Tname"                       blk @ abs $400 + T w, H  \ Loaded from File# 1                  there  tlatest dup @  T A, H !    there  dup tlast !            over c@ 1+ dup T allot  htcmove ( align ) H ;                                                                                : Theader          tlast off  $80 tlastdes !                       (theader  T 0 w, H  there tlastcfa !   ghost dup glast' !       there resolve ;                                              \ prebuild defining words                              01jan93py                                                                : executable? ( addr -- addr f )      dup ;                     : tpfa,                               there , ;                                                                                 : (prebuild ( cfa.addr -- )                                         >in @   Create immediate  >in ! here 4- under 4+ - swap ! ;                                                                 : prebuild ( addr 0_from_: -- 0 )                                 ?struc  executable? dup >r                                         IF    compile Literal  compile (prebuild                        ELSE  drop  THEN                                              compile Theader                                                 ghost gdoes> compile Literal   compile gexecute                 r> IF  compile tpfa,  THEN  0 ;    immediate restrict                                                                        \ code portion of def.words                            02jan93py                                                                : DO> ( -- addr.of.jmp.dodoes> 0 )                                0 w,  !lastdes  here  compile r>  compile @  0 ] ;                                                                            Transient definitions                                           : compile      H ghost compile Literal  compile gexecute ;                                               immediate restrict     : >T&P H $FF and >r $FF and $100 Q* r> or ;                     : T&P  ( Take Push -- ) T >T&P                                    tstate H @  IF  T tlastdes H w! ELSE                                            T tlastopt H @ T w! H THEN ;                  FORTH definitions                                               : T&P:  H : swap compile Literal compile ; macro ;                                                                                                                                              \ the 468 Assembler                                    07nov92py                                                                Forth definitions   0 constant NIL T                            : +tbit  trelinfo there >trel +bit ;                            | Table: relocate   c,  here  allot  c!  +tbit   [                                                                              : !length                                                         tlastcfa H @ ?dup IF  dup T >len w@ H IF  drop exit  THEN                             there over -  swap T >len w! H  THEN ;  Assembler definitions                                           : end-code     end-code !length ;                               \\                                                              D6 Constant loopreg             D7 Constant looplim             A7 Constant RP                  A5 Constant UP                  A6 Constant SP                                                  : Next         rts ;                                            \ Definitionen fuer Assembler                         b17jun10pyFORTH definitions       warning off                             $100 loadfrom forth.fb                                          Transient definitions   warning on                              : Assembler   H relocate [ Assembler ] >codes H !  Assembler ;                                                                  : >label ( addr -- )   H >in @  name gfind  rot >in !              IF  over resolve dup  THEN  drop Create , immediate               Does> @  tstate @ IF  T compile lit here 6 - A! H  THEN ;                                                                  : Label          T ( align )    \ H tlastcfa off                                 T here >label Assembler H ;                    : Code           H THeader T [ Assembler ] :R T Assembler                        [ Assembler ] S: H ;                                                                                                                                                           \ immed. restr. ' \ compile                            24dec92py                                                                : ?pairs   ( n1 n2 -- )  H - abort" unstructured" ;             : >mark     ( -- sys )   T here 6 - 0 over ! H ;                : >resolve  ( sys -- )   H >r there r@ - cell- r> T ! H ;       : <mark    ( -- addr )   H there ;                              : <resolve  ( sys -- )   H there 2- - there 6 - T ! H ;         : flag!                  >r H Tlast @ ?dup                                               IF  glast' @ >name                                                  dup c@ r@ or swap c! dup                                        T c@ r@ or swap c! H  THEN rdrop ; : restrict               T $80 flag! H ;                        : immediate              T $40 flag! H ;                        : ' ( <name> -- cfa )    H g' dup @ <res> - abort" ?" cell+ @ ; : |                      H ?thead @ ?exit  ?thead on ;                                                                          \ Target tools                                         17jun10py                                                                Onlyforth Ttools also definitions                                                                                               | : ttype ( addr n -- )   bounds ?DO  I  T c@ H  dup               bl > IF  emit  ELSE  drop Ascii . emit  THEN  LOOP ; Ttools  : .name ( nfa -- )   ?dup IF  dup 1+ swap T c@ H $1F and ttype                            ELSE ." ??? " THEN space ?cr ; Ttools | : nfa? ( cfa lfa -- nfa / cfa ff )                              BEGIN  dup 0> WHILE  2dup 4+ dup T c@ H $1F and + 1+                                 ( aligned ) 2+ =  IF  4+ nip exit  THEN                       T @ H REPEAT ; Ttools                      : >name ( cfa -- nfa / ff )                                      Tvoc  BEGIN  @ dup  WHILE  under 4- @ nfa? ?dup                                                  IF nip exit THEN                                         swap REPEAT  nip ;  Ttools           \ Ttools for decompiling                           26aug87marewe                                                                | : ?:        dup  4 u.r ." :" ;                                | : w@?       dup  T w@ H  6 u.r ;                              | : @?        dup  T  @ H  6 u.r ;                              | : c?        dup  T c@ H  3 .r ;                                                                                               : s ( addr -- addr+ )         ?: space c? 3 spaces               dup 1+ over  T c@ H  ttype dup  T c@ H  + 1+ ;                                                                                 : n ( addr -- addr+2 )        ?: @? 2 spaces                     dup  T cfa@ H  [ Ttools ] >name .name  H 4+ ;                                                                                  : d ( addr n -- addr+n )   2dup swap ?: swap 0 DO  c? 1+  LOOP                             2 spaces -rot ttype ;                                                                                \ Tools for decompiling                              bp03sep10py                                                                : l ( addr -- addr+4 )    ?: 5 spaces @? 4+ ;                   : c ( addr -- addr+1 )    1 d ;                                 : b ( addr -- addr+2 )    ?: w@? dup T w@ H over + 5 u.r  2+ ;  : dump ( addr n -)        bounds ?DO  cr I $10 d drop                                     stop? IF LEAVE THEN $10 +LOOP ;       : view                    T ' H [ Ttools ] >name ?dup                                       IF  6 -  T w@ H  l  THEN ;          : tdump  ( offset -- )  >r tactmodule @ cell+ T @ H r>            ?DO  cr I 6 .r  space                                                $10 0 DO  T trelinfo H j i + bit@ IF '* ELSE bl THEN emit                 tactmodule @ j i + + c@ 0 <# # # #> type                        I 7 = IF  space  THEN  LOOP  2 spaces                 $10 0 DO  tactmodule @ j i + + c@ bl max emit  LOOP             stop? ?LEAVE $10 +LOOP ;                                 \ clear Liter. Ascii ['] ."                            17jun10pyOnlyforth Transient definitions                                 : !tlastdes H :r tlastdes dup c@ tlastdes 2+ c! w! ;            : clear            true abort" There are ghosts" ;              : Literal ( n -- ) H tstate @ 0= ?exit                                             T compile lit  here 6 -  ! H ;                                  immediate restrict                           : ALiteral ( a --) H tstate @ 0= ?exit                                             T compile lit  here 6 - A! H ;                                  immediate restrict                           : Ascii           H bl word 1+ c@ T [compile] Literal H ;                                                    immediate          : [']             T ' [compile] ALiteral H ; immediate restrict : "               T compile (C" ," H ; immediate restrict       : S"              T compile (S" ," H ; immediate restrict       : ."              T compile (." ," H ; immediate restrict       \ Target compilation  ]                                28jan97pyForth definitions                                               : tcompiler >in @ over c@ 1+ - swap find ?dup                       IF  0> IF  nip execute exit      THEN                               drop dup >in ! name                                         THEN gfind IF  nip gexecute exit      THEN                     number?  ?dup IF 0> IF  swap T [compile] Literal H THEN                          T [compile] Literal H drop exit  THEN          drop >in !  ghost,  exit     ;                               Transient definitions                                           : ]    H tstate on  state on  ['] tcompiler Is parser     ;     : [    H tstate off compile [ ;  immediate     also Assembler   : >c:  ?struc compile [ Assembler :R S: ; immediate previous    Assembler definitions                                           : ;c:  R: T $80 tlastdes H !  current @  context !  0 T ] H ;   Transient definitions                                           \ Macro handling                                       01jan93py: macro  H tlastcfa @ ?dup                                        IF  T 2- dup  wx@ negate swap w! here tlastopt H !                  tlastdes 2+ w@ T w, trelinfo here                               tlastcfa H @ T >trel 0 tlastcfa H @ T 2- wx@ negate             dup 1- 3 >> 1+ allot movebits H  THEN ;                   | : macro, ( addr count skip -- ) dup >r /string                    2dup T here swap move  under + 3+                               trelinfo r> here >trel 4 pick  movebits allot H ;                                                                           | : S:  ( -- )  tlastdes c@ dup :r =                                IF   drop T [s~r] w, H                                          ELSE :s = 0= IF T -2 allot H THEN THEN  0 tlastdes c! ;     | : R:  ( addr1 count1 T&P -- addr2 count2 skip T&P )               dup $FF and :r = 0=  IF  dup 8 >> :r = 0=                       IF  T -2 allot H 2  ELSE  0  THEN  ELSE  0  THEN swap ;     \ (opt,                                                13apr93py                                                                | : <move> ( size +- -- ) dup $80 and IF  $FFFFFF00 or  THEN        dup 0= IF  2drop exit  THEN  >r there dup r@ abs +              r> 0< IF  swap  THEN  2dup 4 pick 1+ T move >trel >r            >trel >r >r trelinfo dup r> r> 2- r> 2- rot 2+ movebits H ; | : (opt, ( addr -- ) 0 T here ! H                                  dup 3+ c@ dup negate T allot H                                  over 2+ c@ T <move> H  dup 5 + count bounds                     ?DO  i c@ dup  IF  T c, H  ELSE T drop 1 allot H THEN  LOOP     c@ dup IF tlastdes c@ IF tlastdes w! exit THEN THEN             drop ;                                                      : .align  ( -- )  there 3 and                                     3 case?  IF  T $90 c,        H  exit  THEN                      2 case?  IF  T $ED8B w,      H  exit  THEN                      1 =      IF  T $6D8D w, 0 c, H  exit  THEN ;                  \ topt,                                                03jan99py| : flag>  T -7 allot                                               2 + here 1+ dup 1+ >r c@ $94 xor >r macro, H                    r> r> dup T c@ H $84 = 0= +                                     under T c@ H xor swap T c! H ;                              | : topt, ( addr len skip Push&Take -- )                            $0505 case? IF  T flag> H exit  THEN                            dup 8 >>  opttab #opt bounds                                    DO  dup I c@ =                                                      IF  drop $FF and dup dup $60 < IF $F and THEN I 1+ count        bounds  DO  I c@ IF over ELSE dup THEN I 1+ c@ =                            IF  2drop  I T (opt, H  I 4+ c@ + T macro, H                        unloop unloop exit  THEN                                    I 5 + c@ 6 +  +LOOP  LEAVE  THEN                    I 1+ c@ 2+  +LOOP drop                                      drop T macro, H ;                                           \ Target conditionals                                  12apr93py: BUT   H depth 2/ 2 min 2- ?struc 2swap H ; immediate restrict : YET      T dup 0= 0 ?pairs 2dup H ;        immediate restrict : IF       T compile ?branch >mark H 1 ;     immediate restrict : AHEAD    T compile  branch >mark H 1 ;     immediate restrict : THEN     T S: abs 1 ?pairs >resolve [s~r] w, H ;                                                           immediate restrict : ELSE     T [compile] AHEAD 2swap [compile] THEN H negate ;                                                 immediate restrict : BEGIN    T S: .align <mark [s~r] w, H 2 ;  immediate restrict : WHILE    T [compile] IF  [compile] BUT H ; immediate restrict : AGAIN    T 2 ?pairs compile branch  <resolve H ;                                                           immediate restrict : UNTIL    T 2 ?pairs compile ?branch <resolve H ;                                                           immediate restrict : REPEAT T [compile] AGAIN [compile] THEN H ; immediate restrict\ Target conditionals                                 b20may00py                                                                Variable  tleavings                                             : endloops   ( addr -- )    T S: tleavings H @                    BEGIN  2dup u<  WHILE  T dup @ H dup 0<>                               IF  over + cell+  THEN  swap T >resolve H  REPEAT        T tleavings H ! drop T [s~r] w, H ;                                                                                           : (leave  T here 6 - tleavings H @                                dup IF T <resolve H ELSE T over ! H THEN T tleavings H ! ;                                                                    : LEAVE     T compile branch  (leave H ;     immediate restrict : ?LEAVE    T compile 0=  compile ?branch (leave H ;                                                         immediate restrict : >R        T compile >r H ;                 immediate restrict : R>        T compile r> H ;                 immediate restrict \ Target conditionals                                  30dec92py                                                                : DO   ( limit start -- )    T                                      compile (do  S: <mark [s~r] w,  H  3 ;   immediate restrict : ?DO  ( limit start -- )    T                                       compile (?do  [compile] LEAVE                                   <mark 2- H  3 ;                         immediate restrict : FOR       T compile (for [compile] BEGIN H drop 4 ;                                                        immediate restrict : loop]     T dup <resolve 5 - endloops compile unloop H ;      : LOOP      T 3 ?pairs compile (loop  loop] H ;                                                              immediate restrict : +LOOP     T 3 ?pairs compile (+loop loop] H ;                                                              immediate restrict : NEXT      T 4 ?pairs compile (next  loop] H ;                                                              immediate restrict \ predefinitions                                     bp17jun10py: abort"             T compile (abort" ," H ; immediate         : error"             T compile (error" ," H ; immediate         Forth definitions                                               Variable tsemalink                                              Variable torigin                                                Variable tudp        0 tudp !                                   Variable tlibs       0 tlibs !                                  : >user              H  @  torigin @ + ;                        : auser+                                                          troot @ dup cell+ T @ H + tudp @ torigin @ + Troot @ - +Bit ; Transient definitions                                           : origin!            H torigin ! ;                              : user'  ( -- n )    T ' 4+ count H $45 =                                            IF T c@ H ELSE T @ H THEN ;                : uallot ( n -- )    H tudp @ swap tudp +! ;                    \ Datatypes                                            15nov95py: User          H >in @ Create immediate >in ! T  Theader                       cell uallot H dup , dup $80 <                                   IF   T compile (suser  here 3 - c! H                            ELSE T compile (user   here 6 -  ! H THEN                       T compile exit !length macro                                    DOES> H tstate @ 0= IF  >user exit  THEN                              @ dup $80 <                                                     IF   T compile (suser here 3 - c! H                             ELSE T compile (user  here 6 -  ! H                             THEN ;                                    : AUser         Auser+ T User H ;                                               DO> T [compile] ALiteral H ;                    : Create        thead+ push -5 thead+ +! prebuild Create ;                                                                                                                                      \ Datatypes                                            11jul96py                DO> H tstate @ 0=  IF  T @ H  ELSE                                      T [compile] ALiteral compile @ H THEN ; : Value         prebuild Value T , H ;                          : AValue        T Value trelinfo H there 4- >trel +Bit ;        : Variable      T Create 0  , H ;                               : AVariable     T Create 0 A, H ;                               : Sema          T Create 0 A, 0 A,                                here tsemalink H @ T A, tsemalink H ! ;                       dummy                                                           : Vocabulary    H >in @  Vocabulary  >in !                        T prebuild (Vocabulary  NIL A, NIL A, here                      H tvoc-link @ T A, H tvoc-link ! T 0 , H ;                    dummy                                                           : File T prebuild File here H tfile-link @ T , H tfile-link !     T 0 , H tfileno @  T w,  H 1 tfileno +! ;                     \ :  Alias  ;                                          06apr96py                                                                : :      H >in @ >in: !  Theader                                         H current @ context ! T ] H 0  ;                       : ;      T 0 ?pairs compile exit !length  [compile] [ H ;                                                   immediate restrict  : Constant   T : swap [compile] Literal  [compile] ; macro H ;  : AConstant  T : swap [compile] ALiteral [compile] ; macro H ;                                                                  : Alias ( n -- )   H tlast off  tlastcfa off                                       (theader  ghost over resolve                                    tlast @  ?dup                                                   IF    T c@ H  $20 or  tlast @ T c! A, H                         ELSE  drop  THEN ;                           : T]  H BEGIN >in @ name w@ $5B01 = 0=  WHILE  >in !                  T ' A, H  REPEAT  drop ;                                  \ Predefinition Input/Output-Struktur                  21dec08pydummy : Out:    T prebuild Out:  dup c,  cell+ H ;              dummy : Output: T prebuild Output: T] H ;                       dummy : In:     T prebuild In:   dup c,  cell+ H ;              dummy : Input:  T prebuild Input:  T] H ;                       dummy : Vec:    T prebuild Vec:  c, H ;    [IFUNDEF] :go32      H Variable direction   Variable offset                            Variable lastcorrect Variable thelib Variable aligncorrect    : proc, ( -- ) T here thelib H @ T 2 cells + dup @ A, !           thelib H @ T A, bl word count tuck here place 1+ allot H ;    ghost .save   ghost .int   ghost .sys-stack ghost resolve-syms  ghost .voidr  ghost .intr  ghost .correct   6 [FOR] drop [NEXT] | : !offset ( n -- )                                                T direction H @ 0= IF  negate cells T offset H +!  THEN         T offset H @ T here 3 - c! H                                    T direction H @    IF  cells T offset H +!  THEN ;          \ Predefinition library access                         24jan10py| : correct ( -- )  T direction H @ 0= IF                        T compile .correct 0 !offset H  ELSE                            T offset H @ negate T lastcorrect H @ T c! H THEN                [IFDEF] :osx                                                      T offset H @ T abs cell+ negate $F and negate                   aligncorrect H @ T c!                                         [THEN] T offset H off ;                                       : int ( -- ) T compile .int   1 !offset H ;  immediate restrict : llong T [compile] int [compile] int H ; immediate restrict    : (void) T correct  compile .sys-stack compile resolve-syms         compile .voidr [compile] ;  proc, H ;    immediate restrict : (int)  T correct  compile .sys-stack compile resolve-syms         compile .intr  [compile] ;  proc, H ;    immediate restrict : <rev> ( -- ) T compile .correct here 3 - lastcorrect H !        T direction H on ;                         immediate restrict \ Predefinition library access                         21dec08py: proc:  T offset direction H off off T : compile .save           [IFDEF] :osx compile .correct here 3 - aligncorrect H ! T       [THEN] H ;                                                    DO> T thelib H ! T proc: H ;                                    : library          T prebuild library H                           tlibs @ T here tlibs H ! T A, 0 , 0 A, 0 A,                     bl word count tuck here place 1+ allot H ;              [THEN]                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                \ target defining words                                01jan93py: Defer      H Auser+ T THeader compile (defer cell uallot ,                 [ret] c, !length macro $8080 tlastopt H @ T w! H ; : Patch      T THeader compile (patch H ;                       : IS   ( adr -- )     T ' H state @  IF  dup w@ $95FF =               IF T 2+ @ compile (user here 6 - ! compile ! H exit THEN        dup c@ $BA =                                                    IF T 1+ [compile] ALiteral compile ! H exit  THEN           ELSE  dup w@ $95FF = IF T 2+ @ torigin H @ + T ! H exit THEN          dup c@ $BA = IF 1+ T ! H exit THEN                        THEN  true abort" not deferred!" ; immediate                  | : dodoes>   T compile (;code !length 0 w, H                                 Glast' @ there dup tlastcfa ! resdoes> ;          : ;Code       0 T ?pairs dodoes> Assembler [compile] [ H ;                                     immediate restrict               : Does>       T dodoes>  compile r> H ;  immediate restrict     \ predefinitions                                       23jan05py                                                                : T&P ( takemode pushmode -- )                                    H tstate @ IF  T compile (T&P  H exit THEN                      T >T&P tlastopt H @ T w! H ;       immediate                  : T&P: T : swap [compile] Literal [compile] ; macro H ;                                                                         : Host                H Onlyforth ;                             : Compiler            T Host H Transient also definitions ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                     \ @ !                                                  15apr91py                                                                \ | : lit? ( -- lit t/f ) T tlastdes H  2+ w@                   \     T :lit H  =  IF  T -6 allot  here 2+ @ H true exit THEN   \     false ;                                                   \                                                               \ : ! H tstate @ 0= IF  T ! H  ELSE  T lit? H                   \   IF  T $23DE w, A, !tlastdes H                               \   ELSE  T compile ! H THEN  THEN  ;  immediate                \ : @ H tstate @ 0= IF  T @ H  exit  THEN                       \   T lit?   H  IF  T $2D39 $2D3A addr, !tlastdes  H  exit  THEN\   T compile @ H ;  immediate                                                                                                  : compile H  >in @ name swap >in ! gfind  nip                     0< IF  T compile (compile ' A, H  ELSE  ghost,  THEN ;                                    immediate restrict                  \ Modul-Struktur                                       20may00pydummy : (Vocabulary    H >in @                                    Vocabulary also lastcfa perform  also definitions  >in !        T prebuild (Vocabulary  NIL A, NIL A, here                      H tvoc-link @ T A, H tvoc-link ! T 0 , H ;                    H $10000    Constant MaxModLen                                  H &10 cells Constant ModHeader  memory also                     | : ModInit ( addr -- )                                             dup >r tdp ! T 0 , MaxModLen , 0 , H tactModule @ dup T , H     dup IF  8+ dup T @ r@ rot ! H  ELSE  r@ Troot !   THEN          T , 0 , r@ tactModule H !                                       r> T $28 + dup dup dup A, A, A, A, $C3 w, H ;               : Module  ( -- ) \ Name                                           H savedp T MaxModLen H dup 8 / + dup NewPtr under swap erase    T ModInit theadalign push theadalign off (Vocabulary H ;                                                                      \ Modul-Struktur                                       20may00py| : vec! H cells $18 + tactModule @ + T ! H ;                   | : vec: H Create c,                                                DOES> c@ H >r T 0 w, here H r> T vec!  ]                        H $80 tlastdes ! there tlastcfa ! 0 ; T                     0 vec: cold:    1 vec: main:    2 vec: bye:    3 vec: export: H : Module]  H savedp tactModule @ $C + T @ H dup tactModule !      ?dup IF dup T @ H + tdp ! THEN toss toss definitions ;        : Module;  ( -- )  T align savedp H tactModule @ >r T             r@ dup cell+ @ +  r@ @ $BA + r@ cell+ !                         r@ dup cell+ @ dup H >r + r> T 1- 3 >> 1+ move                  r@ dup cell+ @ dup 1- 3 >> 1+ + SetPtrSize  Module] H           tactModule @ 0= IF  rdrop exit  THEN                            r> $30 + dup count + 2+ swap count ">tib T Alias H ; toss                                                                                                                                     \ Target                                               21feb95pydummy  : vec:  T Prebuild vec: c, H ;                           : tcfa, ( addr -- )                                               T !tlastdes  dup 2- wx@ dup                                     0< 0= H  IF  drop T call, H :r tlastdes c!  exit  THEN T        negate  2dup + w@ H tlastdes w!                                 there tlastcfa @ = IF tlastdes 1+ c@ tlastdes 3+ c! THEN        1- tlastdes 1+ w@ T R: H                                        dup $0F00 and IF dup $000F and IF  T topt, H exit  THEN THEN    drop T macro, H ;                                             Transient also Forth  ' tcfa, IS (do_resolve                    Onlyforth                                                       : Target              Onlyforth Transient also definitions ;    Transient definitions                                           Ghost c, drop   Ghost a, drop   Ghost cfa, drop Ghost ' drop    Ghost 'prehash drop