Diff for /gforth/cross.fs between versions 1.28 and 1.84

version 1.28, 1995/09/06 21:00:11 version 1.84, 2000/05/04 09:31:16
Line 1 Line 1
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ $Id$  
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992-94 by the GNU Forth Development Group  
   
 \ Log:  \ Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
 \       changed in ; [ to state off           12may93jaw  
 \       included place +place                 12may93jaw  
 \       for a created word (variable, constant...)  
 \       is now an alias in the target voabulary.  
 \       this means it is no longer necessary to  
 \       switch between vocabularies for variable  
 \       initialization                        12may93jaw  
 \       discovered error in DOES>  
 \       replaced !does with (;code)           16may93jaw  
 \       made complete redesign and  
 \       introduced two vocs method  
 \       to be asure that the right words  
 \       are found                             08jun93jaw  
 \       btw:  ! works not with 16 bit  
 \             targets                         09jun93jaw  
 \       added: 2user and value                11jun93jaw  
   
 \ include other.fs       \ ansforth extentions for cross  \ This file is part of Gforth.
   
   \ Gforth is free software; you can redistribute it and/or
   \ modify it under the terms of the GNU General Public License
   \ as published by the Free Software Foundation; either version 2
   \ of the License, or (at your option) any later version.
   
   \ This program is distributed in the hope that it will be useful,
   \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   \ GNU General Public License for more details.
   
   \ You should have received a copy of the GNU General Public License
   \ along with this program; if not, write to the Free Software
   \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   
   0 
   [IF]
   
   ToDo:
   Crossdoc destination ./doc/crossdoc.fd makes no sense when
   cross.fs is uses seperately. jaw
   Do we need this char translation with >address and in branchoffset? 
   (>body also affected) jaw
   Clean up mark> and >resolve stuff jaw
   
   [THEN]
   
   hex
   
   \ debugging for compiling
   
   \ 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 ;
   
   : 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 >r -1 >r
     BEGIN dup WHILE
           over c@ pathsep? 
           IF      r@ -1 =
                   IF      r> drop dup >r
                   ELSE    2dup 1 /string 
                           3 min s" ../" compare
                           0=
                           IF      r@ over - ( diff )
                                   2 pick swap - ( dest-adr )
                                   >r 3 /string r> swap 2dup >r >r
                                   move r> r>
                           ELSE    r> drop dup >r
                           THEN
                   THEN
           THEN
           1 /string
     REPEAT 
     r> drop 
     drop r> tuck - ;
   
   : 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>
   
   \ iForth makes only immediate directly after create
   \ make atonce trick! ?
   
   Variable atonce atonce off
   
 Vocabulary Cross  : NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;
 Vocabulary Target  
 Vocabulary Ghosts  
 VOCABULARY Minimal  
 only Forth also Target also also  
 definitions Forth  
   
 : T  previous Cross also Target ; immediate  : GhostHeader <fwd> , 0 , ['] NoExec , ;
 : G  Ghosts ; immediate  
 : H  previous Forth also Cross ; immediate  
   
 forth definitions  : >magic ;              \ type of ghost
   : >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
   : >end 3 cells + ;      \ room for additional tags
                           \ for builder (create, variable...) words the
                           \ execution symantics of words built are placed here
   
   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
   
 : T  previous Cross also Target ; immediate  : Make-Ghost ( "name" -- ghost )
 : G  Ghosts ; immediate    >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 ;
   
 : >cross  also Cross definitions previous ;  \ ghost words                                          14oct92py
 : >target also Target definitions previous ;  \                                          changed:    10may93py/jaw
 : >minimal also Minimal definitions previous ;  
   : 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                                    drop
   ghost over      ghost =         ghost drop      2drop drop
   ghost - 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
   [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
   
   \ \ 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
   
   Variable image
   Variable tlast    TNIL tlast !  \ Last name field
   Variable tlastcfa \ Last code field
   Variable tdoes    \ Resolve does> calls
   Variable bit$
   
   \ 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 targets 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 ;
   
   \ MakeKernal                                                    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 ;
   
 H  : switchrom
     fixed @ ?EXIT rom-dictionary activate ;
   
 >CROSS  : >tempdp ( addr -- ) 
     tdp tempdp-save ! tempdp to tdp tdp ! ;
   : tempdp> ( -- )
     tempdp-save @ to tdp ;
   
 \ Variables                                            06oct92py  : >ram  fixed off (switchram) fixed on ;
   : >rom  fixed off switchrom fixed on ;
   : >auto fixed off switchrom ;
   
 -1 Constant NIL  
 Variable image  
 Variable tlast    NIL tlast !  \ Last name field  
 Variable tlastcfa \ Last code field  
 Variable tdoes    \ Resolve does> calls  
 Variable bit$  
 Variable tdp  
 : there  tdp @ ;  
   
 \ Parameter for target systems                         06oct92py  
   
 included  \ : romstart dup sromdp ! romdp ! ;
   \ : ramstart dup sramdp ! ramdp ! ;
   
 \ Create additional parameters                         19jan95py  \ default compilation goes to rom
   \ when romable support is off, only the rom switch is used (!!)
   >auto
   
 T  : there  tdp @ ;
 cell               Constant tcell  
 cell<<             Constant tcell<<  
 cell>bit           Constant tcell>bit  
 bits/byte          Constant tbits/byte  
 float              Constant tfloat  
 1 bits/byte lshift Constant maxbyte  
 H  
   
 >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 :dostruc  
 -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 ;       DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
    : T@  ( addr -- n )  >r 0 0 r> tcell bounds     : 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 ;
      : 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 170  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 1179  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 ;  : 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
   
   [IFDEF] asm-include asm-include [THEN] hex
   
   previous
   >CROSS H
   
   \ \ --------------------        Compiler Plug Ins               01aug97jaw
   
   \  Compiler States
   
   Variable comp-state
   0 Constant interpreting
   1 Constant compiling
   2 Constant resolving
   3 Constant assembling
   
   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 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 )
   
 \ Ghost Builder                                        06oct92py  [IFUNDEF] ca>native
   defer ca>native 
 \ <T T> new version with temp variable                 10may93jaw  [THEN]
   
 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 , ;  
   
 : >magic ; : >link cell+ ; : >exec cell+ cell+ ;  
 : >end 3 cells + ;  
   
 Variable last-ghost  
 : Make-Ghost ( "name" -- ghost )  
   >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  >TARGET
 \                                          changed:    10may93py/jaw  DEFER >body             \ we need the system >body
                           \ and the target >body
   >CROSS
   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
   
   : (cc) T a, H ;                                 ' (cc) IS colon,
   
   : (cr) >tempdp ]comp colon, 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 colon, ;                                 ' (cm) IS colonmark,
   
 : gfind   ( string -- ghost true/1 / string false )  >TARGET
 \ searches for string in word-list ghosts  : compile, colon, ;
 \ !! wouldn't it be simpler to just use search-wordlist ? ae  >CROSS
   dup count [ ' ghosts >body ] ALiteral search-wordlist  
   dup IF  >r >body nip r>  THEN ;  
   
 VARIABLE Already  \ resolve structure
   
 : ghost   ( "name" -- ghost )  : >next ;               \ link to next field
   Already off  : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address, 2: doer
   >in @  bl word gfind   IF  Already on nip EXIT  THEN  : >taddr cell+ cell+ ;  
   drop  >in !  Make-Ghost ;  : >ghost 3 cells + ;
   : >file 4 cells + ;
   : >line 5 cells + ;
   
   : (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# , 
     ;
   
   : refered ( ghost tag -- )
   \G creates a resolve structure
       T here aligned H swap (refered)
     ;
   
   : 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 ;
   
 : 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 !
       \ 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 -- )  : is-forward   ( ghost -- )
   >link dup @  there rot !  T  A,  H ;    colonmark, 0 (refered) ; \ compile space for call
 : do-resolve   ( ghost -- )  
   >link @                   T  A,  H ;  : is-resolved   ( ghost -- )
     >link @ colon, ; \ compile-call
 : gexecute   ( ghost -- )   dup @  
              <fwd> = IF  do-forward  ELSE  do-resolve  THEN ;  : gexecute   ( ghost -- )
 : ghost,     ghost  gexecute ;    dup @ <fwd> = IF  is-forward  ELSE  is-resolved  THEN ;
   
   : addr,  ( ghost -- )
     dup @ <fwd> = IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;
   
   \ !! : ghost,     ghost  gexecute ;
   
 \ .unresolved                                          11may93jaw  \ .unresolved                                          11may93jaw
   
Line 312  variable ResolveFlag Line 1478  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 327  variable ResolveFlag Line 1507  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
   
Line 341  variable ResolveFlag Line 1530  variable ResolveFlag
 VARIABLE ^imm  VARIABLE ^imm
   
 >TARGET  >TARGET
 : immediate     20 flag!  : immediate     40 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      20 flag! ;
 >CROSS  
   
 \ ALIAS2 ansforth conform alias                          9may93jaw  
   
 : ALIAS2 create here 0 , DOES> @ execute ;  : isdoer        
 \ usage:  \G define a forth word as doer, this makes obviously only sence on
 \ ' <name> alias2 bla !  \G forth processors such as the PSC1000
                   <do:> last-header-ghost @ >magic ! ;
   >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 ;  : name,  ( "name" -- )  bl word count T string, 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  
           tlast @ >image count 1F and 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 399  Create tag-bof 1 c,  0C c, Line 1590  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 414  Create tag-bof 1 c,  0C c, Line 1605  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
       80 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 80 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 473  VARIABLE ;Resolve 1 cells allot Line 1755  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 (;code)   ghost noop                      2drop  
 ghost (.")      ghost (S")      ghost (ABORT")  2drop drop  
 ghost '  
   
 \ compile                                              10may93jaw  \ compile                                              10may93jaw
   
 : compile  ( -- ) \ name  : compile  ( -- ) \ name
Line 497  ghost ' Line 1765  ghost '
   ELSE  postpone literal postpone gexecute  THEN ;    ELSE  postpone literal postpone gexecute  THEN ;
                                         immediate                                          immediate
   
   : [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 gexecute 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 16 and 32 Bit Targets and 32 Bit Hosts!
   
   Cond: MAXU
     restrict? 
     tcell 1 cells u> 
     IF    compile lit tcell 0 ?DO FF T c, H LOOP 
     ELSE  ffffffff lit, THEN
     ;Cond
   
   Cond: MINI
     restrict?
     tcell 1 cells u>
     IF    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
     ELSE  tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN
     ;Cond
    
   Cond: MAXI
    restrict?
    tcell 1 cells u>
    IF     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
    ELSE   tcell 2 = IF 7fff ELSE 7fffffff THEN lit, 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 550  Cond: [Char]   ( "<char>" -- )  restrict Line 1938  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 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> ;
   
 >TARGET  >TARGET
 Cond: DOES> restrict?  Cond: DOES> restrict?
         compile (;code) dodoes, tdoes @ ?dup IF  @ T here H resolve THEN          compile (does>) doeshandler, 
           \ resolve words made by builders
           tdoes @ ?dup IF  @ T here H resolve 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:-xt "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:-xt ghost )
 : gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>    rot swap              ( do:-xt 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 ;  \  rot swap >exec dup @ ['] NoExec <>
   \  IF 2drop ELSE ! THEN , ;
 : TCreate ( -- )  
   last-ghost @  : gdoes,  ( ghost -- )
   CreateFlag on  \ makes the codefield for a word that is built
     >end @ dup undefined? 0=
     IF
           dup >magic @ <do:> =
           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 gdoes,    Theader >r dup gdoes,
   >end @ >exec @ r> >exec ! ;  \ 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 ;
   
   : 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 80 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 ;    >link @ T >body H false ;
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  \ changed to ?EXIT                                      10may93jaw
Line 612  Cond: DOES> restrict? Line 2079  Cond: DOES> restrict?
   here ghostheader    here ghostheader
   :noname postpone gdoes> postpone ?EXIT ;    :noname postpone gdoes> postpone ?EXIT ;
   
 : ;DO ( addr [xt] [colon-sys] -- )  : by:     ( -- addr [xt] [colon-sys] ) \ name
     ghost
     :noname postpone gdoes> postpone ?EXIT ;
   
   : ;DO ( addr [xt] [colon-sys] -- addr )
   postpone ;    ( S addr xt )    postpone ;    ( S addr xt )
   over >exec ! ; immediate    over >exec ! ; immediate
   
Line 622  Cond: DOES> restrict? Line 2093  Cond: DOES> restrict?
 >TARGET  >TARGET
 \ Variables and Constants                              05dec92py  \ Variables and Constants                              05dec92py
   
 Build:  ;  Build:  ( n -- ) ;
 DO: ( ghost -- addr ) ;DO  by: :docon ( ghost -- n ) T @ H ;DO
   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
 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
 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
   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
 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
 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  Builder Value
 by Constant :docon resolve  
   
 Build:  ( n -- ) T A, H ;  
 by Constant  
 Builder AConstant  
   
 Build:  ( d -- ) T , , H ;  BuildSmart: T A, H ;
 DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO  by (Constant)
 Builder 2Constant  Builder AValue
   
 Build: T 0 , H ;  BuildSmart:  ( -- ) [T'] noop T A, H ;
 by Constant  by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 Builder Value  Builder Defer
   
 Build:  ( -- ) compile noop ;  Build: ( inter comp -- ) swap T immediate A, A, H ;
 DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 Builder Defer  Builder interpret/compile:
 by Defer :dodefer resolve  
   
 \ Sturctures                                           23feb95py  \ Sturctures                                           23feb95py
   
Line 691  by Defer :dodefer resolve Line 2196  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  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 :dostruc 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  
 \ 0 1 T Chars H 2Constant struct  
   
 \ 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 722  Cond: BUT       restrict? sys? swap ;Con Line 2250  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 798  Cond: compile ( -- ) restrict? \ name Line 2396  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
   
   : directive? 
     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] ;
   
 : [IFDEF] there? postpone [IF] ;  : [IFUNDEF] tdefined? 0= postpone [IF] ;
 : [IFUNDEF] there? 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 832  also minimal Line 2542  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 ;
   
 \ turnkey direction  \ turnkey direction
Line 915  only forth also minimal definitions Line 2659  only forth also minimal definitions
 : 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.28  
changed lines
  Added in v.1.84


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