Diff for /gforth/cross.fs between versions 1.30 and 1.100

version 1.30, 1995/11/07 18:06:35 version 1.100, 2001/07/10 20:47:09
Line 1 Line 1
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
   
 \ Copyright (C) 1995 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 17 Line 17
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
 \ Log:  0 
 \       changed in ; [ to state off           12may93jaw  [IF]
 \       included place +place                 12may93jaw  
 \       for a created word (variable, constant...)  ToDo:
 \       is now an alias in the target voabulary.  Crossdoc destination ./doc/crossdoc.fd makes no sense when
 \       this means it is no longer necessary to  cross.fs is uses seperately. jaw
 \       switch between vocabularies for variable  Do we need this char translation with >address and in branchoffset? 
 \       initialization                        12may93jaw  (>body also affected) jaw
 \       discovered error in DOES>  Clean up mark> and >resolve stuff jaw
 \       replaced !does with (;code)           16may93jaw  
 \       made complete redesign and  [THEN]
 \       introduced two vocs method  
 \       to be asure that the right words  hex
 \       are found                             08jun93jaw  
 \       btw:  ! works not with 16 bit  \ debugging for compiling
 \             targets                         09jun93jaw  
 \       added: 2user and value                11jun93jaw  \ print stack at each colon definition
   \ : : save-input cr bl word count type restore-input throw .s : ;
   
   \ print stack at each created word
   \ : create save-input cr bl word count type restore-input throw .s create ;
   
   
   \ \ -------------  Setup Vocabularies
   
   \ Remark: Vocabulary is not ANS, but it should work...
   
   Vocabulary Cross
   Vocabulary Target
   Vocabulary Ghosts
   Vocabulary Minimal
   only Forth also Target also also
   definitions Forth
   
   : T  previous Ghosts also Target ; immediate
   : G  Ghosts ; immediate
   : H  previous Forth also Cross ; immediate
   
   forth definitions
   
   : T  previous Ghosts also Target ; immediate
   : G  Ghosts ; immediate
   
   : >cross  also Cross definitions previous ;
   : >target also Target definitions previous ;
   : >minimal also Minimal definitions previous ;
   
   H
   
   >CROSS
   
   \ find out whether we are compiling with gforth
   
   : defined? bl word find nip ;
   defined? emit-file defined? toupper and \ drop 0
   [IF]
   \ use this in a gforth system
   : \GFORTH ; immediate
   : \ANSI postpone \ ; immediate
   [ELSE]
   : \GFORTH postpone \ ; immediate
   : \ANSI ; immediate
   [THEN]
   
   \ANSI : [IFUNDEF] defined? 0= postpone [IF] ; immediate
   \ANSI : [IFDEF] defined? postpone [IF] ; immediate
   0 \ANSI drop 1
   [IF]
   : \G postpone \ ; immediate
   : rdrop postpone r> postpone drop ; immediate
   : name bl word count ;
   : bounds over + swap ;
   : scan >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN rdrop ;
   : linked here over @ , swap ! ;
   : alias create , DOES> @ EXECUTE ;
   : defer ['] noop alias ;
   : is state @ 
     IF ' >body postpone literal postpone ! 
     ELSE ' >body ! THEN ; immediate
   : 0>= 0< 0= ;
   : d<> rot <> -rot <> or ;
   : toupper dup [char] a [char] z 1+ within IF [char] A [char] a - + THEN ;
   Variable ebuf
   : emit-file ( c fd -- ior ) swap ebuf c! ebuf 1 chars rot write-file ;
   0a Constant #lf
   0d Constant #cr
   
   [IFUNDEF] Warnings Variable Warnings [THEN]
   
   \ \ Number parsing                                      23feb93py
   
   \ number? number                                       23feb93py
   
   Variable dpl
   
   hex
   Create bases   10 ,   2 ,   A , 100 ,
   \              16     2    10   character
   
   \ !! protect BASE saving wrapper against exceptions
   : getbase ( addr u -- addr' u' )
       over c@ [char] $ - dup 4 u<
       IF
           cells bases + @ base ! 1 /string
       ELSE
           drop
       THEN ;
   
   : sign? ( addr u -- addr u flag )
       over c@ [char] - =  dup >r
       IF
           1 /string
       THEN
       r> ;
   
   : s>unumber? ( addr u -- ud flag )
       over [char] ' =
       IF  \ a ' alone is rather unusual :-)
           drop char+ c@ 0 true EXIT 
       THEN
       base @ >r  dpl on  getbase
       0. 2swap
       BEGIN ( d addr len )
           dup >r >number dup
       WHILE \ there are characters left
           dup r> -
       WHILE \ the last >number parsed something
           dup 1- dpl ! over c@ [char] . =
       WHILE \ the current char is '.'
           1 /string
       REPEAT  THEN \ there are unparseable characters left
           2drop false
       ELSE
           rdrop 2drop true
       THEN
       r> base ! ;
   
   \ ouch, this is complicated; there must be a simpler way - anton
   : s>number? ( addr len -- d f )
       \ converts string addr len into d, flag indicates success
       sign? >r
       s>unumber?
       0= IF
           rdrop false
       ELSE \ no characters left, all ok
           r>
           IF
               dnegate
           THEN
           true
       THEN ;
   
   : s>number ( addr len -- d )
       \ don't use this, there is no way to tell success
       s>number? drop ;
   
   : snumber? ( c-addr u -- 0 / n -1 / d 0> )
       s>number? 0=
       IF
           2drop false  EXIT
       THEN
       dpl @ dup 0< IF
           nip
       ELSE
           1+
       THEN ;
   
 \ include other.fs       \ ansforth extentions for cross  : number? ( string -- string 0 / n -1 / d 0> )
       dup >r count snumber? dup if
           rdrop
       else
           r> swap
       then ;
   
   : number ( string -- d )
       number? ?dup 0= abort" ?"  0<
       IF
           s>d
       THEN ;
   
   [THEN]
   
   hex     \ the defualt base for the cross-compiler is hex !!
   \ Warnings off
   
   \ words that are generaly useful
   
   : KB  400 * ;
   : >wordlist ( vocabulary-xt -- wordlist-struct )
     also execute get-order swap >r 1- set-order r> ;
   
   : umax 2dup u< IF swap THEN drop ;
   : umin 2dup u> IF swap THEN drop ;
   
 : string, ( c-addr u -- )  : string, ( c-addr u -- )
     \ puts down string as cstring      \ puts down string as cstring
     dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;
 ' falign Alias cfalign  
   : ," [char] " parse string, ;
   
   : SetValue ( n -- <name> )
   \G Same behaviour as "Value" if the <name> is not defined
   \G Same behaviour as "to" if <name> is defined
   \G SetValue searches in the current vocabulary
     save-input bl word >r restore-input throw r> count
     get-current search-wordlist
     IF    drop >r
           \ we have to set current to be topmost context wordlist
           get-order get-order get-current swap 1+ set-order
           r> ['] to execute
           set-order
     ELSE Value THEN ;
   
   : DefaultValue ( n -- <name> )
   \G Same behaviour as "Value" if the <name> is not defined
   \G DefaultValue searches in the current vocabulary
    save-input bl word >r restore-input throw r> count
    get-current search-wordlist
    IF bl word drop 2drop ELSE Value THEN ;
   
   hex
   
   \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are
                           \ for cross-compiling
   \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!
   
 : comment? ( c-addr u -- c-addr u )  : comment? ( c-addr u -- c-addr u )
         2dup s" (" compare 0=          2dup s" (" compare 0=
         IF    postpone (          IF    postpone (
         ELSE  2dup s" \" compare 0= IF postpone \ THEN          ELSE  2dup s" \" compare 0= IF postpone \ THEN
         THEN ;          THEN ;
   
   \ Begin CROSS COMPILER:
   
   \ debugging
   
   0 [IF]
   
   This implements debugflags for the cross compiler and the compiled
   images. It works identical to the has-flags in the environment.
   The debugflags are defined in a vocabluary. If the word exists and
   its value is true, the flag is switched on.
   
   [THEN]
   
   >CROSS
   
   Vocabulary debugflags   \ debug flags for cross
   also debugflags get-order over
   Constant debugflags-wl
   set-order previous
   
   : DebugFlag
     get-current >r debugflags-wl set-current
     SetValue
     r> set-current ;
   
   : Debug? ( adr u -- flag )
   \G return true if debug flag is defined or switched on
     debugflags-wl search-wordlist
     IF EXECUTE
     ELSE false THEN ;
   
   : D? ( <name> -- flag )
   \G return true if debug flag is defined or switched on
   \G while compiling we do not return the current value but
     bl word count debug? ;
   
   : [d?]
   \G compile the value-xt so the debug flag can be switched
   \G the flag must exist!
     bl word count debugflags-wl search-wordlist
     IF    compile,
     ELSE  -1 ABORT" unknown debug flag"
           \ POSTPONE false 
     THEN ; immediate
   
   \ \ --------------------        source file
   
 decimal  decimal
   
 \ Begin CROSS COMPILER:  Variable cross-file-list
   0 cross-file-list !
   Variable target-file-list
   0 target-file-list !
   Variable host-file-list
   0 host-file-list !
   
   cross-file-list Value file-list
   0 Value source-desc
   
   \ file loading
   
   : >fl-id   1 cells + ;
   : >fl-name 2 cells + ;
   
   Variable filelist 0 filelist !
   Create NoFile ," #load-file#"
   
   : loadfile ( -- adr )
     source-desc ?dup IF >fl-name ELSE NoFile THEN ;
   
   : sourcefilename ( -- adr len ) 
     loadfile count ;
   
   \ANSI : sourceline# 0 ;
   
   \ \ --------------------        path handling from kernel/paths.fs
   
   \ paths.fs path file handling                                    03may97jaw
   
   \ -Changing the search-path:
   \ fpath+ <path>         adds a directory to the searchpath
   \ fpath= <path>|<path>  makes complete now searchpath
   \                       seperator is |
   \ .fpath                displays the search path
   \ remark I: 
   \ a ./ in the beginning of filename is expanded to the directory the
   \ current file comes from. ./ can also be included in the search-path!
   \ ~+/ loads from the current working directory
   
   \ remark II:
   \ if there is no sufficient space for the search path increase it!
   
   
   \ -Creating custom paths:
   
   \ It is possible to use the search mechanism on yourself.
   
   \ Make a buffer for the path:
   \ create mypath 100 chars ,     \ maximum length (is checked)
   \               0 ,             \ real len
   \               100 chars allot \ space for path
   \ use the same functions as above with:
   \ mypath path+ 
   \ mypath path=
   \ mypath .path
   
   \ do a open with the search path:
   \ open-path-file ( adr len path -- fd adr len ior )
   \ the file is opened read-only; if the file is not found an error is generated
   
   \ questions to: wilke@jwdt.com
   
   [IFUNDEF] +place
   : +place ( adr len adr )
           2dup >r >r
           dup c@ char+ + swap move
           r> r> dup c@ rot + swap c! ;
   [THEN]
   
   [IFUNDEF] place
   : place ( c-addr1 u c-addr2 )
           2dup c! char+ swap move ;
   [THEN]
   
   \ if we have path handling, use this and the setup of it
   [IFUNDEF] open-fpath-file
   
   create sourcepath 1024 chars , 0 , 1024 chars allot \ !! make this dynamic
   sourcepath value fpath
   
   : also-path ( adr len path^ -- )
     >r
     \ len check
     r@ cell+ @ over + r@ @ u> ABORT" path buffer too small!"
     \ copy into
     tuck r@ cell+ dup @ cell+ + swap cmove
     \ make delimiter
     0 r@ cell+ dup @ cell+ + 2 pick + c! 1 + r> cell+ +!
     ;
   
   : only-path ( adr len path^ -- )
     dup 0 swap cell+ ! also-path ;
   
   : path+ ( path-addr  "dir" -- ) \ gforth
       \G Add the directory @var{dir} to the search path @var{path-addr}.
       name rot also-path ;
   
   : fpath+ ( "dir" ) \ gforth
       \G Add directory @var{dir} to the Forth search path.
       fpath path+ ;
   
   : path= ( path-addr "dir1|dir2|dir3" ) \ gforth
       \G Make a complete new search path; the path separator is |.
       name 2dup bounds ?DO i c@ [char] | = IF 0 i c! THEN LOOP
       rot only-path ;
   
   : fpath= ( "dir1|dir2|dir3" ) \ gforth
       \G Make a complete new Forth search path; the path separator is |.
       fpath path= ;
   
   : path>counted  cell+ dup cell+ swap @ ;
   
   : next-path ( adr len -- adr2 len2 )
     2dup 0 scan
     dup 0= IF     2drop 0 -rot 0 -rot EXIT THEN
     >r 1+ -rot r@ 1- -rot
     r> - ;
   
   : previous-path ( path^ -- )
     dup path>counted
     BEGIN tuck dup WHILE repeat ;
   
   : .path ( path-addr -- ) \ gforth
       \G Display the contents of the search path @var{path-addr}.
       path>counted
       BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ;
   
   : .fpath ( -- ) \ gforth
       \G Display the contents of the Forth search path.
       fpath .path ;
   
   : absolut-path? ( addr u -- flag ) \ gforth
       \G A path is absolute if it starts with a / or a ~ (~ expansion),
       \G or if it is in the form ./*, extended regexp: ^[/~]|./, or if
       \G it has a colon as second character ("C:...").  Paths simply
       \G containing a / are not absolute!
       2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....
       over c@ [char] / = >r
       over c@ [char] ~ = >r
       \ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic
       2 min S" ./" compare 0=
       r> r> r> or or or ;
   
   Create ofile 0 c, 255 chars allot
   Create tfile 0 c, 255 chars allot
   
   : pathsep? dup [char] / = swap [char] \ = or ;
   
   : need/   ofile dup c@ + c@ pathsep? 0= IF s" /" ofile +place THEN ;
   
   : extractpath ( adr len -- adr len2 )
     BEGIN dup WHILE 1-
           2dup + c@ pathsep? IF EXIT THEN
     REPEAT ;
   
   : remove~+ ( -- )
       ofile count 3 min s" ~+/" compare 0=
       IF
           ofile count 3 /string ofile place
       THEN ;
   
   : expandtopic ( -- ) \ stack effect correct? - anton
       \ expands "./" into an absolute name
       ofile count 2 min s" ./" compare 0=
       IF
           ofile count 1 /string tfile place
           0 ofile c! sourcefilename extractpath ofile place
           ofile c@ IF need/ THEN
           tfile count over c@ pathsep? IF 1 /string THEN
           ofile +place
       THEN ;
   
   : compact.. ( adr len -- adr2 len2 )
       \ deletes phrases like "xy/.." out of our directory name 2dec97jaw
       over swap
       BEGIN  dup  WHILE
           dup >r '/ scan 2dup 4 min s" /../" compare 0=
           IF
               dup r> - >r 4 /string over r> + 4 -
               swap 2dup + >r move dup r> over -
           ELSE
               rdrop dup 1 min /string
           THEN
       REPEAT  drop over - ;
   
   : reworkdir ( -- )
     remove~+
     ofile count compact..
     nip ofile c! ;
   
   : open-ofile ( -- fid ior )
       \G opens the file whose name is in ofile
       expandtopic reworkdir
       ofile count r/o open-file ;
   
   : check-path ( adr1 len1 adr2 len2 -- fd 0 | 0 <>0 )
     0 ofile ! >r >r ofile place need/
     r> r> ofile +place
     open-ofile ;
   
   : open-path-file ( addr1 u1 path-addr -- wfileid addr2 u2 0 | ior ) \ gforth
       \G Look in path @var{path-addr} for the file specified by @var{addr1 u1}.
       \G If found, the resulting path and an open file descriptor
       \G are returned. If the file is not found, @var{ior} is non-zero.
     >r
     2dup absolut-path?
     IF    rdrop
           ofile place open-ofile
           dup 0= IF >r ofile count r> THEN EXIT
     ELSE  r> path>counted
           BEGIN  next-path dup
           WHILE  5 pick 5 pick check-path
           0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN
     REPEAT
           2drop 2drop 2drop -38
     THEN ;
   
   : open-fpath-file ( addr1 u1 -- wfileid addr2 u2 0 | ior ) \ gforth
       \G Look in the Forth search path for the file specified by @var{addr1 u1}.
       \G If found, the resulting path and an open file descriptor
       \G are returned. If the file is not found, @var{ior} is non-zero.
       fpath open-path-file ;
   
   fpath= ~+
   
   [THEN]
   
   \ \ --------------------        include require                 13may99jaw
   
   >CROSS
   
   : add-included-file ( adr len -- adr )
     dup >fl-name char+ allocate throw >r
     file-list @ r@ ! r@ file-list !
     r@ >fl-name place r> ;
   
   : included? ( c-addr u -- f )
     file-list
     BEGIN @ dup
     WHILE >r 2dup r@ >fl-name count compare 0=
           IF rdrop 2drop true EXIT THEN
           r>
     REPEAT
     2drop drop false ;    
   
   false DebugFlag showincludedfiles
   
   : included1 ( fd adr u -- )
   \ include file adr u / fd
   \ we don't use fd with include-file, because the forth system
   \ doesn't know the name of the file to get a nice error report
     [d?] showincludedfiles
     IF    cr ." Including: " 2dup type ." ..." THEN
     rot close-file throw
     source-desc >r
     add-included-file to source-desc 
     sourcefilename
     ['] included catch
     r> to source-desc 
     throw ;
   
   : included ( adr len -- )
           cross-file-list to file-list
           open-fpath-file throw 
           included1 ;
   
   : required ( adr len -- )
           cross-file-list to file-list
           open-fpath-file throw \ 2dup cr ." R:" type
           2dup included?
           IF      2drop close-file throw
           ELSE    included1
           THEN ;
   
   : include bl word count included ;
   
   : require bl word count required ;
   
   0 [IF]
   
   also forth definitions previous
   
   : included ( adr len -- ) included ;
   
   : required ( adr len -- ) required ;
   
   : include include ;
   
   : require require ;
   
   [THEN]
   
   >CROSS
   hex
   
   \ \ --------------------        Error Handling                  05aug97jaw
   
   \ Flags
   
   also forth definitions  \ these values may be predefined before
                           \ the cross-compiler is loaded
   
   false DefaultValue stack-warn            \ check on empty stack at any definition
   false DefaultValue create-forward-warn   \ warn on forward declaration of created words
   
   previous >CROSS
   
   : .dec
     base @ decimal swap . base ! ;
   
   : .sourcepos
     cr sourcefilename type ." :"
     sourceline# .dec ;
   
   : warnhead
   \G display error-message head
   \G perhaps with linenumber and filename
     .sourcepos ." Warning: " ;
   
   : empty? depth IF .sourcepos ." Stack not empty!"  THEN ;
   
   stack-warn [IF]
   : defempty? empty? ;
   [ELSE]
   : defempty? ; immediate
   [THEN]
   
   \ \ GhostNames Ghosts                                  9may93jaw
   
 \ GhostNames                                            9may93jaw  
 \ second name source to search trough list  \ second name source to search trough list
   
 VARIABLE GhostNames  VARIABLE GhostNames
 0 GhostNames !  0 GhostNames !
   
 : GhostName ( -- addr )  : GhostName ( -- addr )
     here GhostNames @ , GhostNames ! here 0 ,      align here GhostNames @ , GhostNames ! here 0 ,
     bl word count      bl word count
     \ 2dup type space      \ 2dup type space
     string, cfalign ;      string, \ !! cfalign ?
       align ;
   
   \ Ghost Builder                                        06oct92py
   
   \ <T T> new version with temp variable                 10may93jaw
   
   VARIABLE VocTemp
   
   : <T  get-current VocTemp ! also Ghosts definitions ;
   : T>  previous VocTemp @ set-current ;
   
 hex  hex
   4711 Constant <fwd>             4712 Constant <res>
   4713 Constant <imm>             4714 Constant <do:>
   4715 Constant <skip>
   
   \  Compiler States
   
 Vocabulary Cross  Variable comp-state
 Vocabulary Target  0 Constant interpreting
 Vocabulary Ghosts  1 Constant compiling
 VOCABULARY Minimal  2 Constant resolving
 only Forth also Target also also  3 Constant assembling
 definitions Forth  
   Defer lit, ( n -- )
   Defer alit, ( n -- )
   
   Defer branch, ( target-addr -- )        \ compiles a branch
   Defer ?branch, ( target-addr -- )       \ compiles a ?branch
   Defer branchmark, ( -- branch-addr )    \ reserves room for a branch
   Defer ?branchmark, ( -- branch-addr )   \ reserves room for a ?branch
   Defer ?domark, ( -- branch-addr )       \ reserves room for a ?do branch
   Defer branchto, ( -- )                  \ actual program position is target of a branch (do e.g. alignment)
   Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
   Defer branchfrom, ( -- )                \ ?!
   Defer branchtomark, ( -- target-addr )  \ marks a branch destination
   
   Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position
   Defer prim, ( tcfa -- )                 \ compiles a primitive invocation
                                           \ at current position
   Defer colonmark, ( -- addr )            \ marks a colon call
   Defer colon-resolve ( tcfa addr -- )
   
   Defer addr-resolve ( target-addr addr -- )
   Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
   
   Defer do,       ( -- do-token )
   Defer ?do,      ( -- ?do-token )
   Defer for,      ( -- for-token )
   Defer loop,     ( do-token / ?do-token -- )
   Defer +loop,    ( do-token / ?do-token -- )
   Defer next,     ( for-token )
   
 : T  previous Cross also Target ; immediate  [IFUNDEF] ca>native
 : G  Ghosts ; immediate  defer ca>native 
 : H  previous Forth also Cross ; immediate  [THEN]
   
 forth definitions  \ ghost structure
   
 : T  previous Cross also Target ; immediate  : >magic ;              \ type of ghost
 : G  Ghosts ; immediate  : >link cell+ ;         \ pointer where ghost is in target, or if unresolved
                           \ points to the where we have to resolve (linked-list)
   : >exec cell+ cell+ ;   \ execution symantics (while target compiling) of ghost
   : >comp 3 cells + ;     \ compilation semantics
   : >end 4 cells + ;      \ room for additional tags
                           \ for builder (create, variable...) words the
                           \ execution symantics of words built are placed here
   
   \ resolve structure
   
   : >next ;               \ link to next field
   : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address, 2: doer
   : >taddr cell+ cell+ ;  
   : >ghost 3 cells + ;
   : >file 4 cells + ;
   : >line 5 cells + ;
   
   \ refer variables
   
   Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>
   Variable last-ghost     \ last ghost that is created
   Variable last-header-ghost \ last ghost definitions with header
   
   : (refered) ( ghost addr tag -- )
   \G creates a reference to ghost at address taddr
       rot >r here r@ >link @ , r> >link ! 
       ( taddr tag ) ,
       ( taddr ) , 
       last-header-ghost @ , 
       loadfile , 
       sourceline# , 
     ;
   
 : >cross  also Cross definitions previous ;  \ iForth makes only immediate directly after create
 : >target also Target definitions previous ;  \ make atonce trick! ?
 : >minimal also Minimal definitions previous ;  
   
 H  Variable atonce atonce off
   
   : NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;
   
   : is-forward   ( ghost -- )
     colonmark, 0 (refered) ; \ compile space for call
   
   : GhostHeader <fwd> , 0 , ['] NoExec , ['] is-forward , ;
   
   : Make-Ghost ( "name" -- ghost )
     >in @ GhostName swap >in !
     <T Create atonce @ IF immediate atonce off THEN
     here tuck swap ! ghostheader T>
     dup last-ghost !
     DOES> dup executed-ghost ! >exec @ execute ;
   
   \ ghost words                                          14oct92py
   \                                          changed:    10may93py/jaw
   
   : gfind   ( string -- ghost true/1 / string false )
   \ searches for string in word-list ghosts
     dup count [ ' ghosts >wordlist ] Literal search-wordlist
     dup IF >r >body nip r>  THEN ;
   
   : gdiscover ( xt -- ghost true | xt false )
     GhostNames
     BEGIN @ dup
     WHILE 2dup
           cell+ @ dup >magic @ <fwd> <>
           >r >link @ = r> and
           IF cell+ @ nip true EXIT THEN
     REPEAT
     drop false ;
   
   VARIABLE Already
   
   : ghost   ( "name" -- ghost )
     Already off
     >in @  bl word gfind   IF  atonce off Already on nip EXIT  THEN
     drop  >in !  Make-Ghost ;
   
   : >ghostname ( ghost -- adr len )
     GhostNames
     BEGIN @ dup
     WHILE 2dup cell+ @ =
     UNTIL nip 2 cells + count
     ELSE  2drop 
           \ true abort" CROSS: Ghostnames inconsistent"
           s" ?!?!?!"
     THEN ;
   
   : .ghost ( ghost -- ) >ghostname type ;
   
   \ ' >ghostname ALIAS @name
   
   : forward? ( ghost -- flag )
     >magic @ <fwd> = ;
   
   : undefined? ( ghost -- flag )
     >magic @ dup <fwd> = swap <skip> = or ;
   
   \ Predefined ghosts                                    12dec92py
   
   ghost 0=                                        drop
   ghost branch    ghost ?branch                   2drop
   ghost (do)      ghost (?do)                     2drop
   ghost (for)                                     drop
   ghost (loop)    ghost (+loop)                   2drop
   ghost (next)                                    drop
   ghost unloop    ghost ;S                        2drop
   ghost lit       ghost (compile) ghost !         2drop drop
   ghost (does>)   ghost noop                      2drop
   ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
   ghost '                                         drop
   ghost :docol    ghost :doesjump ghost :dodoes   2drop drop
   ghost :dovar    ghost :dodefer  ghost :dofield  2drop drop
   ghost over      ghost =         ghost drop      2drop drop
   ghost call      ghost useraddr  ghost execute   2drop drop
   ghost +         ghost -         ghost @         2drop drop
   ghost 2drop drop
   ghost 2dup drop
   
   \ \ Parameter for target systems                         06oct92py
   
   \ we define it ans like...
   wordlist Constant target-environment
   
   VARIABLE env-current \ save information of current dictionary to restore with environ>
   
   : >ENVIRON get-current env-current ! target-environment set-current ;
   : ENVIRON> env-current @ set-current ; 
   
   >TARGET
   
   : environment? ( adr len -- [ x ] true | false )
     target-environment search-wordlist 
     IF execute true ELSE false THEN ;
   
   : e? bl word count T environment? H 0= ABORT" environment variable not defined!" ;
   
   : has?  bl word count T environment? H 
           IF      \ environment variable is present, return its value
           ELSE    \ environment variable is not present, return false
                   false \ debug true ABORT" arg" 
           THEN ;
   
   : $has? T environment? H IF ELSE false THEN ;
   
   >ENVIRON get-order get-current swap 1+ set-order
   true SetValue compiler
   true SetValue cross
   true SetValue standard-threading
   >TARGET previous
   
   0
   [IFDEF] mach-file mach-file count 1 [THEN]
   [IFDEF] machine-file machine-file 1 [THEN]
   [IF]    included hex drop
   [ELSE]  cr ." No machine description!" ABORT 
   [THEN]
   
   >ENVIRON
   
   T has? ec H
   [IF]
   false DefaultValue relocate
   false DefaultValue file
   false DefaultValue OS
   false DefaultValue prims
   false DefaultValue floating
   false DefaultValue glocals
   false DefaultValue dcomps
   false DefaultValue hash
   false DefaultValue xconds
   false DefaultValue header
   false DefaultValue backtrace
   false DefaultValue new-input
   [THEN]
   
   true DefaultValue interpreter
   true DefaultValue ITC
   false DefaultValue rom
   true DefaultValue standardthreading
   
   >TARGET
   s" relocate" T environment? H 
   [IF]    SetValue NIL
   [ELSE]  >ENVIRON T NIL H SetValue relocate
   [THEN]
   
 >CROSS  >CROSS
   
   \ \ Create additional parameters                         19jan95py
   
   \ currently cross only works for host machines with address-unit-bits
   \ eual to 8 because of s! and sc!
   \ but I start to query the environment just to modularize a little bit
   
   : check-address-unit-bits ( -- )        
   \       s" ADDRESS-UNIT-BITS" environment?
   \       IF 8 <> ELSE true THEN
   \       ABORT" ADDRESS-UNIT-BITS unknown or not equal to 8!"
   
   \       shit, this doesn't work because environment? is only defined for 
   \       gforth.fi and not kernl???.fi
           ;
   
   check-address-unit-bits
   8 Constant bits/byte    \ we define: byte is address-unit
   
   1 bits/byte lshift Constant maxbyte 
   \ this sets byte size for the target machine, (probably right guess) jaw
   
   T
   NIL                     Constant TNIL
   cell                    Constant tcell
   cell<<                  Constant tcell<<
   cell>bit                Constant tcell>bit
   bits/char               Constant tbits/char
   bits/char H bits/byte T /      
                           Constant tchar
   float                   Constant tfloat
   1 bits/char lshift      Constant tmaxchar
   [IFUNDEF] bits/byte
   8                       Constant tbits/byte
   [ELSE]
   bits/byte               Constant tbits/byte
   [THEN]
   H
   tbits/char bits/byte /  Constant tbyte
   
   
 \ Variables                                            06oct92py  \ Variables                                            06oct92py
   
 -1 Constant NIL  
 Variable image  Variable image
 Variable tlast    NIL tlast !  \ Last name field  Variable tlast    TNIL tlast !  \ Last name field
 Variable tlastcfa \ Last code field  Variable tlastcfa \ Last code field
 Variable tdoes    \ Resolve does> calls  Variable tdoes    \ Resolve does> calls
 Variable bit$  Variable bit$
 Variable tdp  
 : there  tdp @ ;  
   
 \ Parameter for target systems                         06oct92py  \ statistics                                            10jun97jaw
   
   Variable headers-named 0 headers-named !
   Variable user-vars 0 user-vars !
   
   : target>bitmask-size ( u1 -- u2 )
     1- tcell>bit rshift 1+ ;
   
   : allocatetarget ( size -- adr )
     dup allocate ABORT" CROSS: No memory for target"
     swap over swap erase ;
   
   \ \ memregion.fs
   
   
   Variable last-defined-region    \ pointer to last defined region
   Variable region-link            \ linked list with all regions
   Variable mirrored-link          \ linked list for mirrored regions
   0 dup mirrored-link ! region-link !
   
   
   : >rname 6 cells + ;
   : >rbm   5 cells + ;
   : >rmem  4 cells + ;
   : >rlink 3 cells + ;
   : >rdp 2 cells + ;
   : >rlen cell+ ;
   : >rstart ;
   
   
   : region ( addr len -- )                \G create a new region
     \ check whether predefined region exists 
     save-input bl word find >r >r restore-input throw r> r> 0= 
     IF    \ make region
           drop
           save-input create restore-input throw
           here last-defined-region !
           over ( startaddr ) , ( length ) , ( dp ) ,
           region-link linked 0 , 0 , bl word count string,
     ELSE  \ store new parameters in region
           bl word drop
           >body >r r@ last-defined-region !
           r@ >rlen ! dup r@ >rstart ! r> >rdp !
     THEN ;
   
   : borders ( region -- startaddr endaddr ) \G returns lower and upper region border
     dup >rstart @ swap >rlen @ over + ;
   
   : extent  ( region -- startaddr len )   \G returns the really used area
     dup >rstart @ swap >rdp @ over - ;
   
   : area ( region -- startaddr totallen ) \G returns the total area
     dup >rstart @ swap >rlen @ ;
   
   : mirrored                              \G mark a region as mirrored
     mirrored-link
     align linked last-defined-region @ , ;
   
   : .addr ( u -- )
   \G prints a 16 or 32 Bit nice hex value
     base @ >r hex
     tcell 2 u>
     IF s>d <# # # # # [char] . hold # # # # #> type
     ELSE s>d <# # # # # # #> type
     THEN r> base ! ;
   
   : .regions                      \G display region statistic
   
     \ we want to list the regions in the right order
     \ so first collect all regions on stack
     0 region-link @
     BEGIN dup WHILE dup @ REPEAT drop
     BEGIN dup
     WHILE cr
           0 >rlink - >r
           r@ >rname count tuck type
           12 swap - 0 max spaces space
           ." Start: " r@ >rstart @ dup .addr space
           ." End: " r@ >rlen @ + .addr space
           ." DP: " r> >rdp @ .addr
     REPEAT drop
     s" rom" T $has? H 0= ?EXIT
     cr ." Mirrored:"
     mirrored-link @
     BEGIN dup
     WHILE space dup cell+ @ >rname count type @
     REPEAT drop cr
     ;
   
   \ -------- predefined regions
   
   0 0 region address-space
   \ total memory addressed and used by the target system
   
   0 0 region dictionary
   \ rom area for the compiler
   
   T has? rom H
   [IF]
   0 0 region ram-dictionary mirrored
   \ ram area for the compiler
   [ELSE]
   ' dictionary ALIAS ram-dictionary
   [THEN]
   
   0 0 region return-stack
   
   0 0 region data-stack
   
   0 0 region tib-region
   
   ' dictionary ALIAS rom-dictionary
   
   
   : setup-target ( -- )   \G initialize target's memory space
     s" rom" T $has? H
     IF  \ check for ram and rom...
         \ address-space area nip 0<>
         ram-dictionary area nip 0<>
         rom-dictionary area nip 0<>
         and 0=
         ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!"
     THEN
     address-space area nip
     IF
         address-space area
     ELSE
         dictionary area
     THEN
     nip 0=
     ABORT" CROSS: define at least address-space or dictionary!!"
   
     \ allocate target for each region
     region-link
     BEGIN @ dup
     WHILE dup
           0 >rlink - >r
           r@ >rlen @
           IF      \ allocate mem
                   r@ >rlen @ dup
   
                   allocatetarget dup image !
                   r@ >rmem !
   
                   target>bitmask-size allocatetarget
                   dup bit$ !
                   r> >rbm !
   
           ELSE    r> drop THEN
      REPEAT drop ;
   
   \ MakeKernel                                                    22feb99jaw
   
   : makekernel ( targetsize -- targetsize )
     dup dictionary >rlen ! setup-target ;
   
   >MINIMAL
   : makekernel makekernel ;
   >CROSS
   
   \ \ switched tdp for rom support                                03jun97jaw
   
   \ second value is here to store some maximal value for statistics
   \ tempdp is also embedded here but has nothing to do with rom support
   \ (needs switched dp)
   
   variable tempdp 0 ,     \ temporary dp for resolving
   variable tempdp-save
   
   0 [IF]
   variable romdp 0 ,      \ Dictionary-Pointer for ramarea
   variable ramdp 0 ,      \ Dictionary-Pointer for romarea
   
   \
   variable sramdp         \ start of ram-area for forth
   variable sromdp         \ start of rom-area for forth
   
   [THEN]
   
   
   0 value tdp
   variable fixed          \ flag: true: no automatic switching
                           \       false: switching is done automatically
   
   \ Switch-Policy:
   \
   \ a header is always compiled into rom
   \ after a created word (create and variable) compilation goes to ram
   \
   \ Be careful: If you want to make the data behind create into rom
   \ you have to put >rom before create!
   
   variable constflag constflag off
   
   : activate ( region -- )
   \G next code goes to this region
     >rdp to tdp ;
   
   : (switchram)
     fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
     ram-dictionary activate ;
   
   : switchram
     constflag @
     IF constflag off ELSE (switchram) THEN ;
   
   : switchrom
     fixed @ ?EXIT rom-dictionary activate ;
   
   : >tempdp ( addr -- ) 
     tdp tempdp-save ! tempdp to tdp tdp ! ;
   : tempdp> ( -- )
     tempdp-save @ to tdp ;
   
 included  : >ram  fixed off (switchram) fixed on ;
   : >rom  fixed off switchrom fixed on ;
   : >auto fixed off switchrom ;
   
 \ Create additional parameters                         19jan95py  
   
 T  
 cell               Constant tcell  \ : romstart dup sromdp ! romdp ! ;
 cell<<             Constant tcell<<  \ : ramstart dup sramdp ! ramdp ! ;
 cell>bit           Constant tcell>bit  
 bits/byte          Constant tbits/byte  \ default compilation goes to rom
 float              Constant tfloat  \ when romable support is off, only the rom switch is used (!!)
 1 bits/byte lshift Constant maxbyte  >auto
 H  
   : there  tdp @ ;
   
 >TARGET  >TARGET
   
   \ \ Target Memory Handling
   
 \ Byte ordering and cell size                          06oct92py  \ Byte ordering and cell size                          06oct92py
   
 : cell+         tcell + ;  : cell+         tcell + ;
 : cells         tcell<< lshift ;  : cells         tcell<< lshift ;
 : chars         ;  : chars         tchar * ;
   : char+         tchar + ;
 : floats        tfloat * ;  : floats        tfloat * ;
           
 >CROSS  >CROSS
 : cell/         tcell<< rshift ;  : cell/         tcell<< rshift ;
 >TARGET  >TARGET
 20 CONSTANT bl  20 CONSTANT bl
 -1 Constant NIL  \ TNIL Constant NIL
 -2 Constant :docol  
 -3 Constant :docon  
 -4 Constant :dovar  
 -5 Constant :douser  
 -6 Constant :dodefer  
 -7 Constant :dofield  
 -8 Constant :dodoes  
 -9 Constant :doesjump  
   
 >CROSS  >CROSS
   
 bigendian  bigendian
 [IF]  [IF]
    : T!  ( n addr -- )  >r s>d r> tcell bounds swap 1-     : S!  ( n addr -- )  >r s>d r> tcell bounds swap 1-
        DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
      : S@  ( addr -- n )  >r 0 0 r> tcell bounds
        DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
      : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-
      DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
    : T@  ( addr -- n )  >r 0 0 r> tcell bounds     : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
 [ELSE]  [ELSE]
    : T!  ( n addr -- )  >r s>d r> tcell bounds     : S!  ( n addr -- )  >r s>d r> tcell bounds
      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
    : T@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-     : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
        DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
      : Sc!  ( n addr -- )  >r s>d r> tchar bounds
        DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
      : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds swap 1-
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
 [THEN]  [THEN]
   
 \ Memory initialisation                                05dec92py  : taddr>region ( taddr -- region | 0 )
 \ Fixed bug in else part                               11may93jaw  \G finds for a target-address the correct region
   \G returns 0 if taddr is not in range of a target memory region
 [IFDEF] Memory \ Memory is a bigFORTH feature    region-link
    also Memory    BEGIN @ dup
    : initmem ( var len -- )    WHILE dup >r
      2dup swap handle! >r @ r> erase ;          0 >rlink - >r
    toss          r@ >rlen @
 [ELSE]          IF      dup r@ borders within
    : initmem ( var len -- )                  IF r> r> drop nip EXIT THEN
      tuck allocate abort" CROSS: No memory for target"          THEN
      ( len var adr ) dup rot !          r> drop
      ( len adr ) swap erase ;          r>
 [THEN]    REPEAT
     2drop 0 ;
 \ MakeKernal                                           12dec92py  
   : (>regionimage) ( taddr -- 'taddr )
 >MINIMAL    dup
 : makekernal ( targetsize -- targetsize )    \ find region we want to address
   bit$  over 1- cell>bit rshift 1+ initmem    taddr>region dup 0= ABORT" Address out of range!"
   image over initmem tdp off ;    >r
     \ calculate offset in region
     r@ >rstart @ -
     \ add regions real address in our memory
     r> >rmem @ + ;
   
 >CROSS  
 \ Bit string manipulation                               06oct92py  \ Bit string manipulation                               06oct92py
 \                                                       9may93jaw  \                                                       9may93jaw
 CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,  CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
Line 186  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 1240  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;  : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
 : +bit ( addr n -- )  >bit over c@ or swap c! ;  : +bit ( addr n -- )  >bit over c@ or swap c! ;
 : -bit ( addr n -- )  >bit invert over c@ and swap c! ;  : -bit ( addr n -- )  >bit invert over c@ and swap c! ;
 : relon ( taddr -- )  bit$ @ swap cell/ +bit ;  
 : reloff ( taddr -- )  bit$ @ swap cell/ -bit ;  : (relon) ( taddr -- )  
     [ [IFDEF] fd-relocation-table ]
     s" +" fd-relocation-table write-file throw
     dup s>d <# #s #> fd-relocation-table write-line throw
     [ [THEN] ]
     bit$ @ swap cell/ +bit ;
   
   : (reloff) ( taddr -- ) 
     [ [IFDEF] fd-relocation-table ]
     s" -" fd-relocation-table write-file throw
     dup s>d <# #s #> fd-relocation-table write-line throw
     [ [THEN] ]
     bit$ @ swap cell/ -bit ;
   
   : (>image) ( taddr -- absaddr ) image @ + ;
   
   DEFER >image
   DEFER relon
   DEFER reloff
   DEFER correcter
   
   T has? relocate H
   [IF]
   ' (relon) IS relon
   ' (reloff) IS reloff
   ' (>image) IS >image
   [ELSE]
   ' drop IS relon
   ' drop IS reloff
   ' (>regionimage) IS >image
   [THEN]
   
 \ Target memory access                                 06oct92py  \ Target memory access                                 06oct92py
   
 : align+  ( taddr -- rest )  : align+  ( taddr -- rest )
     cell tuck 1- and - [ cell 1- ] Literal and ;      tcell tuck 1- and - [ tcell 1- ] Literal and ;
 : cfalign+  ( taddr -- rest )  : cfalign+  ( taddr -- rest )
     \ see kernal.fs:cfaligned      \ see kernel.fs:cfaligned
     float tuck 1- and - [ float 1- ] Literal and ;      /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ;
   
 >TARGET  >TARGET
 : aligned ( taddr -- ta-addr )  dup align+ + ;  : aligned ( taddr -- ta-addr )  dup align+ + ;
 \ assumes cell alignment granularity (as GNU C)  \ assumes cell alignment granularity (as GNU C)
   
 : cfaligned ( taddr1 -- taddr2 )  : cfaligned ( taddr1 -- taddr2 )
     \ see kernal.fs      \ see kernel.fs
     dup cfalign+ + ;      dup cfalign+ + ;
   
 >CROSS  : @  ( taddr -- w )     >image S@ ;
 : >image ( taddr -- absaddr )  image @ + ;  : !  ( w taddr -- )     >image S! ;
 >TARGET  : c@ ( taddr -- char )  >image Sc@ ;
 : @  ( taddr -- w )     >image t@ ;  : c! ( char taddr -- )  >image Sc! ;
 : !  ( w taddr -- )     >image t! ;  
 : c@ ( taddr -- char )  >image c@ ;  
 : c! ( char taddr -- )  >image c! ;  
 : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;  : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
 : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;  : 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ;
   
 \ Target compilation primitives                        06oct92py  \ Target compilation primitives                        06oct92py
 \ included A!                                          16may93jaw  \ included A!                                          16may93jaw
   
 : here  ( -- there )    there ;  : here  ( -- there )    there ;
 : allot ( n -- )        tdp +! ;  : allot ( n -- )        tdp +! ;
 : ,     ( w -- )        T here H cell T allot  ! H ;  : ,     ( w -- )        T here H tcell T allot  ! H ;
 : c,    ( char -- )     T here    1 allot c! H ;  : c,    ( char -- )     T here H tchar T allot c! H ;
 : align ( -- )          T here H align+ 0 ?DO  bl T c, H LOOP ;  : align ( -- )          T here H align+ 0 ?DO  bl T c, H tchar +LOOP ;
 : cfalign ( -- )  : cfalign ( -- )
     T here H cfalign+ 0 ?DO  bl T c, H LOOP ;      T here H cfalign+ 0 ?DO  bl T c, H tchar +LOOP ;
   
 : A!                    dup relon T ! H ;  : >address              dup 0>= IF tbyte / THEN ; \ ?? jaw 
 : A,    ( w -- )        T here H relon T , H ;  : A!                    swap >address swap dup relon T ! H ;
   : A,    ( w -- )        >address T here H relon T , H ;
   
 >CROSS  >CROSS
   
 \ threading modell                                     13dec92py  : tcmove ( source dest len -- )
   \G cmove in target memory
     tchar * bounds
     ?DO  dup T c@ H I T c! H 1+
     tchar +LOOP  drop ;
   
 \ generic threading modell  \ \ Load Assembler
 : docol,  ( -- ) :docol T A, 0 , H ;  
   
 >TARGET  >TARGET
 : >body   ( cfa -- pfa ) T cell+ cell+ H ;  H also Forth definitions
 >CROSS  
   
 : dodoes, ( -- ) T :doesjump A, 0 , H ;  
   
 \ Ghost Builder                                        06oct92py  
   
 \ <T T> new version with temp variable                 10may93jaw  
   
 VARIABLE VocTemp  
   
 : <T  get-current VocTemp ! also Ghosts definitions ;  
 : T>  previous VocTemp @ set-current ;  
   
 4711 Constant <fwd>             4712 Constant <res>  
 4713 Constant <imm>  
   
 \ iForth makes only immediate directly after create  
 \ make atonce trick! ?  
   
 Variable atonce atonce off  
   
 : NoExec true ABORT" CROSS: Don't execute ghost" ;  
   
 : GhostHeader <fwd> , 0 , ['] NoExec , ;  : X     bl word count [ ' target >wordlist ] Literal search-wordlist
           IF      state @ IF compile,
                   ELSE execute THEN
           ELSE    -1 ABORT" Cross: access method not supported!"
           THEN ; immediate
   
 : >magic ; : >link cell+ ; : >exec cell+ cell+ ;  [IFDEF] asm-include asm-include [THEN] hex
 : >end 3 cells + ;  
   
 Variable last-ghost  previous
 : Make-Ghost ( "name" -- ghost )  >CROSS H
   >in @ GhostName swap >in !  
   <T Create atonce @ IF immediate atonce off THEN  
   here tuck swap ! ghostheader T>  
   DOES> dup last-ghost ! >exec @ execute ;  
   
 \ ghost words                                          14oct92py  \ \ --------------------        Compiler Plug Ins               01aug97jaw
 \                                          changed:    10may93py/jaw  
   
 : gfind   ( string -- ghost true/1 / string false )  >TARGET
 \ searches for string in word-list ghosts  DEFER >body             \ we need the system >body
 \ !! wouldn't it be simpler to just use search-wordlist ? ae                          \ and the target >body
   dup count [ ' ghosts >body ] ALiteral search-wordlist  >CROSS
   dup IF  >r >body nip r>  THEN ;  T 2 cells H VALUE xt>body
   DEFER doprim,   \ compiles start of a primitive
   DEFER docol,    \ compiles start of a colon definition
   DEFER doer,             
   DEFER fini,      \ compiles end of definition ;s
   DEFER doeshandler,
   DEFER dodoes,
   
   DEFER ]comp     \ starts compilation
   DEFER comp[     \ ends compilation
   
   : (prim) T a, H ;                               ' (prim) IS prim,
   
   : (cr) >tempdp ]comp prim, comp[ tempdp> ;      ' (cr) IS colon-resolve
   : (ar) T ! H ;                                  ' (ar) IS addr-resolve
   : (dr)  ( ghost res-pnt target-addr addr )
           >tempdp drop over 
           dup >magic @ <do:> =
           IF      doer,
           ELSE    dodoes,
           THEN 
           tempdp> ;                               ' (dr) IS doer-resolve
   
   : (cm) ( -- addr )
       T here align H
       -1 prim, ;                                  ' (cm) IS colonmark,
   
 VARIABLE Already  >TARGET
   : compile, prim, ;
   >CROSS
   
 : ghost   ( "name" -- ghost )  : refered ( ghost tag -- )
   Already off  \G creates a resolve structure
   >in @  bl word gfind   IF  Already on nip EXIT  THEN      T here aligned H swap (refered)
   drop  >in !  Make-Ghost ;    ;
   
   : killref ( addr ghost -- )
   \G kills a forward reference to ghost at position addr
   \G this is used to eleminate a :dovar refence after making a DOES>
       dup >magic @ <fwd> <> IF 2drop EXIT THEN
       swap >r >link
       BEGIN dup @ dup  ( addr last this )
       WHILE dup >taddr @ r@ =
            IF   @ over !
            ELSE nip THEN
       REPEAT rdrop 2drop 
     ;
   
   Defer resolve-warning
   
   : reswarn-test ( ghost res-struct -- ghost res-struct )
     over cr ." Resolving " .ghost dup ."  in " >ghost @ .ghost ;
   
   : reswarn-forward ( ghost res-struct -- ghost res-struct )
     over warnhead .ghost dup ."  is referenced in " 
     >ghost @ .ghost ;
   
   \ ' reswarn-test IS resolve-warning
    
 \ resolve                                              14oct92py  \ resolve                                              14oct92py
   
 : resolve-loop ( ghost tcfa -- ghost tcfa )   : resolve-loop ( ghost resolve-list tcfa -- )
   >r dup >link @      >r
   BEGIN  dup  WHILE  dup T @ H r@ rot T ! H REPEAT  drop r> ;      BEGIN dup WHILE 
   \         dup >tag @ 2 = IF reswarn-forward THEN
             resolve-warning 
             r@ over >taddr @ 
             2 pick >tag @
             CASE  0 OF colon-resolve ENDOF
                   1 OF addr-resolve ENDOF
                   2 OF doer-resolve ENDOF
             ENDCASE
             @ \ next list element
       REPEAT 2drop rdrop 
     ;
   
   \ : resolve-loop ( ghost tcfa -- ghost tcfa )
   \  >r dup >link @
   \  BEGIN  dup  WHILE  dup T @ H r@ rot T ! H REPEAT  drop r> ;
   
 \ exists                                                9may93jaw  \ exists                                                9may93jaw
   
   Variable TWarnings
   TWarnings on
   Variable Exists-Warnings
   Exists-Warnings on
   
 : exists ( ghost tcfa -- )  : exists ( ghost tcfa -- )
   over GhostNames    over GhostNames
   BEGIN @ dup    BEGIN @ dup
   WHILE 2dup cell+ @ =    WHILE 2dup cell+ @ =
   UNTIL    UNTIL
         2 cells + count cr ." CROSS: Exists: " type 4 spaces drop          2 cells + count
         swap cell+ !          TWarnings @ Exists-Warnings @ and
           IF warnhead type ."  exists"
           ELSE 2drop THEN
           drop swap >link !
   ELSE  true abort" CROSS: Ghostnames inconsistent "    ELSE  true abort" CROSS: Ghostnames inconsistent "
   THEN ;    THEN ;
   
   : colon-resolved   ( ghost -- )
       >link @ colon, ; \ compile-call
   : prim-resolved  ( ghost -- )
       >link @ prim, ;
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
   over >magic @ <fwd> <>  IF  exists EXIT THEN  \G resolve referencies to ghost with tcfa
   resolve-loop  over >link ! <res> swap >magic ! ;      \ is ghost resolved?, second resolve means another definition with the
       \ same name
       over undefined? 0= IF  exists EXIT THEN
       \ get linked-list
       swap >r r@ >link @ swap \ ( list tcfa R: ghost )
       \ mark ghost as resolved
       dup r@ >link ! <res> r@ >magic !
       r@ >comp @ ['] is-forward = IF
           ['] prim-resolved  r@ >comp !  THEN
       \ loop through forward referencies
       r> -rot 
       comp-state @ >r Resolving comp-state !
       resolve-loop 
       r> comp-state !
   
       ['] noop IS resolve-warning 
     ;
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
 : do-forward   ( ghost -- )  : gexecute   ( ghost -- )
   >link dup @  there rot !  T  A,  H ;      dup >comp @ execute ;
 : do-resolve   ( ghost -- )  
   >link @                   T  A,  H ;  : addr,  ( ghost -- )
     dup forward? IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;
 : gexecute   ( ghost -- )   dup @  
              <fwd> = IF  do-forward  ELSE  do-resolve  THEN ;  \ !! : ghost,     ghost  gexecute ;
 : ghost,     ghost  gexecute ;  
   
 \ .unresolved                                          11may93jaw  \ .unresolved                                          11may93jaw
   
Line 328  variable ResolveFlag Line 1482  variable ResolveFlag
   
 \ ?touched                                             11may93jaw  \ ?touched                                             11may93jaw
   
 : ?touched ( ghost -- flag ) dup >magic @ <fwd> = swap >link @  : ?touched ( ghost -- flag ) dup forward? swap >link @
                                0 <> and ;                                 0 <> and ;
   
   : .forwarddefs ( ghost -- )
           ."  appeared in:"
           >link
           BEGIN   @ dup
           WHILE   cr 5 spaces
                   dup >ghost @ .ghost
                   ."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN
                   ."  line " dup >line @ .dec
           REPEAT 
           drop ;
   
 : ?resolved  ( ghostname -- )  : ?resolved  ( ghostname -- )
   dup cell+ @ ?touched    dup cell+ @ ?touched
   IF  cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;    IF    dup 
           cell+ cell+ count cr type ResolveFlag on 
           cell+ @ .forwarddefs
     ELSE  drop 
     THEN ;
   
 >MINIMAL  
 : .unresolved  ( -- )  : .unresolved  ( -- )
   ResolveFlag off cr ." Unresolved: "    ResolveFlag off cr ." Unresolved: "
   Ghostnames    Ghostnames
Line 343  variable ResolveFlag Line 1511  variable ResolveFlag
   WHILE dup ?resolved    WHILE dup ?resolved
   REPEAT drop ResolveFlag @    REPEAT drop ResolveFlag @
   IF    IF
       abort" Unresolved words!"        -1 abort" Unresolved words!"
   ELSE    ELSE
       ." Nothing!"        ." Nothing!"
   THEN    THEN
   cr ;    cr ;
   
   : .stats
     base @ >r decimal
     cr ." named Headers: " headers-named @ . 
     r> base ! ;
   
   >MINIMAL
   
   : .unresolved .unresolved ;
   
 >CROSS  >CROSS
 \ Header states                                        12dec92py  \ Header states                                        12dec92py
   
 : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;  bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+
   : flag! ( w -- )   tlast @ flag+ + dup >r T c@ xor r> c! H ;
   
 VARIABLE ^imm  VARIABLE ^imm
   
   \ !! should be target wordsize specific
   $80 constant alias-mask
   $40 constant immediate-mask
   $20 constant restrict-mask
   
 >TARGET  >TARGET
 : immediate     20 flag!  : immediate     immediate-mask flag!
                 ^imm @ @ dup <imm> = IF  drop  EXIT  THEN                  ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
                 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"                  <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                 <imm> ^imm @ ! ;                  <imm> ^imm @ ! ;
 : restrict      40 flag! ;  : restrict      restrict-mask flag! ;
 >CROSS  
   
 \ ALIAS2 ansforth conform alias                          9may93jaw  : isdoer        
   \G define a forth word as doer, this makes obviously only sence on
 : ALIAS2 create here 0 , DOES> @ execute ;  \G forth processors such as the PSC1000
 \ usage:                  <do:> last-header-ghost @ >magic ! ;
 \ ' <name> alias2 bla !  >CROSS
   
 \ Target Header Creation                               01nov92py  \ Target Header Creation                               01nov92py
   
   >TARGET
 : string,  ( addr count -- )  : string,  ( addr count -- )
   dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;       dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;
 : name,  ( "name" -- )  bl word count string, T cfalign H ;  : lstring, ( addr count -- )
       dup T , H bounds  ?DO  I c@ T c, H  LOOP ;
   : name,  ( "name" -- )  bl word count T lstring, cfalign H ;
 : view,   ( -- ) ( dummy ) ;  : view,   ( -- ) ( dummy ) ;
   >CROSS
   
 \ Target Document Creation (goes to crossdoc.fd)       05jul95py  \ Target Document Creation (goes to crossdoc.fd)       05jul95py
   
 s" crossdoc.fd" r/w create-file throw value doc-file-id  s" ./doc/crossdoc.fd" r/w create-file throw value doc-file-id
 \ contains the file-id of the documentation file  \ contains the file-id of the documentation file
   
 : \G ( -- )  : T-\G ( -- )
     source >in @ /string doc-file-id write-line throw      source >in @ /string doc-file-id write-line throw
     source >in ! drop ; immediate      postpone \ ;
   
 Variable to-doc  Variable to-doc  to-doc on
   
 : cross-doc-entry  ( -- )  : cross-doc-entry  ( -- )
     to-doc @ tlast @ 0<> and    \ not an anonymous (i.e. noname) header      to-doc @ tlast @ 0<> and    \ not an anonymous (i.e. noname) header
     IF      IF
         s" " doc-file-id write-line throw          s" " doc-file-id write-line throw
         s" make-doc " doc-file-id write-file throw          s" make-doc " doc-file-id write-file throw
         tlast @ >image count $1F and doc-file-id write-file throw          Last-Header-Ghost @ >ghostname doc-file-id write-file throw
         >in @          >in @
         [char] ( parse 2drop          [char] ( parse 2drop
         [char] ) parse doc-file-id write-file throw          [char] ) parse doc-file-id write-file throw
         s"  )" doc-file-id write-file throw          s"  )" doc-file-id write-file throw
         [char] \ parse 2drop                                              [char] \ parse 2drop                                    
         POSTPONE \g          T-\G
         >in !          >in !
     THEN  to-doc on ;      THEN ;
   
 \ Target TAGS creation  \ Target TAGS creation
   
 s" TAGS" r/w create-file throw value tag-file-id  s" kernel.TAGS" r/w create-file throw value tag-file-id
 \ contains the file-id of the tags file  \ contains the file-id of the tags file
   
 Create tag-beg 2 c,  7F c, bl c,  Create tag-beg 2 c,  7F c, bl c,
Line 415  Create tag-bof 1 c,  0C c, Line 1601  Create tag-bof 1 c,  0C c,
 2variable last-loadfilename 0 0 last-loadfilename 2!  2variable last-loadfilename 0 0 last-loadfilename 2!
                           
 : put-load-file-name ( -- )  : put-load-file-name ( -- )
     loadfilename 2@ last-loadfilename 2@ d<>      sourcefilename last-loadfilename 2@ d<>
     IF      IF
         tag-bof count tag-file-id write-line throw          tag-bof count tag-file-id write-line throw
         loadfilename 2@ 2dup          sourcefilename 2dup
         tag-file-id write-file throw          tag-file-id write-file throw
         last-loadfilename 2!          last-loadfilename 2!
         s" ,0" tag-file-id write-line throw          s" ,0" tag-file-id write-line throw
Line 430  Create tag-bof 1 c,  0C c, Line 1616  Create tag-bof 1 c,  0C c,
         put-load-file-name          put-load-file-name
         source >in @ min tag-file-id write-file throw          source >in @ min tag-file-id write-file throw
         tag-beg count tag-file-id write-file throw          tag-beg count tag-file-id write-file throw
         tlast @ >image count $1F and tag-file-id write-file throw          tlast @ >image count 1F and tag-file-id write-file throw
         tag-end count tag-file-id write-file throw          tag-end count tag-file-id write-file throw
         base @ decimal loadline @ 0 <# #s #> tag-file-id write-file throw          base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
 \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw  \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
         s" ,0" tag-file-id write-line throw          s" ,0" tag-file-id write-line throw
         base !          base !
     THEN ;      THEN ;
   
   \ Check for words
   
   Defer skip? ' false IS skip?
   
   : skipdef ( <name> -- )
   \G skip definition of an undefined word in undef-words and
   \G all-words mode
       ghost dup forward?
       IF  >magic <skip> swap !
       ELSE drop THEN ;
   
   : tdefined? ( -- flag ) \ name
       ghost undefined? 0= ;
   
   : defined2? ( -- flag ) \ name
   \G return true for anything else than forward, even for <skip>
   \G that's what we want
       ghost forward? 0= ;
   
   : forced? ( -- flag ) \ name
   \G return ture if it is a foreced skip with defskip
       ghost >magic @ <skip> = ;
   
   : needed? ( -- flag ) \ name
   \G returns a false flag when
   \G a word is not defined
   \G a forward reference exists
   \G so the definition is not skipped!
       bl word gfind
       IF dup undefined?
           nip
           0=
       ELSE  drop true  THEN ;
   
   : doer? ( -- flag ) \ name
       ghost >magic @ <do:> = ;
   
   : skip-defs ( -- )
       BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;
   
 \ Target header creation  \ Target header creation
   
 VARIABLE CreateFlag CreateFlag off  Variable NoHeaderFlag
   NoHeaderFlag off
   
 : (Theader ( "name" -- ghost ) T align H view,  : 0.r ( n1 n2 -- ) 
   tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !      base @ >r hex 
   >in @ name, >in ! T here H tlastcfa !      0 swap <# 0 ?DO # LOOP #> type 
   CreateFlag @ IF      r> base ! ;
        >in @ alias2 swap >in !         \ create alias in target  
        >in @ ghost swap >in !  : .sym ( adr len -- )
        swap also ghosts ' previous swap !     \ tick ghost and store in alias  \G escapes / and \ to produce sed output
        CreateFlag off    bounds 
   ELSE ghost THEN    DO I c@ dup
   dup >magic ^imm !     \ a pointer for immediate          CASE    [char] / OF drop ." \/" ENDOF
   Already @ IF  dup >end tdoes !                  [char] \ OF drop ." \\" ENDOF
   ELSE 0 tdoes ! THEN                  dup OF emit ENDOF
   80 flag!          ENDCASE
   cross-doc-entry cross-tag-entry ;      LOOP ;
   
   : (Theader ( "name" -- ghost )
       \  >in @ bl word count type 2 spaces >in !
       \ wordheaders will always be compiled to rom
       switchrom
       \ build header in target
       NoHeaderFlag @
       IF  NoHeaderFlag off
       ELSE
           T align H view,
           tlast @ dup 0> IF tcell - THEN T A, H  there tlast !
           1 headers-named +!      \ Statistic
           >in @ T name, H >in !
       THEN
       T cfalign here H tlastcfa !
       \ Old Symbol table sed-script
   \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
       ghost
       \ output symbol table to extra file
       [ [IFDEF] fd-symbol-table ]
         base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !
         s" :" fd-symbol-table write-file throw
         dup >ghostname fd-symbol-table write-line throw
       [ [THEN] ]
       dup Last-Header-Ghost !
       dup >magic ^imm !     \ a pointer for immediate
       Already @
       IF  dup >end tdoes !
       ELSE 0 tdoes !
       THEN
       alias-mask flag!
       cross-doc-entry cross-tag-entry ;
   
 VARIABLE ;Resolve 1 cells allot  VARIABLE ;Resolve 1 cells allot
   \ this is the resolver information from ":"
   \ resolving is done by ";"
   
 : Theader  ( "name" -- ghost )  : Theader  ( "name" -- ghost )
   (THeader dup there resolve 0 ;Resolve ! ;    (THeader dup there resolve 0 ;Resolve ! ;
   
 >TARGET  >TARGET
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
   dup 0< IF  to-doc off  THEN      >in @ skip? IF  2drop  EXIT  THEN  >in !
   (THeader over resolve T A, H 80 flag! ;      dup 0< s" prims" T $has? H 0= and
       IF
           .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
       THEN
       (THeader over resolve T A, H alias-mask flag! ;
   : Alias:   ( cfa -- ) \ name
       >in @ skip? IF  2drop  EXIT  THEN  >in !
       dup 0< s" prims" T $has? H 0= and
       IF
           .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
       THEN
       ghost tuck swap resolve <do:> swap >magic ! ;
   
   Variable prim#
   : first-primitive ( n -- )  prim# ! ;
   : Primitive  ( -- ) \ name
       prim# @ T Alias H  -1 prim# +! ;
 >CROSS  >CROSS
   
 \ Conditionals and Comments                            11may93jaw  \ Conditionals and Comments                            11may93jaw
Line 489  VARIABLE ;Resolve 1 cells allot Line 1766  VARIABLE ;Resolve 1 cells allot
   
 Comment (       Comment \  Comment (       Comment \
   
 \ Predefined ghosts                                    12dec92py  
   
 ghost 0=                                        drop  
 ghost branch    ghost ?branch                   2drop  
 ghost (do)      ghost (?do)                     2drop  
 ghost (for)                                     drop  
 ghost (loop)    ghost (+loop)                   2drop  
 ghost (next)                                    drop  
 ghost unloop    ghost ;S                        2drop  
 ghost lit       ghost (compile) ghost !         2drop drop  
 ghost (does>)   ghost noop                      2drop  
 ghost (.")      ghost (S")      ghost (ABORT")  2drop drop  
 ghost '  
   
 \ compile                                              10may93jaw  \ compile                                              10may93jaw
   
 : compile  ( -- ) \ name  : compile  ( -- ) \ name
Line 513  ghost ' Line 1776  ghost '
   ELSE  postpone literal postpone gexecute  THEN ;    ELSE  postpone literal postpone gexecute  THEN ;
                                         immediate                                          immediate
   
   T has? peephole H [IF]
   : (cc) compile call T >body a, H ;              ' (cc) IS colon,
   [ELSE]
       ' (prim) IS colon,
   [THEN]
   
   : [G'] 
   \G ticks a ghost and returns its address
     bl word gfind 0= ABORT" CROSS: Ghost don't exists"
     state @
     IF   postpone literal
     THEN ; immediate
   
   : ghost>cfa
     dup undefined? ABORT" CROSS: forward " >link @ ;
                  
 >TARGET  >TARGET
 : '  ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "  
   dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;  
   
 Cond: [']  compile lit ghost gexecute ;Cond  : '  ( -- cfa ) 
   \ returns the target-cfa of a ghost
     bl word gfind 0= ABORT" CROSS: Ghost don't exists"
     ghost>cfa ;
   
 Cond: chars ;Cond  Cond: [']  T ' H alit, ;Cond
   
 >CROSS  >CROSS
 \ tLiteral                                             12dec92py  
   
 : lit, ( n -- )   compile lit T  ,  H ;  : [T']
 : alit, ( n -- )  compile lit T A,  H ;  \ returns the target-cfa of a ghost, or compiles it as literal
     postpone [G'] state @ IF postpone ghost>cfa ELSE ghost>cfa THEN ; immediate
   
   \ \ threading modell                                    13dec92py
   \ modularized                                           14jun97jaw
   
   : fillcfa   ( usedcells -- )
     T cells H xt>body swap - 0 ?DO 0 X c, tchar +LOOP ;
   
   : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H
   
   : (doer,)   ( ghost -- ) ]comp addr, comp[ 1 fillcfa ;   ' (doer,) IS doer,
   
   : (docol,)  ( -- ) [G'] :docol doer, ;          ' (docol,) IS docol,
   
   : (doprim,) ( -- )
     there xt>body + ca>native T a, H 1 fillcfa ;  ' (doprim,) IS doprim,
   
   : (doeshandler,) ( -- ) 
     T cfalign H compile :doesjump T 0 , H ;       ' (doeshandler,) IS doeshandler,
   
   : (dodoes,) ( does-action-ghost -- )
     ]comp [G'] :dodoes gexecute comp[
     addr,
     T here H tcell - reloff 2 fillcfa ;           ' (dodoes,) IS dodoes,
   
   : (lit,) ( n -- )   compile lit T  ,  H ;       ' (lit,) IS lit,
   
   \ if we dont produce relocatable code alit, defaults to lit, jaw
   \ this is just for convenience, so we don't have to define alit,
   \ seperately for embedded systems....
   T has? relocate H
   [IF]
   : (alit,) ( n -- )  compile lit T  a, H ;       ' (alit,) IS alit,
   [ELSE]
   : (alit,) ( n -- )  lit, ;                      ' (alit,) IS alit,
   [THEN]
   
   : (fini,)         compile ;s ;                ' (fini,) IS fini,
   
   [IFUNDEF] (code) 
   Defer (code)
   Defer (end-code)
   [THEN]
   
   >TARGET
   : Code
     defempty?
     (THeader there resolve
     [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
     doprim, 
     [THEN]
     depth (code) ;
   
   : Code:
     defempty?
       ghost dup there ca>native resolve  <do:> swap >magic !
       depth (code) ;
   
   : end-code
       (end-code)
       depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
       ELSE true ABORT" CROSS: Stack empty" THEN
       ;
   
   >CROSS
   
   \ tLiteral                                             12dec92py
   
 >TARGET  >TARGET
   Cond: \G  T-\G ;Cond
   
 Cond:  Literal ( n -- )   restrict? lit, ;Cond  Cond:  Literal ( n -- )   restrict? lit, ;Cond
 Cond: ALiteral ( n -- )   restrict? alit, ;Cond  Cond: ALiteral ( n -- )   restrict? alit, ;Cond
   
 : Char ( "<char>" -- )  bl word char+ c@ ;  : Char ( "<char>" -- )  bl word char+ c@ ;
 Cond: [Char]   ( "<char>" -- )  restrict? Char  lit, ;Cond  Cond: [Char]   ( "<char>" -- )  restrict? Char  lit, ;Cond
   
   \ some special literals                                 27jan97jaw
   
   \ !! Known Bug: Special Literals and plug-ins work only correct
   \ on targets with char = 8 bit
   
   Cond: MAXU
     restrict? 
     compile lit tcell 0 ?DO FF T c, H LOOP 
     ;Cond
   
   Cond: MINI
     restrict?
     compile lit bigendian 
     IF    80 T c, H tcell 1 ?DO 0 T c, H LOOP 
     ELSE  tcell 1 ?DO 0 T c, H LOOP 80 T c, H
     THEN
     ;Cond
    
   Cond: MAXI
    restrict?
    compile lit bigendian 
    IF     7F T c, H tcell 1 ?DO FF T c, H LOOP
    ELSE   tcell 1 ?DO FF T c, H LOOP 7F T c, H
    THEN
    ;Cond
   
 >CROSS  >CROSS
 \ Target compiling loop                                12dec92py  \ Target compiling loop                                12dec92py
 \ ">tib trick thrown out                               10may93jaw  \ ">tib trick thrown out                               10may93jaw
 \ number? defined at the top                           11may93jaw  \ number? defined at the top                           11may93jaw
   \ replaced >in by save-input                            
   
   : discard 0 ?DO drop LOOP ;
   
 \ compiled word might leave items on stack!  \ compiled word might leave items on stack!
 : tcom ( in name -- )  : tcom ( x1 .. xn n name -- )
   gfind  ?dup  IF    0> IF    nip >exec @ execute  \  dup count type space
                         ELSE  nip gexecute  THEN EXIT THEN    gfind  ?dup
   number? dup  IF    0> IF swap lit,  THEN  lit,  drop    IF    >r >r discard r> r>
                ELSE  2drop >in !          0> IF   >exec @ execute
                ghost gexecute THEN  ;          ELSE    gexecute  THEN 
           EXIT 
     THEN
     number? dup  
     IF    0> IF swap lit,  THEN  lit, discard
     ELSE  2drop restore-input throw ghost gexecute THEN  ;
   
 >TARGET  >TARGET
 \ : ; DOES>                                            13dec92py  \ : ; DOES>                                            13dec92py
 \ ]                                                     9may93py/jaw  \ ]                                                     9may93py/jaw
   
 : ] state on  : ] state on
       Compiling comp-state !
     BEGIN      BEGIN
         BEGIN >in @ bl word          BEGIN save-input bl word
               dup c@ 0= WHILE 2drop refill 0=                dup c@ 0= WHILE drop discard refill 0=
               ABORT" CROSS: End of file while target compiling"                ABORT" CROSS: End of file while target compiling"
         REPEAT          REPEAT
         tcom          tcom
Line 566  Cond: [Char]   ( "<char>" -- )  restrict Line 1949  Cond: [Char]   ( "<char>" -- )  restrict
 \             is not allowed if a system should be ans conform  \             is not allowed if a system should be ans conform
   
 : : ( -- colon-sys ) \ Name  : : ( -- colon-sys ) \ Name
     defempty?
     constflag off \ don't let this flag work over colon defs
                   \ just to go sure nothing unwanted happens
     >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !
   (THeader ;Resolve ! there ;Resolve cell+ !    (THeader ;Resolve ! there ;Resolve cell+ !
   docol, depth T ] H ;    docol, ]comp depth T ] H ;
   
   : :noname ( -- colon-sys )
     T cfalign H there docol, 0 ;Resolve ! depth T ] H ;
   
 Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond  Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond
   
 Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond  Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
   
   >CROSS
   : LastXT ;Resolve @ 0= abort" CROSS: no definition for LastXT"
            ;Resolve cell+ @ ;
   
   >TARGET
   
   Cond: recurse ( -- ) Last-Ghost @ gexecute ;Cond
   
 Cond: ; ( -- ) restrict?  Cond: ; ( -- ) restrict?
                depth ?dup IF   1- <> ABORT" CROSS: Stack changed"                 depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
                           ELSE true ABORT" CROSS: Stack empty" THEN                            ELSE true ABORT" CROSS: Stack empty" THEN
                compile ;S state off                 fini,
                  comp[
                  state off
                ;Resolve @                 ;Resolve @
                IF ;Resolve @ ;Resolve cell+ @ resolve THEN                 IF ;Resolve @ ;Resolve cell+ @ resolve
                     ['] colon-resolved ;Resolve @ >comp ! THEN
                   Interpreting comp-state !
                ;Cond                 ;Cond
 Cond: [  restrict? state off ;Cond  Cond: [  restrict? state off Interpreting comp-state ! ;Cond
   
 >CROSS  >CROSS
 : !does  :dodoes tlastcfa @ tuck T ! cell+ ! H ;  
   Create GhostDummy ghostheader
   <res> GhostDummy >magic !
   
   : !does ( does-action -- )
   \ !! zusammenziehen und dodoes, machen!
       tlastcfa @ [G'] :dovar killref
   \    tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
   \ !! geht so nicht, da dodoes, ghost will!
       GhostDummy >link ! GhostDummy 
       tlastcfa @ >tempdp dodoes, tempdp> ;
   
   : g>body ( ghost -- body )
       >link @ T >body H ;
   : does-resolved ( ghost -- )
       dup g>body alit, >end @ g>body colon, ;
   
 >TARGET  >TARGET
 Cond: DOES> restrict?  Cond: DOES> restrict?
         compile (does>) dodoes, tdoes @ ?dup IF  @ T here H resolve THEN          compile (does>) doeshandler, 
           \ resolve words made by builders
           tdoes @ ?dup IF  @ dup T here H resolve
               ['] prim-resolved swap >comp !  THEN
         ;Cond          ;Cond
 : DOES> dodoes, T here H !does depth T ] H ;  : DOES> switchrom doeshandler, T here H !does depth T ] H ;
   
 >CROSS  >CROSS
 \ Creation                                             01nov92py  \ Creation                                             01nov92py
   
 \ Builder                                               11may93jaw  \ Builder                                               11may93jaw
   
 : Builder    ( Create do: "name" -- )  : Builder    ( Create-xt do-ghost "name" -- )
   >in @ alias2 swap dup >in ! >r >r  \ builds up a builder in current vocabulary
   Make-Ghost rot swap >exec ! ,  \ create-xt is executed when word is interpreted
   r> r> >in !  \ do:-xt is executet when the created word from builder is executed
   also ghosts ' previous swap ! ;  \ for do:-xt an additional entry after the normal ghost-enrys is used
 \  DOES>  dup >exec @ execute ;  
     Make-Ghost            ( Create-xt do-ghost ghost )
 : gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>    rot swap              ( do-ghost Create-xt ghost )
   IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN    >exec ! , ;
   :dodoes T A, H gexecute T here H cell - reloff ;  
   : gdoes,  ( ghost -- )
 : TCreate ( -- )  \ makes the codefield for a word that is built
   last-ghost @    >end @ dup undefined? 0=
   CreateFlag on    IF
   Theader >r dup gdoes,          dup >magic @ <do:> =
   >end @ >exec @ r> >exec ! ;          IF       doer, 
           ELSE    dodoes,
           THEN
           EXIT
     THEN
   \  compile :dodoes gexecute
   \  T here H tcell - reloff 
     2 refered 
     0 fillcfa
     ;
   
   : TCreate ( <name> -- )
     executed-ghost @
     create-forward-warn
     IF ['] reswarn-forward IS resolve-warning THEN
     Theader >r dup , dup gdoes,
   \ stores execution semantic in the built word
   \ if the word already has a semantic (concerns S", IS, .", DOES>)
   \ then keep it
     >end @
     dup >exec @ r@ >exec dup @ ['] NoExec =  IF ! ELSE 2drop THEN
     >comp @ r> >comp ! ;
   
   : RTCreate ( <name> -- )
   \ creates a new word with code-field in ram
     executed-ghost @
     create-forward-warn
     IF ['] reswarn-forward IS resolve-warning THEN
     \ make Alias
     (THeader there 0 T a, H alias-mask flag! ( S executed-ghost new-ghost )
     \ store  poiter to code-field
     switchram T cfalign H
     there swap T ! H
     there tlastcfa ! 
     dup there resolve 0 ;Resolve !
     >r dup gdoes,
   \ stores execution semantic in the built word
   \ if the word already has a semantic (concerns S", IS, .", DOES>)
   \ then keep it
     >end @ >exec @ r> >exec dup @ ['] NoExec =
     IF ! ELSE 2drop THEN ;
   
 : Build:  ( -- [xt] [colon-sys] )  : Build:  ( -- [xt] [colon-sys] )
   :noname  postpone TCreate ;    :noname postpone TCreate ;
   
   : BuildSmart:  ( -- [xt] [colon-sys] )
     :noname
     [ T has? rom H [IF] ]
     postpone RTCreate
     [ [ELSE] ]
     postpone TCreate 
     [ [THEN] ] ;
   
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
   last-ghost @    executed-ghost @
   state @ IF  gexecute true EXIT  THEN    state @ IF  gexecute true EXIT  THEN
   cell+ @ T >body H false ;    g>body false ;
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  \ changed to ?EXIT                                      10may93jaw
   
 : DO:     ( -- addr [xt] [colon-sys] )  : DO:     ( -- ghost [xt] [colon-sys] )
   here ghostheader    here ghostheader
   :noname postpone gdoes> postpone ?EXIT ;    :noname postpone gdoes> postpone ?EXIT ;
   
 : ;DO ( addr [xt] [colon-sys] -- )  : by:     ( -- ghost [xt] [colon-sys] ) \ name
     ghost
     :noname postpone gdoes> postpone ?EXIT ;
   
   : ;DO ( ghost [xt] [colon-sys] -- ghost )
   postpone ;    ( S addr xt )    postpone ;    ( S addr xt )
   over >exec ! ; immediate    over >exec ! ; immediate
   
 : by      ( -- addr ) \ Name  T has? peephole H [IF]
   : compile: ( ghost -- ghost [xt] [colon-sys] )
       :noname  postpone g>body ;
   : ;compile ( ghost [xt] [colon-sys] -- ghost )
       postpone ;  over >comp ! ; immediate
   [ELSE]
   : compile:  ( ghost -- ghost xt colon-sys )  :noname ;
   : ;compile ( ghost xt colon-sys -- ghost )
       postpone ; drop ['] prim-resolved over >comp ! ; immediate
   [THEN]
   
   : by      ( -- ghost ) \ Name
   ghost >end @ ;    ghost >end @ ;
   
 >TARGET  >TARGET
 \ Variables and Constants                              05dec92py  \ Variables and Constants                              05dec92py
   
 Build:  ;  Build:  ( n -- ) ;
 DO: ( ghost -- addr ) ;DO  by: :docon ( ghost -- n ) T @ H ;DO
   compile: alit, compile @ ;compile
   Builder (Constant)
   
   Build:  ( n -- ) T , H ;
   by (Constant)
   Builder Constant
   
   Build:  ( n -- ) T A, H ;
   by (Constant)
   Builder AConstant
   
   Build:  ( d -- ) T , , H ;
   DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
   Builder 2Constant
   
   BuildSmart: ;
   by: :dovar ( ghost -- addr ) ;DO
   \ compile: alit, ;compile
 Builder Create  Builder Create
 by Create :dovar resolve  
   
   T has? rom H [IF]
   Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
   by (Constant)
   Builder Variable
   [ELSE]
 Build: T 0 , H ;  Build: T 0 , H ;
 by Create  by Create
   \ compile: alit, ;compile
 Builder Variable  Builder Variable
   [THEN]
   
   T has? rom H [IF]
   Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;
   by (Constant)
   Builder 2Variable
   [ELSE]
   Build: T 0 , 0 , H ;
   by Create
   \ compile: alit, ;compile
   Builder 2Variable
   [THEN]
   
   T has? rom H [IF]
   Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
   by (Constant)
   Builder AVariable
   [ELSE]
 Build: T 0 A, H ;  Build: T 0 A, H ;
 by Create  by Create
   \ compile: alit, ;compile
 Builder AVariable  Builder AVariable
   [THEN]
   
 \ User variables                                       04may94py  \ User variables                                       04may94py
   
 >CROSS  >CROSS
   
 Variable tup  0 tup !  Variable tup  0 tup !
 Variable tudp 0 tudp !  Variable tudp 0 tudp !
   
 : u,  ( n -- udp )  : u,  ( n -- udp )
   tup @ tudp @ + T  ! H    tup @ tudp @ + T  ! H
   tudp @ dup T cell+ H tudp ! ;    tudp @ dup T cell+ H tudp ! ;
   
 : au, ( n -- udp )  : au, ( n -- udp )
   tup @ tudp @ + T A! H    tup @ tudp @ + T A! H
   tudp @ dup T cell+ H tudp ! ;    tudp @ dup T cell+ H tudp ! ;
   
 >TARGET  >TARGET
   
 Build: T 0 u, , H ;  Build: 0 u, X , ;
 DO: ( ghost -- up-addr )  T @ H tup @ + ;DO  by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO
   compile: compile useraddr T @ , H ;compile
 Builder User  Builder User
 by User :douser resolve  
   
 Build: T 0 u, , 0 u, drop H ;  Build: 0 u, X , 0 u, drop ;
 by User  by User
 Builder 2User  Builder 2User
   
 Build: T 0 au, , H ;  Build: 0 au, X , ;
 by User  by User
 Builder AUser  Builder AUser
   
 Build:  ( n -- ) T , H ;  BuildSmart: T , H ;
 DO: ( ghost -- n ) T @ H ;DO  by (Constant)
 Builder Constant  
 by Constant :docon resolve  
   
 Build:  ( n -- ) T A, H ;  
 by Constant  
 Builder AConstant  
   
 Build:  ( d -- ) T , , H ;  
 DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO  
 Builder 2Constant  
   
 Build: T 0 , H ;  
 by Constant  
 Builder Value  Builder Value
   
 Build:  ( -- ) compile noop ;  BuildSmart: T A, H ;
 DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  by (Constant)
   Builder AValue
   
   BuildSmart:  ( -- ) [T'] noop T A, H ;
   by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
   compile: alit, compile @ compile execute ;compile
 Builder Defer  Builder Defer
 by Defer :dodefer resolve  
   Build: ( inter comp -- ) swap T immediate A, A, H ;
   DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
   Builder interpret/compile:
   
 \ Sturctures                                           23feb95py  \ Sturctures                                           23feb95py
   
Line 707  by Defer :dodefer resolve Line 2231  by Defer :dodefer resolve
  1- tuck +  swap invert and ;   1- tuck +  swap invert and ;
 >TARGET  >TARGET
   
 Build:  >r rot r@ nalign  dup T , H  ( align1 size offset )  Build: ;
         + swap r> nalign ;  by: :dofield T @ H + ;DO
 DO: T @ H + ;DO  compile: T @ H lit, compile + ;compile
   Builder (Field)
   
   Build: ( align1 offset1 align size "name" --  align2 offset2 )
       rot dup T , H ( align1 align size offset1 )
       + >r nalign r> ;
   by (Field)
 Builder Field  Builder Field
 by Field :dofield resolve  
   
 : struct  T 0 1 chars H ;  : struct  T 1 chars 0 H ;
 : end-struct  T 2Constant H ;  : end-struct  T 2Constant H ;
   
 : cells: ( n -- size align )  : cell% ( n -- size align )
     T cells 1 cells H ;      T 1 cells H dup ;
   
 \ ' 2Constant Alias2 end-struct  Build: ( m v -- m' v )  dup T , cell+ H ;
 \ 0 1 T Chars H 2Constant struct  DO:  abort" Not in cross mode" ;DO
   Builder input-method
   
   Build: ( m v size -- m v' )  over T , H + ;
   DO:  abort" Not in cross mode" ;DO
   Builder input-var
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS
 : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;  : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;
 : sys?        ( sys -- sys )    dup 0= ?struc ;  : sys?        ( sys -- sys )    dup 0= ?struc ;
 : >mark       ( -- sys )        T here  0 , H ;  : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;
 : >resolve    ( sys -- )        T here over - swap ! H ;  
 : <resolve    ( sys -- )        T here - , H ;  : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
   
   : >resolve    ( sys -- )        
           X here ( dup ." >" hex. ) over branchoffset swap X ! ;
   
   : <resolve    ( sys -- )
           X here ( dup ." <" hex. ) branchoffset X , ;
   
   :noname compile branch X here branchoffset X , ;
     IS branch, ( target-addr -- )
   :noname compile ?branch X here branchoffset X , ;
     IS ?branch, ( target-addr -- )
   :noname compile branch T here 0 , H ;
     IS branchmark, ( -- branchtoken )
   :noname compile ?branch T here 0 , H ;
     IS ?branchmark, ( -- branchtoken )
   :noname T here 0 , H ;
     IS ?domark, ( -- branchtoken )
   :noname dup X @ ?struc X here over branchoffset swap X ! ;
     IS branchtoresolve, ( branchtoken -- )
   :noname branchto, X here ;
     IS branchtomark, ( -- target-addr )
   
 >TARGET  >TARGET
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
Line 738  Cond: BUT       restrict? sys? swap ;Con Line 2294  Cond: BUT       restrict? sys? swap ;Con
 Cond: YET       restrict? sys? dup ;Cond  Cond: YET       restrict? sys? dup ;Cond
   
 >CROSS  >CROSS
 Variable tleavings  
   Variable tleavings 0 tleavings !
   
   : (done) ( addr -- )
       tleavings @
       BEGIN  dup
       WHILE
           >r dup r@ cell+ @ \ address of branch
           u> 0=      \ lower than DO?     
       WHILE
           r@ 2 cells + @ \ branch token
           branchtoresolve,
           r@ @ r> free throw
       REPEAT  r>  THEN
       tleavings ! drop ;
   
 >TARGET  >TARGET
   
 Cond: DONE   ( addr -- )  restrict? tleavings @  Cond: DONE   ( addr -- )  restrict? (done) ;Cond
       BEGIN  2dup u> 0=  WHILE  dup T @ H swap >resolve REPEAT  
       tleavings ! drop ;Cond  
   
 >CROSS  >CROSS
 : (leave  T here H tleavings @ T , H  tleavings ! ;  : (leave) ( branchtoken -- )
       3 cells allocate throw >r
       T here H r@ cell+ !
       r@ 2 cells + !
       tleavings @ r@ !
       r> tleavings ! ;
 >TARGET  >TARGET
   
 Cond: LEAVE     restrict? compile branch (leave ;Cond  Cond: LEAVE     restrict? branchmark, (leave) ;Cond
 Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond  Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave)  ;Cond
   
   >CROSS
   \ !!JW ToDo : Move to general tools section
   
   : to1 ( x1 x2 xn n -- addr )
   \G packs n stack elements in a allocated memory region
      dup dup 1+ cells allocate throw dup >r swap 1+
      0 DO tuck ! cell+ LOOP
      drop r> ;
   : 1to ( addr -- x1 x2 xn )
   \G unpacks the elements saved by to1
       dup @ swap over cells + swap
       0 DO  dup @ swap 1 cells -  LOOP
       free throw ;
   
   : loop]     branchto, dup <resolve tcell - (done) ;
   
   : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
   
   >TARGET
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 Cond: AHEAD     restrict? compile branch >mark ;Cond  >TARGET
 Cond: IF        restrict? compile ?branch >mark ;Cond  Cond: AHEAD     restrict? branchmark, ;Cond
 Cond: THEN      restrict? sys? dup T @ H ?struc >resolve ;Cond  Cond: IF        restrict? ?branchmark, ;Cond
   Cond: THEN      restrict? sys? branchto, branchtoresolve, ;Cond
 Cond: ELSE      restrict? sys? compile AHEAD swap compile THEN ;Cond  Cond: ELSE      restrict? sys? compile AHEAD swap compile THEN ;Cond
   
 Cond: BEGIN     restrict? T here H ;Cond  Cond: BEGIN     restrict? branchtomark, ;Cond
 Cond: WHILE     restrict? sys? compile IF swap ;Cond  Cond: WHILE     restrict? sys? compile IF swap ;Cond
 Cond: AGAIN     restrict? sys? compile branch <resolve ;Cond  Cond: AGAIN     restrict? sys? branch, ;Cond
 Cond: UNTIL     restrict? sys? compile ?branch <resolve ;Cond  Cond: UNTIL     restrict? sys? ?branch, ;Cond
 Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond  Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond
   
 \ Structural Conditionals                              12dec92py  Cond: CASE      restrict? 0 ;Cond
   Cond: OF        restrict? 1+ >r compile over compile =
 Cond: DO        restrict? compile (do)   T here H ;Cond                  compile IF compile drop r> ;Cond
 Cond: ?DO       restrict? compile (?do)  (leave T here H ;Cond  Cond: ENDOF     restrict? >r compile ELSE r> ;Cond
 Cond: FOR       restrict? compile (for)  T here H ;Cond  Cond: ENDCASE   restrict? compile drop 0 ?DO  compile THEN  LOOP ;Cond
   
 >CROSS  \ Structural Conditionals                              12dec92py
 : loop]   dup <resolve cell - compile DONE compile unloop ;  
 >TARGET  
   
 Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond  :noname \ ?? i think 0 is too much! jaw
 Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond      0 compile (do)
 Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond      branchtomark,  2 to1 ;
     IS do, ( -- target-addr )
   
   \ :noname
   \     compile 2dup compile = compile IF
   \     compile 2drop compile ELSE
   \     compile (do) branchtomark, 2 to1 ;
   \   IS ?do,
       
   :noname
       0 compile (?do)  ?domark, (leave)
       branchtomark,  2 to1 ;
     IS ?do, ( -- target-addr )
   :noname compile (for) branchtomark, ;
     IS for, ( -- target-addr )
   :noname 1to compile (loop)  loop] compile unloop skiploop] ;
     IS loop, ( target-addr -- )
   :noname 1to compile (+loop)  loop] compile unloop skiploop] ;
     IS +loop, ( target-addr -- )
   :noname compile (next)  loop] compile unloop ;
     IS next, ( target-addr -- )
   
   Cond: DO        restrict? do, ;Cond
   Cond: ?DO       restrict? ?do, ;Cond
   Cond: FOR       restrict? for, ;Cond
   
   Cond: LOOP      restrict? sys? loop, ;Cond
   Cond: +LOOP     restrict? sys? +loop, ;Cond
   Cond: NEXT      restrict? sys? next, ;Cond
   
 \ String words                                         23feb93py  \ String words                                         23feb93py
   
 : ,"            [char] " parse string, T align H ;  : ,"            [char] " parse T string, align H ;
   
 Cond: ."        restrict? compile (.")     T ," H ;Cond  Cond: ."        restrict? compile (.")     T ," H ;Cond
 Cond: S"        restrict? compile (S")     T ," H ;Cond  Cond: S"        restrict? compile (S")     T ," H ;Cond
 Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond  Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond
   
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond  Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 : IS            T ' >body ! H ;  : IS            T >address ' >body ! H ;
 Cond: TO        T ' >body H compile ALiteral compile ! ;Cond  Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
 : TO            T ' >body ! H ;  : TO            T ' >body ! H ;
   
   Cond: defers    T ' >body @ compile, H ;Cond
   : on            T -1 swap ! H ; 
   : off           T 0 swap ! H ;
   
 \ LINKED ERR" ENV" 2ENV"                                18may93jaw  \ LINKED ERR" ENV" 2ENV"                                18may93jaw
   
 \ linked list primitive  \ linked list primitive
 : linked        T here over @ A, swap ! H ;  : linked        X here over X @ X A, swap X ! ;
   : chained       T linked A, H ;
   
 : err"   s" ErrLink linked" evaluate T , H  : err"   s" ErrLink linked" evaluate T , H
          [char] " parse string, T align H ;           [char] " parse T string, align H ;
   
 : env"  [char] " parse s" EnvLink linked" evaluate  : env"  [char] " parse s" EnvLink linked" evaluate
         string, T align , H ;          T string, align , H ;
   
 : 2env" [char] " parse s" EnvLink linked" evaluate  : 2env" [char] " parse s" EnvLink linked" evaluate
         here >r string, T align , , H          here >r T string, align , , H
         r> dup T c@ H 80 and swap T c! H ;          r> dup T c@ H 80 and swap T c! H ;
   
 \ compile must be last                                 22feb93py  \ compile must be last                                 22feb93py
Line 814  Cond: compile ( -- ) restrict? \ name Line 2440  Cond: compile ( -- ) restrict? \ name
       0> IF    gexecute        0> IF    gexecute
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) gexecute THEN THEN ;Cond                 ELSE compile (compile) addr, THEN THEN ;Cond
   
 Cond: postpone ( -- ) restrict? \ name  Cond: postpone ( -- ) restrict? \ name
       bl word gfind dup 0= ABORT" CROSS: Can't compile"        bl word gfind dup 0= ABORT" CROSS: Can't compile"
       0> IF    gexecute        0> IF    gexecute
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) gexecute THEN THEN ;Cond                 ELSE compile (compile) addr, THEN THEN ;Cond
              
   \ save-cross                                           17mar93py
   
   hex
   
   >CROSS
   Create magic  s" Gforth2x" here over allot swap move
   
   bigendian 1+ \ strangely, in magic big=0, little=1
   tcell 1 = 0 and or
   tcell 2 = 2 and or
   tcell 4 = 4 and or
   tcell 8 = 6 and or
   tchar 1 = 00 and or
   tchar 2 = 28 and or
   tchar 4 = 50 and or
   tchar 8 = 78 and or
   magic 7 + c!
   
   : save-cross ( "image-name" "binary-name" -- )
     bl parse ." Saving to " 2dup type cr
     w/o bin create-file throw >r
     TNIL IF
         s" #! "           r@ write-file throw
         bl parse          r@ write-file throw
         s"  --image-file" r@ write-file throw
         #lf       r@ emit-file throw
         r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )
         ?do
             bl over emit-file throw
         loop
         drop
         magic 8       r@ write-file throw \ write magic
     ELSE
         bl parse 2drop
     THEN
     image @ there 
     r@ write-file throw \ write image
     TNIL IF
         bit$  @ there 1- tcell>bit rshift 1+
                   r@ write-file throw \ write tags
     THEN
     r> close-file throw ;
   
   : save-region ( addr len -- )
     bl parse w/o bin create-file throw >r
     swap >image swap r@ write-file throw
     r> close-file throw ;
   
   \ \ minimal definitions
              
   >MINIMAL also minimal
   
 >MINIMAL  
 also minimal  
 \ Usefull words                                        13feb93py  \ Usefull words                                        13feb93py
   
 : KB  400 * ;  : KB  400 * ;
   
   \ \ [IF] [ELSE] [THEN] ...                              14sep97jaw
   
   \ it is useful to define our own structures and not to rely
   \ on the words in the compiler
   \ The words in the compiler might be defined with vocabularies
   \ this doesn't work with our self-made compile-loop
   
   Create parsed 20 chars allot    \ store word we parsed
   
   : upcase
       parsed count bounds
       ?DO I c@ toupper I c! LOOP ;
   
   : [ELSE]
       1 BEGIN
           BEGIN bl word count dup WHILE
               comment? 20 umin parsed place upcase parsed count
               2dup s" [IF]" compare 0= >r 
               2dup s" [IFUNDEF]" compare 0= >r
               2dup s" [IFDEF]" compare 0= r> or r> or
               IF   2drop 1+
               ELSE 2dup s" [ELSE]" compare 0=
                   IF   2drop 1- dup
                       IF 1+
                       THEN
                   ELSE
                       2dup s" [ENDIF]" compare 0= >r
                       s" [THEN]" compare 0= r> or
                       IF 1- THEN
                   THEN
               THEN
               ?dup 0= ?EXIT
           REPEAT
           2drop refill 0=
       UNTIL drop ; immediate
     
   : [THEN] ( -- ) ; immediate
   
   : [ENDIF] ( -- ) ; immediate
   
   : [IF] ( flag -- )
       0= IF postpone [ELSE] THEN ; immediate 
   
   Cond: [IF]      postpone [IF] ;Cond
   Cond: [THEN]    postpone [THEN] ;Cond
   Cond: [ELSE]    postpone [ELSE] ;Cond
   
 \ define new [IFDEF] and [IFUNDEF]                      20may93jaw  \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
   
 : there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ;  : defined? tdefined? ;
   : needed? needed? ;
   : doer? doer? ;
   
   \ we want to use IFDEF on compiler directives (e.g. E?) in the source, too
   
 : [IFDEF] there? postpone [IF] ;  : directive? 
 : [IFUNDEF] there? 0= postpone [IF] ;    bl word count [ ' target >wordlist ] literal search-wordlist 
     dup IF nip THEN ;
   
   : [IFDEF]  >in @ directive? swap >in !
              0= IF tdefined? ELSE name 2drop true THEN
              postpone [IF] ;
   
   : [IFUNDEF] tdefined? 0= postpone [IF] ;
   
   Cond: [IFDEF]   postpone [IFDEF] ;Cond
   
   Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
   
 \ C: \- \+ Conditional Compiling                         09jun93jaw  \ C: \- \+ Conditional Compiling                         09jun93jaw
   
 : C: >in @ there? 0=  : C: >in @ tdefined? 0=
      IF    >in ! T : H       IF    >in ! X :
      ELSE drop       ELSE drop
         BEGIN bl word dup c@          BEGIN bl word dup c@
               IF   count comment? s" ;" compare 0= ?EXIT                IF   count comment? s" ;" compare 0= ?EXIT
Line 848  also minimal Line 2586  also minimal
         AGAIN          AGAIN
      THEN ;       THEN ;
   
 also minimal  : d? d? ;
   
 : \- there? IF postpone \ THEN ;  \G doesn't skip line when debug switch is on
 : \+ there? 0= IF postpone \ THEN ;  : \D D? 0= IF postpone \ THEN ;
   
 : [IF]   postpone [IF] ;  \G interprets the line if word is not defined
 : [THEN] postpone [THEN] ;  : \- tdefined? IF postpone \ THEN ;
 : [ELSE] postpone [ELSE] ;  
   
 Cond: [IF]      [IF] ;Cond  
 Cond: [IFDEF]   [IFDEF] ;Cond  
 Cond: [IFUNDEF] [IFUNDEF] ;Cond  
 Cond: [THEN]    [THEN] ;Cond  
 Cond: [ELSE]    [ELSE] ;Cond  
   
 \ save-cross                                           17mar93py  \G interprets the line if word is defined
   : \+ tdefined? 0= IF postpone \ THEN ;
   
 \ i'm not interested in bigforth features this time    10may93jaw  Cond: \- \- ;Cond
 \ [IFDEF] file  Cond: \+ \+ ;Cond
 \ also file  Cond: \D \D ;Cond
 \ [THEN]  
 \ included throw after create-file                     11may93jaw  
   
 bigendian Constant bigendian  : ?? bl word find IF execute ELSE drop 0 THEN ;
   
 Create magic  s" gforth00" here over allot swap move  : needed:
   \G defines ghost for words that we want to be compiled
     BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;
   
 [char] 1 bigendian + cell + magic 7 + c!  \ words that should be in minimal
   
 : save-cross ( "name" -- )  create s-buffer 50 chars allot
   bl parse ." Saving to " 2dup type  
   w/o bin create-file throw >r  
   magic 8       r@ write-file throw \ write magic  
   image @ there r@ write-file throw \ write image  
   bit$  @ there 1- cell>bit rshift 1+  
                 r@ write-file throw \ write tags  
   r> close-file throw ;  
   
 \ words that should be in minimal  bigendian Constant bigendian
   
 : + + ;         : 1- 1- ;  : here there ;
 : - - ;         : 2* 2* ;  : equ constant ;
 : * * ;         : / / ;  : mark there constant ;
 : dup dup ;     : over over ;  
 : swap swap ;   : rot rot ;  \ compiler directives
 : drop drop ;   : =   = ;  : >ram >ram ;
 : lshift lshift ; : 2/ 2/ ;  : >rom >rom ;
   : >auto >auto ;
   : >tempdp >tempdp ;
   : tempdp> tempdp> ;
   : const constflag on ;
   : warnings name 3 = 0= twarnings ! drop ;
   : | ;
   \ : | NoHeaderFlag on ; \ This is broken (damages the last word)
   
   : save-cross save-cross ;
   : save-region save-region ;
   : tdump swap >image swap dump ;
   
   also forth 
   [IFDEF] Label           : Label defempty? Label ; [THEN] 
   [IFDEF] start-macros    : start-macros defempty? start-macros ; [THEN]
   \ [IFDEF] builttag      : builttag builttag ;   [THEN]
   previous
   
   : s" [char] " parse s-buffer place s-buffer count ; \ for environment?
   : + + ;
   : 1+ 1 + ;
   : 2+ 2 + ;
   : 1- 1- ;
   : - - ;
   : and and ;
   : or or ;
   : 2* 2* ;
   : * * ;
   : / / ;
   : dup dup ;
   : over over ;
   : swap swap ;
   : rot rot ;
   : drop drop ;
   : =   = ;
   : 0=   0= ;
   : lshift lshift ;
   : 2/ 2/ ;
 : . . ;  : . . ;
 cell constant cell  
   
 \ include bug5.fs  : all-words    ['] forced?    IS skip? ;
 \ only forth also minimal definitions  : needed-words ['] needed?  IS skip? ;
   : undef-words  ['] defined2? IS skip? ;
 : \  postpone \ ;  : skipdef skipdef ;
 : \G postpone \G ;  
 : (  postpone ( ;  : \  postpone \ ;  immediate
   : \G T-\G ; immediate
   : (  postpone ( ;  immediate
 : include bl word count included ;  : include bl word count included ;
   : require require ;
 : .( [char] ) parse type ;  : .( [char] ) parse type ;
   : ." [char] " parse type ;
 : cr cr ;  : cr cr ;
   
 : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation  : times 0 ?DO dup X c, LOOP drop ; \ used for space table creation
 only forth also minimal definitions  
   \ only forth also cross also minimal definitions order
   
 \ cross-compiler words  \ cross-compiler words
   
 : decimal       decimal ;  : decimal       decimal ;
 : hex           hex ;  : hex           hex ;
   
 : tudp          T tudp H ;  \ : tudp          X tudp ;
 : tup           T tup H ;  minimal  \ : tup           X tup ;
   
   : doc-off       false to-doc ! ;
   : doc-on        true  to-doc ! ;
   
   [IFDEF] dbg : dbg dbg ; [THEN]
   
 \ for debugging...  \ for debugging...
 : order         order ;  : order         order ;
 : words         words ;  : hwords         words ;
   : words         also ghosts words previous ;
 : .s            .s ;  : .s            .s ;
   
 : bye           bye ;  : bye           bye ;
   
   \ dummy
   
   : group  source >in ! drop ;
   
 \ turnkey direction  \ turnkey direction
 : H forth ; immediate  : H forth ; immediate
 : T minimal ; immediate  : T minimal ; immediate
 : G ghosts ; immediate  : G ghosts ; immediate
   
 : turnkey  0 set-order also Target definitions  : turnkey 
            also Minimal also ;     \GFORTH 0 set-order also ghosts
      \ANSI [ ' ghosts >wordlist ] Literal 1 set-order
      also target definitions
      also Minimal also ;
   
 \ these ones are pefered:  \ these ones are pefered:
   
 : lock   turnkey ;  : lock   turnkey ;
 : unlock forth also cross ;  : unlock previous forth also cross ;
   
   \ also minimal
   : [[ also unlock ;
   : ]] previous previous also also ;
   
 unlock definitions also minimal  unlock definitions also minimal
 : lock   lock ;  : lock   lock ;
 lock  lock
   
   \ load cross compiler extension defined in mach file
   
   UNLOCK >CROSS
   
   [IFDEF] extend-cross extend-cross [THEN]
   
   LOCK

Removed from v.1.30  
changed lines
  Added in v.1.100


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>