Diff for /gforth/cross.fs between versions 1.76 and 1.111

version 1.76, 1999/05/17 13:12:25 version 1.111, 2001/09/06 08:14:16
Line 1 Line 1
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
   
 \ Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 17 Line 17
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
 0   0 
 [IF]  [IF]
   
 ToDo:  ToDo:
 Crossdoc destination ./doc/crossdoc.fd makes no sense when  - Crossdoc destination ./doc/crossdoc.fd makes no sense when
 cross.fs is uses seperately. jaw    cross.fs is used seperately. jaw
 Do we need this char translation with >address and in branchoffset?   - Do we need this char translation with >address and in branchoffset? 
 (>body also affected) jaw    (>body also affected) jaw
 Clean up mark> and >resolve stuff jaw  - MAXU etc. can be done with dlit,
   
 [THEN]  [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 !!  hex     \ the defualt base for the cross-compiler is hex !!
 Warnings off  \ Warnings off
   
 \ words that are generaly useful  \ words that are generaly useful
   
Line 48  Warnings off Line 218  Warnings off
     \ 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 ;
   
   : ," [char] " parse string, ;
   
 : SetValue ( n -- <name> )  : SetValue ( n -- <name> )
 \G Same behaviour as "Value" if the <name> is not defined  \G Same behaviour as "Value" if the <name> is not defined
 \G Same behaviour as "to" if <name> is defined  \G Same behaviour as "to" if <name> is defined
Line 70  Warnings off Line 242  Warnings off
   
 hex  hex
   
 Vocabulary Cross  
 Vocabulary Target  
 Vocabulary Ghosts  
 VOCABULARY Minimal  
 only Forth also Target also also  
 definitions Forth  
   
 : T  previous Cross also Target ; immediate  
 : G  Ghosts ; immediate  
 : H  previous Forth also Cross ; immediate  
   
 forth definitions  
   
 : T  previous Cross also Target ; immediate  
 : G  Ghosts ; immediate  
   
 : >cross  also Cross definitions previous ;  
 : >target also Target definitions previous ;  
 : >minimal also Minimal definitions previous ;  
   
 H  
   
 >CROSS  
   
 \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are  \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are
                         \ for cross-compiling                          \ for cross-compiling
 \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!  \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!
Line 104  H Line 252  H
         ELSE  2dup s" \" compare 0= IF postpone \ THEN          ELSE  2dup s" \" compare 0= IF postpone \ THEN
         THEN ;          THEN ;
   
 \ Begin CROSS COMPILER:  : X     bl word count [ ' target >wordlist ] Literal search-wordlist
           IF      state @ IF compile,
                   ELSE execute THEN
           ELSE    -1 ABORT" Cross: access method not supported!"
 \ \ --------------------        Error Handling                  05aug97jaw          THEN ; immediate
   
 \ 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]  \ Begin CROSS COMPILER:
 : defempty? empty? ;  
 [ELSE]  
 : defempty? ; immediate  
 [THEN]  
   
 \ debugging  \ debugging
   
Line 151  its value is true, the flag is switched Line 271  its value is true, the flag is switched
   
 [THEN]  [THEN]
   
   >CROSS
   
 Vocabulary debugflags   \ debug flags for cross  Vocabulary debugflags   \ debug flags for cross
 also debugflags get-order over  also debugflags get-order over
 Constant debugflags-wl  Constant debugflags-wl
Line 181  set-order previous Line 303  set-order previous
         \ POSTPONE false           \ POSTPONE false 
   THEN ; immediate    THEN ; immediate
   
 \ \ GhostNames Ghosts                                  9may93jaw  \ \ --------------------        source file
   
 \ second name source to search trough list  decimal
   
 VARIABLE GhostNames  Variable cross-file-list
 0 GhostNames !  0 cross-file-list !
   Variable target-file-list
   0 target-file-list !
   Variable host-file-list
   0 host-file-list !
   
 : GhostName ( -- addr )  cross-file-list Value file-list
     here GhostNames @ , GhostNames ! here 0 ,  0 Value source-desc
     bl word count  
     \ 2dup type space  
     string, \ !! cfalign ?  
     align ;  
   
 \ Ghost Builder                                        06oct92py  \ file loading
   
   : >fl-id   1 cells + ;
   : >fl-name 2 cells + ;
   
   Variable filelist 0 filelist !
   Create NoFile ," #load-file#"
   
   : loadfile ( -- adr )
     source-desc ?dup IF >fl-name ELSE NoFile THEN ;
   
   : sourcefilename ( -- adr len ) 
     loadfile count ;
   
   \ANSI : sourceline# 0 ;
   
   \ \ --------------------        path handling from kernel/paths.fs
   
   \ paths.fs path file handling                                    03may97jaw
   
   \ -Changing the search-path:
   \ fpath+ <path>         adds a directory to the searchpath
   \ fpath= <path>|<path>  makes complete now searchpath
   \                       seperator is |
   \ .fpath                displays the search path
   \ remark I: 
   \ a ./ in the beginning of filename is expanded to the directory the
   \ current file comes from. ./ can also be included in the search-path!
   \ ~+/ loads from the current working directory
   
   \ remark II:
   \ if there is no sufficient space for the search path increase it!
   
   
   \ -Creating custom paths:
   
   \ It is possible to use the search mechanism on yourself.
   
   \ Make a buffer for the path:
   \ create mypath 100 chars ,     \ maximum length (is checked)
   \               0 ,             \ real len
   \               100 chars allot \ space for path
   \ use the same functions as above with:
   \ mypath path+ 
   \ mypath path=
   \ mypath .path
   
   \ do a open with the search path:
   \ open-path-file ( adr len path -- fd adr len ior )
   \ the file is opened read-only; if the file is not found an error is generated
   
   \ questions to: wilke@jwdt.com
   
   [IFUNDEF] +place
   : +place ( adr len adr )
           2dup >r >r
           dup c@ char+ + swap move
           r> r> dup c@ rot + swap c! ;
   [THEN]
   
   [IFUNDEF] place
   : place ( c-addr1 u c-addr2 )
           2dup c! char+ swap move ;
   [THEN]
   
   \ if we have path handling, use this and the setup of it
   [IFUNDEF] open-fpath-file
   
   create sourcepath 1024 chars , 0 , 1024 chars allot \ !! make this dynamic
   sourcepath value fpath
   
   : also-path ( adr len path^ -- )
     >r
     \ len check
     r@ cell+ @ over + r@ @ u> ABORT" path buffer too small!"
     \ copy into
     tuck r@ cell+ dup @ cell+ + swap cmove
     \ make delimiter
     0 r@ cell+ dup @ cell+ + 2 pick + c! 1 + r> cell+ +!
     ;
   
   : only-path ( adr len path^ -- )
     dup 0 swap cell+ ! also-path ;
   
   : path+ ( path-addr  "dir" -- ) \ gforth
       \G Add the directory @var{dir} to the search path @var{path-addr}.
       name rot also-path ;
   
   : fpath+ ( "dir" ) \ gforth
       \G Add directory @var{dir} to the Forth search path.
       fpath path+ ;
   
   : path= ( path-addr "dir1|dir2|dir3" ) \ gforth
       \G Make a complete new search path; the path separator is |.
       name 2dup bounds ?DO i c@ [char] | = IF 0 i c! THEN LOOP
       rot only-path ;
   
   : fpath= ( "dir1|dir2|dir3" ) \ gforth
       \G Make a complete new Forth search path; the path separator is |.
       fpath path= ;
   
   : path>counted  cell+ dup cell+ swap @ ;
   
   : next-path ( adr len -- adr2 len2 )
     2dup 0 scan
     dup 0= IF     2drop 0 -rot 0 -rot EXIT THEN
     >r 1+ -rot r@ 1- -rot
     r> - ;
   
   : previous-path ( path^ -- )
     dup path>counted
     BEGIN tuck dup WHILE repeat ;
   
   : .path ( path-addr -- ) \ gforth
       \G Display the contents of the search path @var{path-addr}.
       path>counted
       BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ;
   
   : .fpath ( -- ) \ gforth
       \G Display the contents of the Forth search path.
       fpath .path ;
   
   : absolut-path? ( addr u -- flag ) \ gforth
       \G A path is absolute if it starts with a / or a ~ (~ expansion),
       \G or if it is in the form ./*, extended regexp: ^[/~]|./, or if
       \G it has a colon as second character ("C:...").  Paths simply
       \G containing a / are not absolute!
       2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....
       over c@ [char] / = >r
       over c@ [char] ~ = >r
       \ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic
       2 min S" ./" compare 0=
       r> r> r> or or or ;
   
   Create ofile 0 c, 255 chars allot
   Create tfile 0 c, 255 chars allot
   
   : pathsep? dup [char] / = swap [char] \ = or ;
   
   : need/   ofile dup c@ + c@ pathsep? 0= IF s" /" ofile +place THEN ;
   
   : extractpath ( adr len -- adr len2 )
     BEGIN dup WHILE 1-
           2dup + c@ pathsep? IF EXIT THEN
     REPEAT ;
   
   : remove~+ ( -- )
       ofile count 3 min s" ~+/" compare 0=
       IF
           ofile count 3 /string ofile place
       THEN ;
   
   : expandtopic ( -- ) \ stack effect correct? - anton
       \ expands "./" into an absolute name
       ofile count 2 min s" ./" compare 0=
       IF
           ofile count 1 /string tfile place
           0 ofile c! sourcefilename extractpath ofile place
           ofile c@ IF need/ THEN
           tfile count over c@ pathsep? IF 1 /string THEN
           ofile +place
       THEN ;
   
   : compact.. ( adr len -- adr2 len2 )
       \ deletes phrases like "xy/.." out of our directory name 2dec97jaw
       over swap
       BEGIN  dup  WHILE
           dup >r '/ scan 2dup 4 min s" /../" compare 0=
           IF
               dup r> - >r 4 /string over r> + 4 -
               swap 2dup + >r move dup r> over -
           ELSE
               rdrop dup 1 min /string
           THEN
       REPEAT  drop over - ;
   
   : reworkdir ( -- )
     remove~+
     ofile count compact..
     nip ofile c! ;
   
   : open-ofile ( -- fid ior )
       \G opens the file whose name is in ofile
       expandtopic reworkdir
       ofile count r/o open-file ;
   
   : check-path ( adr1 len1 adr2 len2 -- fd 0 | 0 <>0 )
     0 ofile ! >r >r ofile place need/
     r> r> ofile +place
     open-ofile ;
   
   : open-path-file ( addr1 u1 path-addr -- wfileid addr2 u2 0 | ior ) \ gforth
       \G Look in path @var{path-addr} for the file specified by @var{addr1 u1}.
       \G If found, the resulting path and an open file descriptor
       \G are returned. If the file is not found, @var{ior} is non-zero.
     >r
     2dup absolut-path?
     IF    rdrop
           ofile place open-ofile
           dup 0= IF >r ofile count r> THEN EXIT
     ELSE  r> path>counted
           BEGIN  next-path dup
           WHILE  5 pick 5 pick check-path
           0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN
     REPEAT
           2drop 2drop 2drop -38
     THEN ;
   
   : open-fpath-file ( addr1 u1 -- wfileid addr2 u2 0 | ior ) \ gforth
       \G Look in the Forth search path for the file specified by @var{addr1 u1}.
       \G If found, the resulting path and an open file descriptor
       \G are returned. If the file is not found, @var{ior} is non-zero.
       fpath open-path-file ;
   
   fpath= ~+
   
   [THEN]
   
   \ \ --------------------        include require                 13may99jaw
   
   >CROSS
   
   : add-included-file ( adr len -- adr )
     dup >fl-name char+ allocate throw >r
     file-list @ r@ ! r@ file-list !
     r@ >fl-name place r> ;
   
   : included? ( c-addr u -- f )
     file-list
     BEGIN @ dup
     WHILE >r 2dup r@ >fl-name count compare 0=
           IF rdrop 2drop true EXIT THEN
           r>
     REPEAT
     2drop drop false ;    
   
   false DebugFlag showincludedfiles
   
   : included1 ( fd adr u -- )
   \ include file adr u / fd
   \ we don't use fd with include-file, because the forth system
   \ doesn't know the name of the file to get a nice error report
     [d?] showincludedfiles
     IF    cr ." Including: " 2dup type ." ..." THEN
     rot close-file throw
     source-desc >r
     add-included-file to source-desc 
     sourcefilename
     ['] included catch
     r> to source-desc 
     throw ;
   
   : included ( adr len -- )
           cross-file-list to file-list
           open-fpath-file throw 
           included1 ;
   
   : required ( adr len -- )
           cross-file-list to file-list
           open-fpath-file throw \ 2dup cr ." R:" type
           2dup included?
           IF      2drop close-file throw
           ELSE    included1
           THEN ;
   
   : include bl word count included ;
   
   : require bl word count required ;
   
   0 [IF]
   
 \ <T T> new version with temp variable                 10may93jaw  also forth definitions previous
   
 VARIABLE VocTemp  : included ( adr len -- ) included ;
   
 : <T  get-current VocTemp ! also Ghosts definitions ;  : required ( adr len -- ) required ;
 : T>  previous VocTemp @ set-current ;  
   
   : include include ;
   
   : require require ;
   
   [THEN]
   
   >CROSS
 hex  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]
   
   \ \ --------------------        Compiler Plug Ins               01aug97jaw
   
   >CROSS
   
   \ Compiler States
   
   Variable comp-state
   0 Constant interpreting
   1 Constant compiling
   2 Constant resolving
   3 Constant assembling
   
   : compiling? comp-state @ compiling = ;
   
   : pi-undefined -1 ABORT" Plugin undefined" ;
   
   : Plugin ( -- : pluginname )
     Create 
     \ for normal cross-compiling only one action
     \ exists, this fields are identical. For the instant
     \ simulation environment we need, two actions for each plugin
     \ the target one and the one that generates the simulation code
     ['] pi-undefined , \ action
     ['] pi-undefined , \ target plugin action
     8765 ,     \ plugin magic
     DOES> perform ;
   
   Plugin DummyPlugin
   
   : 'PI ( -- addr : pluginname )
     ' >body dup 2 cells + @ 8765 <> ABORT" not a plugin" ;
   
   : plugin-of ( xt -- : pluginname )
     dup 'PI 2! ;
   
   : action-of ( xt -- : plunginname )
     'PI cell+ ! ;
   
   : TPA ( -- : plugin )
   \ target plugin action
   \ executes current target action of plugin
     'PI cell+ POSTPONE literal POSTPONE perform ; immediate
   
   Variable ppi-temp 0 ppi-temp !
   
   : pa:
   \g define plugin action
     ppi-temp @ ABORT" pa: definition not closed"
     'PI ppi-temp ! :noname ;
   
   : ;pa
   \g end a definition for plugin action
     POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate
   
   
   Plugin dlit, ( d -- )                   \ compile numerical value the target
   Plugin lit, ( n -- )
   Plugin alit, ( n -- )
   
   Plugin branch, ( target-addr -- )       \ compiles a branch
   Plugin ?branch, ( target-addr -- )      \ compiles a ?branch
   Plugin branchmark, ( -- branch-addr )   \ reserves room for a branch
   Plugin ?branchmark, ( -- branch-addr )  \ reserves room for a ?branch
   Plugin ?domark, ( -- branch-addr )      \ reserves room for a ?do branch
   Plugin branchto, ( -- )                 \ actual program position is target of a branch (do e.g. alignment)
   ' NOOP plugin-of branchto, 
   Plugin branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
   Plugin branchtomark, ( -- target-addr ) \ marks a branch destination
   
   Plugin colon, ( tcfa -- )               \ compiles call to tcfa at current position
   Plugin prim, ( tcfa -- )                \ compiles primitive invocation
   Plugin colonmark, ( -- addr )           \ marks a colon call
   Plugin colon-resolve ( tcfa addr -- )
   
   Plugin addr-resolve ( target-addr addr -- )
   Plugin doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
   
   Plugin ncontrols? ( [ xn ... x1 ] n -- ) \ checks wheter n control structures are open
   Plugin if,      ( -- if-token )
   Plugin else,    ( if-token -- if-token )
   Plugin then,    ( if-token -- )
   Plugin ahead,
   Plugin begin,
   Plugin while,
   Plugin until,
   Plugin again,
   Plugin repeat,
   Plugin cs-swap  ( x1 x2 -- x2 x1 )
   
   Plugin case,    ( -- n )
   Plugin of,      ( n -- x1 n )
   Plugin endof,   ( x1 n -- x2 n )
   Plugin endcase, ( x1 .. xn n -- )
   
   Plugin do,      ( -- do-token )
   Plugin ?do,     ( -- ?do-token )
   Plugin for,     ( -- for-token )
   Plugin loop,    ( do-token / ?do-token -- )
   Plugin +loop,   ( do-token / ?do-token -- )
   Plugin next,    ( for-token )
   Plugin leave,   ( -- )
   Plugin ?leave,  ( -- )
   
   [IFUNDEF] ca>native
   Plugin ca>native        
   [THEN]
   
   Plugin doprim,  \ compiles start of a primitive
   Plugin docol,           \ compiles start of a colon definition
   Plugin doer,            
   Plugin fini,      \ compiles end of definition ;s
   Plugin doeshandler,
   Plugin dodoes,
   
   Plugin colon-start
   ' noop plugin-of colon-start
   Plugin colon-end
   ' noop plugin-of colon-end
   
   Plugin ]comp     \ starts compilation
   ' noop plugin-of ]comp
   Plugin comp[     \ ends compilation
   ' noop plugin-of comp[
   
   Plugin t>body             \ we need the system >body
                           \ and the target >body
   
   >TARGET
   : >body t>body ;
   
   
   \ Ghost Builder                                        06oct92py
   
   >CROSS
   hex
   \ Values for ghost magic
 4711 Constant <fwd>             4712 Constant <res>  4711 Constant <fwd>             4712 Constant <res>
 4713 Constant <imm>             4714 Constant <do:>  4713 Constant <imm>             4714 Constant <do:>
 4715 Constant <skip>  4715 Constant <skip>
   
 \ iForth makes only immediate directly after create  \ Bitmask for ghost flags
 \ make atonce trick! ?  1 Constant <unique>
   2 Constant <primitive>
   
   \ FXIME: move this to general stuff?
   : set-flag ( addr flag -- )
     over @ or swap ! ;
   
   : reset-flag ( addr flag -- )
     invert over @ and swap ! ;
   
   : get-flag ( addr flag -- f )
     swap @ and 0<> ;
     
   
   Struct
   
 Variable atonce atonce off    \ link to next ghost (always the first element)
     cell% field >next-ghost
   
 : NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;    \ type of ghost
     cell% field >magic
                   
     \ pointer where ghost is in target, or if unresolved
     \ points to the where we have to resolve (linked-list)
     cell% field >link
   
     \ execution semantics (while target compiling) of ghost
     cell% field >exec
   
     \ compilation action of this ghost; this is what is
     \ done to compile a call (or whatever) to this definition.
     \ E.g. >comp contains the semantic of postpone s"
     \ whereas >exec-compile contains the semantic of s"
     cell% field >comp
   
     \ Compilation sematics (while parsing) of this ghost. E.g. 
     \ "\" will skip the rest of line.
     \ These semantics are defined by Cond: and
     \ if a word is made immediate in instant, then the >exec2 field
     \ gets copied to here
     cell% field >exec-compile
   
     \ Additional execution semantics of this ghost. This is used
     \ for code generated by instant and for the doer-xt of created
     \ words
     cell% field >exec2
   
     cell% field >created
   
     \ the xt of the created ghost word itself
     cell% field >ghost-xt
   
     \ pointer to the counted string of the assiciated
     \ assembler label
     cell% field >asm-name
   
     \ mapped primitives have a special address, so
     \ we are able to detect them
     cell% field >asm-dummyaddr
                           
     \ for builder (create, variable...) words
     \ the execution symantics of words built are placed here
     \ this is a doer ghost or a dummy ghost
     cell% field >do:ghost
   
 : GhostHeader <fwd> , 0 , ['] NoExec , ;    cell% field >ghost-flags
   
 : >magic ;              \ type of ghost    cell% field >ghost-name
 : >link cell+ ;         \ pointer where ghost is in target, or if unresolved  
                         \ points to the where we have to resolve (linked-list)  End-Struct ghost-struct
 : >exec cell+ cell+ ;   \ execution symantics (while target compiling) of ghost  
 : >end 3 cells + ;      \ room for additional tags  Variable ghost-list
                         \ for builder (create, variable...) words the  0 ghost-list !
                         \ execution symantics of words built are placed here  
   
 Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>  Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>
 Variable last-ghost     \ last ghost that is created  \ Variable last-ghost   \ last ghost that is created
 Variable last-header-ghost \ last ghost definitions with header  Variable last-header-ghost \ last ghost definitions with header
   
   \ space for ghosts resolve structure
   \ we create ghosts in a sepearte space
   \ and not to the current host dp, because this
   \ gives trouble with instant while compiling and creating
   \ a ghost for a forward reference
   \ BTW: we cannot allocate another memory region
   \ because allot will check the overflow!!
   Variable cross-space-dp
   Create cross-space 250000 allot here 100 allot align 
   Constant cross-space-end
   cross-space cross-space-dp !
   Variable cross-space-dp-orig
   
   : cross-space-used cross-space-dp @ cross-space - ;
   
   : >space ( -- )
     dp @ cross-space-dp-orig !
     cross-space-dp @ dp ! ;
   
   : space> ( -- )
     dp @ dup cross-space-dp !
     cross-space-end u> ABORT" CROSS: cross-space overflow"
     cross-space-dp-orig @ dp ! ;
   
   \ this is just for debugging, to see this in the backtrace
   : execute-exec execute ;
   : execute-exec2 execute ;
   : execute-exec-compile execute ;
   
   : NoExec
     executed-ghost @ >exec2 @
     ?dup 
     IF   execute-exec2
     ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word"
     THEN ;
   
   Defer is-forward
   
   : (ghostheader) ( -- )
     ghost-list linked <fwd> , 0 , ['] NoExec , ['] is-forward , 
     0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;
   
   : ghostheader ( -- ) (ghostheader) 0 , ;
   
   ' Ghosts >wordlist Constant ghosts-wordlist
   
   \ the current wordlist for ghost definitions in the host
   ghosts-wordlist Value current-ghosts
   
 : Make-Ghost ( "name" -- ghost )  : Make-Ghost ( "name" -- ghost )
   >in @ GhostName swap >in !    >space
   <T Create atonce @ IF immediate atonce off THEN    \ save current and create in ghost vocabulary
   here tuck swap ! ghostheader T>    get-current >r current-ghosts set-current
   dup last-ghost !    >in @ Create >in !
   DOES> dup executed-ghost ! >exec @ execute ;    \ some forth systems like iForth need the immediate directly
     \ after the word is created
     \ restore current
     r> set-current
     here (ghostheader)
     bl word count string, align
     space>
     \ set ghost-xt field by doing a search
     dup >ghost-name count 
     current-ghosts search-wordlist
     0= ABORT" CROSS: Just created, must be there!"
     over >ghost-xt !
     DOES> 
         dup executed-ghost !
         >exec @ execute-exec ;
   
 \ ghost words                                          14oct92py  \ ghost words                                          14oct92py
 \                                          changed:    10may93py/jaw  \                                          changed:    10may93py/jaw
   
 : gfind   ( string -- ghost true/1 / string false )  Defer search-ghosts
   
   : (search-ghosts) ( adr len -- cfa true | 0 )
     current-ghosts search-wordlist ; 
   
     ' (search-ghosts) IS search-ghosts
   
   : gsearch ( addr len -- ghost true | 0 )
     search-ghosts
     dup IF swap >body swap THEN ;
   
   : gfind   ( string -- ghost true / string false )
 \ searches for string in word-list ghosts  \ searches for string in word-list ghosts
   dup count [ ' ghosts >wordlist ] ALiteral search-wordlist    \ dup count type space
   dup IF >r >body nip r>  THEN ;    dup >r count gsearch
     dup IF rdrop ELSE r> swap THEN ;
   
 : gdiscover ( xt -- ghost true | xt false )  : gdiscover ( xt -- ghost true | xt false )
   GhostNames    >r ghost-list
   BEGIN @ dup    BEGIN @ dup
   WHILE 2dup    WHILE dup >magic @ <fwd> <>
         cell+ @ dup >magic @ <fwd> <>          IF dup >link @ r@ =
         >r >link @ = r> and             IF rdrop true EXIT THEN
         IF cell+ @ nip true EXIT THEN          THEN
   REPEAT    REPEAT
   drop false ;    drop r> false ;
   
 VARIABLE Already  : xt>ghost ( xt -- ghost )
     gdiscover 0= ABORT" CROSS: ghost not found for this xt" ;
   
 : ghost   ( "name" -- ghost )  : Ghost   ( "name" -- ghost )
   Already off    >in @ bl word gfind IF  nip EXIT  THEN
   >in @  bl word gfind   IF  atonce off Already on nip EXIT  THEN  
   drop  >in !  Make-Ghost ;    drop  >in !  Make-Ghost ;
   
 : >ghostname ( ghost -- adr len )  : >ghostname ( ghost -- adr len )
   GhostNames    >ghost-name count ;
   BEGIN @ dup  
   WHILE 2dup cell+ @ =  
   UNTIL nip 2 cells + count  
   ELSE  2drop   
         \ true abort" CROSS: Ghostnames inconsistent"  
         s" ?!?!?!"  
   THEN ;  
   
 ' >ghostname ALIAS @name  
   
 : forward? ( ghost -- flag )  : forward? ( ghost -- flag )
   >magic @ <fwd> = ;    >magic @ <fwd> = ;
Line 280  VARIABLE Already Line 970  VARIABLE Already
 : undefined? ( ghost -- flag )  : undefined? ( ghost -- flag )
   >magic @ dup <fwd> = swap <skip> = or ;    >magic @ dup <fwd> = swap <skip> = or ;
   
   : immediate? ( ghost -- flag )
     >magic @ <imm> = ;
   
   Variable TWarnings
   TWarnings on
   Variable Exists-Warnings
   Exists-Warnings on
   
   : exists-warning ( ghost -- ghost )
     TWarnings @ Exists-Warnings @ and
     IF dup >ghostname warnhead type ."  exists " THEN ;
   
   \ : HeaderGhost Ghost ;
   
   Variable reuse-ghosts reuse-ghosts off
   
   : HeaderGhost ( "name" -- ghost )
     >in @ 
     bl word count 
   \  2dup type space
     current-ghosts search-wordlist
     IF  >body dup undefined? reuse-ghosts @ or
         IF   nip EXIT
         ELSE exists-warning 
         THEN
         drop >in ! 
     ELSE >in ! 
     THEN 
     \ we keep the execution semantics of the prviously
     \ defined words, this is a workaround
     \ for the redefined \ until vocs work
     Make-Ghost ;
    
   : .ghost ( ghost -- ) >ghostname type ;
   
   \ ' >ghostname ALIAS @name
   
   : [G'] ( -- ghost : name )
   \G ticks a ghost and returns its address
   \  bl word gfind 0= ABORT" CROSS: Ghost don't exists"
     ghost state @ IF postpone literal THEN ; immediate
   
   : g>xt ( ghost -- xt )
   \G Returns the xt (cfa) of a ghost. Issues a warning if undefined.
     dup undefined? ABORT" CROSS: forward " >link @ ;
      
   : g>body ( ghost -- body )
   \G Returns the body-address (pfa) of a ghost. 
   \G Issues a warning if undefined (a forward-reference).
     g>xt X >body ;
   
   1 Constant <label>
   
   Struct
     \ bitmask of address type (not used for now)
     cell% field addr-type
     \ if this address is an xt, this field points to the ghost
     cell% field addr-xt-ghost
     \ a bit mask that tells as what part of the cell
     \ is refenced from an address pointer, used for assembler generation
     cell% field addr-refs
   End-Struct addr-struct
   
   : %allocerase ( align size -- addr )
     dup >r %alloc dup r> erase ;
   
   \ returns the addr struct, define it if 0 reference
   : define-addr-struct ( addr -- struct-addr )
     dup @ ?dup IF nip EXIT THEN
     addr-struct %allocerase tuck swap ! ;
   
 \ Predefined ghosts                                    12dec92py  \ Predefined ghosts                                    12dec92py
   
 ghost 0=                                        drop  Ghost 0=                                        drop
 ghost branch    ghost ?branch                   2drop  Ghost branch    Ghost ?branch                   2drop
 ghost (do)      ghost (?do)                     2drop  Ghost (do)      Ghost (?do)                     2drop
 ghost (for)                                     drop  Ghost (for)                                     drop
 ghost (loop)    ghost (+loop)                   2drop  Ghost (loop)    Ghost (+loop)                   2drop
 ghost (next)                                    drop  Ghost (next)                                    drop
 ghost unloop    ghost ;S                        2drop  Ghost unloop    Ghost ;S                        2drop
 ghost lit       ghost (compile) ghost !         2drop drop  Ghost lit       Ghost (compile) Ghost !         2drop drop
 ghost (does>)   ghost noop                      2drop  Ghost (does>)   Ghost noop                      2drop
 ghost (.")      ghost (S")      ghost (ABORT")  2drop drop  Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
 ghost '                                         drop  Ghost '                                         drop
 ghost :docol    ghost :doesjump ghost :dodoes   2drop drop  Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
 ghost :dovar                                    drop  Ghost :dovar                                    drop
 ghost over      ghost =         ghost drop      2drop drop  Ghost over      Ghost =         Ghost drop      2drop drop
 ghost - drop  Ghost - drop
 ghost 2drop drop  Ghost 2drop drop
 ghost 2dup drop  Ghost 2dup drop
   
   
   
 \ \ Parameter for target systems                         06oct92py  \ \ Parameter for target systems                         06oct92py
   
   
   >cross
 \ we define it ans like...  \ we define it ans like...
 wordlist Constant target-environment  wordlist Constant target-environment
   
 VARIABLE env-current \ save information of current dictionary to restore with environ>  \ save information of current dictionary to restore with environ>
   Variable env-current 
   
 : >ENVIRON get-current env-current ! target-environment set-current ;  : >ENVIRON get-current env-current ! target-environment set-current ;
 : ENVIRON> env-current @ set-current ;   : ENVIRON> env-current @ set-current ; 
   
 >TARGET  >TARGET
   
 : environment? ( adr len -- [ x ] true | false )  : environment? ( addr len -- [ x ] true | false )
   target-environment search-wordlist   \G returns the content of environment variable and true or
   IF execute true ELSE false THEN ;  \G false if not present
      target-environment search-wordlist 
 : e? bl word count T environment? H 0= ABORT" environment variable not defined!" ;     IF EXECUTE true ELSE false THEN ;
   
 : has?  bl word count T environment? H   : $has? ( addr len -- x | false )
         IF      \ environment variable is present, return its value  \G returns the content of environment variable 
         ELSE    \ environment variable is not present, return false  \G or false if not present
                 false \ debug true ABORT" arg"      T environment? H dup IF drop THEN ;
         THEN ;  
   : e? ( "name" -- x )
   \G returns the content of environment variable. 
   \G The variable is expected to exist. If not, issue an error.
      bl word count T environment? H 
      0= ABORT" environment variable not defined!" ;
   
   : has? ( "name" --- x | false )
   \G returns the content of environment variable 
   \G or false if not present
      bl word count T $has? H ;
   
 : $has? T environment? H IF ELSE false THEN ;  
   
 >ENVIRON get-order get-current swap 1+ set-order  >ENVIRON get-order get-current swap 1+ set-order
 true SetValue compiler  true SetValue compiler
 true  SetValue cross  true SetValue cross
 true SetValue standard-threading  true SetValue standard-threading
 >TARGET previous  >TARGET previous
   
   0
 mach-file count included hex  [IFDEF] mach-file drop mach-file count 1 [THEN]
   [IFDEF] machine-file drop machine-file 1 [THEN]
   [IF]    included hex
   [ELSE]  cr ." No machine description!" ABORT 
   [THEN]
   
 >ENVIRON  >ENVIRON
   
Line 349  false DefaultValue dcomps Line 1128  false DefaultValue dcomps
 false DefaultValue hash  false DefaultValue hash
 false DefaultValue xconds  false DefaultValue xconds
 false DefaultValue header  false DefaultValue header
   false DefaultValue backtrace
   false DefaultValue new-input
   false DefaultValue peephole
 [THEN]  [THEN]
   
 true DefaultValue interpreter  true DefaultValue interpreter
Line 358  true DefaultValue standardthreading Line 1140  true DefaultValue standardthreading
   
 >TARGET  >TARGET
 s" relocate" T environment? H   s" relocate" T environment? H 
 [IF]    SetValue NIL  \ JAW why set NIL to this?!
   [IF]    drop \ SetValue NIL
 [ELSE]  >ENVIRON T NIL H SetValue relocate  [ELSE]  >ENVIRON T NIL H SetValue relocate
 [THEN]  [THEN]
   
Line 383  check-address-unit-bits Line 1166  check-address-unit-bits
 8 Constant bits/byte    \ we define: byte is address-unit  8 Constant bits/byte    \ we define: byte is address-unit
   
 1 bits/byte lshift Constant maxbyte   1 bits/byte lshift Constant maxbyte 
 \ this sets byte size for the target machine, an (probably right guess) jaw  \ this sets byte size for the target machine, (probably right guess) jaw
   
 T  T
 NIL                     Constant TNIL  NIL                     Constant TNIL
Line 401  float              Constant tfloat Line 1184  float              Constant tfloat
 bits/byte               Constant tbits/byte  bits/byte               Constant tbits/byte
 [THEN]  [THEN]
 H  H
 tbits/byte bits/byte /  Constant tbyte  tbits/char bits/byte /  Constant tbyte
   
   
 \ Variables                                            06oct92py  \ Variables                                            06oct92py
Line 409  tbits/byte bits/byte / Constant tbyte Line 1192  tbits/byte bits/byte / Constant tbyte
 Variable image  Variable image
 Variable tlast    TNIL tlast !  \ Last name field  Variable tlast    TNIL tlast !  \ Last name field
 Variable tlastcfa \ Last code field  Variable tlastcfa \ Last code field
 Variable tdoes    \ Resolve does> calls  
 Variable bit$  Variable bit$
   
 \ statistics                                            10jun97jaw  \ statistics                                            10jun97jaw
Line 420  Variable user-vars 0 user-vars ! Line 1202  Variable user-vars 0 user-vars !
 : target>bitmask-size ( u1 -- u2 )  : target>bitmask-size ( u1 -- u2 )
   1- tcell>bit rshift 1+ ;    1- tcell>bit rshift 1+ ;
   
 : allocatetarget ( size --- adr )  : allocatetarget ( size -- adr )
   dup allocate ABORT" CROSS: No memory for target"    dup allocate ABORT" CROSS: No memory for target"
   swap over swap erase ;    swap over swap erase ;
   
Line 433  Variable mirrored-link          \ linked Line 1215  Variable mirrored-link          \ linked
 0 dup mirrored-link ! region-link !  0 dup mirrored-link ! region-link !
   
   
 : >rname 6 cells + ;  : >rname 7 cells + ;
 : >rbm   5 cells + ;  : >rbm   4 cells + ;
 : >rmem  4 cells + ;  : >rmem  5 cells + ;
   : >rtype 6 cells + ;
 : >rlink 3 cells + ;  : >rlink 3 cells + ;
 : >rdp 2 cells + ;  : >rdp 2 cells + ;
 : >rlen cell+ ;  : >rlen cell+ ;
 : >rstart ;  : >rstart ;
   
   
 : region ( addr len -- )                \G create a new region  : region ( addr len -- )                
   \G create a new region
   \ check whether predefined region exists     \ check whether predefined region exists 
   save-input bl word find >r >r restore-input throw r> r> 0=     save-input bl word find >r >r restore-input throw r> r> 0= 
   IF    \ make region    IF    \ make region
Line 450  Variable mirrored-link          \ linked Line 1234  Variable mirrored-link          \ linked
         save-input create restore-input throw          save-input create restore-input throw
         here last-defined-region !          here last-defined-region !
         over ( startaddr ) , ( length ) , ( dp ) ,          over ( startaddr ) , ( length ) , ( dp ) ,
         region-link linked 0 , 0 , bl word count string,          region-link linked 0 , 0 , 0 , bl word count string,
   ELSE  \ store new parameters in region    ELSE  \ store new parameters in region
         bl word drop          bl word drop
         >body >r r@ last-defined-region !          >body >r r@ last-defined-region !
         r@ >rlen ! dup r@ >rstart ! r> >rdp !          r@ >rlen ! dup r@ >rstart ! r> >rdp !
   THEN ;    THEN ;
   
 : borders ( region -- startaddr endaddr ) \G returns lower and upper region border  : borders ( region -- startaddr endaddr ) 
   \G returns lower and upper region border
   dup >rstart @ swap >rlen @ over + ;    dup >rstart @ swap >rlen @ over + ;
   
 : extent  ( region -- startaddr len )   \G returns the really used area  : extent  ( region -- startaddr len )   
   \G returns the really used area
   dup >rstart @ swap >rdp @ over - ;    dup >rstart @ swap >rdp @ over - ;
   
 : area ( region -- startaddr totallen ) \G returns the total area  : area ( region -- startaddr totallen ) 
   dup >rstart swap >rlen @ ;  \G returns the total area
     dup >rstart @ swap >rlen @ ;
   
 : mirrored                              \G mark a region as mirrored  : mirrored                              
   \G mark a region as mirrored
   mirrored-link    mirrored-link
   align linked last-defined-region @ , ;    align linked last-defined-region @ , ;
   
Line 474  Variable mirrored-link          \ linked Line 1262  Variable mirrored-link          \ linked
 \G prints a 16 or 32 Bit nice hex value  \G prints a 16 or 32 Bit nice hex value
   base @ >r hex    base @ >r hex
   tcell 2 u>    tcell 2 u>
   IF s>d <# # # # # '. hold # # # # #> type    IF s>d <# # # # # [char] . hold # # # # #> type
   ELSE s>d <# # # # # # #> type    ELSE s>d <# # # # # # #> type
   THEN r> base ! ;    THEN r> base ! space ;
   
 : .regions                      \G display region statistic  : .regions                      \G display region statistic
   
Line 526  T has? rom H Line 1314  T has? rom H
 ' dictionary ALIAS rom-dictionary  ' dictionary ALIAS rom-dictionary
   
   
 : setup-target ( -- )   \G initialize targets memory space  : setup-target ( -- )   \G initialize target's memory space
   s" rom" T $has? H    s" rom" T $has? H
   IF  \ check for ram and rom...    IF  \ check for ram and rom...
       \ address-space area nip 0<>        \ address-space area nip 0<>
Line 551  T has? rom H Line 1339  T has? rom H
         0 >rlink - >r          0 >rlink - >r
         r@ >rlen @          r@ >rlen @
         IF      \ allocate mem          IF      \ allocate mem
                 r@ >rlen @ dup                  r@ >rlen @ allocatetarget dup image !
   
                 allocatetarget dup image !  
                 r@ >rmem !                  r@ >rmem !
   
                   r@ >rlen @
                 target>bitmask-size allocatetarget                  target>bitmask-size allocatetarget
                 dup bit$ !                  dup bit$ !
                 r> >rbm !                  r@ >rbm !
   
                   r@ >rlen @
                   tcell / 1+ cells allocatetarget r@ >rtype !
   
                   rdrop
         ELSE    r> drop THEN          ELSE    r> drop THEN
    REPEAT drop ;     REPEAT drop ;
   
 \ MakeKernal                                                    22feb99jaw  \ MakeKernel                                                    22feb99jaw
   
 : makekernel ( targetsize -- targetsize )  : makekernel ( targetsize -- targetsize )
   dup dictionary >rlen ! setup-target ;    dup dictionary >rlen ! setup-target ;
Line 663  variable constflag constflag off Line 1454  variable constflag constflag off
   
 bigendian  bigendian
 [IF]  [IF]
    : S!  ( n addr -- )  >r s>d r> tcell bounds swap 1-     : DS!  ( d addr -- )  tcell bounds swap 1-
      DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
    : S@  ( addr -- n )  >r 0 0 r> tcell bounds     : DS@  ( addr -- d )  >r 0 0 r> tcell 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 ;
    : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-     : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-
      DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
    : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds     : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
 [ELSE]  [ELSE]
    : S!  ( n addr -- )  >r s>d r> tcell bounds     : DS!  ( d addr -- )  tcell bounds
      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
    : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-     : DS@  ( addr -- n )  >r 0 0 r> tcell 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 ;
    : Sc!  ( n addr -- )  >r s>d r> tchar bounds     : Sc!  ( n addr -- )  >r s>d r> tchar bounds
      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
    : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds swap 1-     : 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]
   
   : S! ( n addr -- ) >r s>d r> DS! ;
   : S@ ( addr -- n ) DS@ d>s ;
   
 : taddr>region ( taddr -- region | 0 )  : taddr>region ( taddr -- region | 0 )
 \G finds for a target-address the correct region  \G finds for a target-address the correct region
 \G returns 0 if taddr is not in range of a target memory region  \G returns 0 if taddr is not in range of a target memory region
Line 698  bigendian Line 1492  bigendian
   REPEAT    REPEAT
   2drop 0 ;    2drop 0 ;
   
   : taddr>region-abort ( taddr -- region | 0 )
     dup taddr>region dup 0= 
     IF    drop cr ." Wrong address: " .addr
           -1 ABORT" Address out of range!"
     THEN nip ;
   
 : (>regionimage) ( taddr -- 'taddr )  : (>regionimage) ( taddr -- 'taddr )
   dup    dup
   \ find region we want to address    \ find region we want to address
   taddr>region dup 0= ABORT" Address out of range!"    taddr>region-abort
   >r    >r
   \ calculate offset in region    \ calculate offset in region
   r@ >rstart @ -    r@ >rstart @ -
   \ add regions real address in our memory    \ add regions real address in our memory
   r> >rmem @ + ;    r> >rmem @ + ;
   
   : (>regionbm) ( taddr -- 'taddr bitmaskbaseaddr )
     dup
     \ find region we want to address
     taddr>region-abort
     >r
     \ calculate offset in region
     r@ >rstart @ -
     \ add regions real address in our memory
     r> >rbm @ ;
   
   : (>regiontype) ( taddr -- 'taddr )
     dup
     \ find region we want to address
     taddr>region-abort
     >r
     \ calculate offset in region
     r@ >rstart @ - tcell / cells
     \ add regions real address in our memory
     r> >rtype @ + ;
     
 \ 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 717  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 1537  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : +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 ;  : @relbit ( taddr -- f ) (>regionbm) swap cell/ >bit swap c@ and ;
 : (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] ]
     (>regionbm) 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] ]
     (>regionbm) swap cell/ -bit ;
   
 : (>image) ( taddr -- absaddr ) image @ + ;  : (>image) ( taddr -- absaddr ) image @ + ;
   
Line 731  T has? relocate H Line 1564  T has? relocate H
 [IF]  [IF]
 ' (relon) IS relon  ' (relon) IS relon
 ' (reloff) IS reloff  ' (reloff) IS reloff
 ' (>image) IS >image  ' (>regionimage) IS >image
 [ELSE]  [ELSE]
 ' drop IS relon  ' drop IS relon
 ' drop IS reloff  ' drop IS reloff
Line 759  T has? relocate H Line 1592  T has? relocate H
 : c@ ( taddr -- char )  >image Sc@ ;  : c@ ( taddr -- char )  >image Sc@ ;
 : c! ( char taddr -- )  >image Sc! ;  : c! ( char taddr -- )  >image Sc! ;
 : 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 tcell T allot  ! H T here drop H ;  : ,     ( w -- )        T here H tcell T allot  ! H ;
 : c,    ( char -- )     T here    tchar allot c! H ;  : c,    ( char -- )     T here H tchar T allot c! H ;
 : align ( -- )          T here H align+ 0 ?DO  bl T c, tchar 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, tchar H +LOOP ;      T here H cfalign+ 0 ?DO  bl T c, H tchar +LOOP ;
   
 : >address              dup 0>= IF tbyte / THEN ; \ ?? jaw   : >address              dup 0>= IF tbyte / THEN ; \ ?? jaw 
 : A!                    swap >address swap dup relon T ! H ;  : A!                    swap >address swap dup relon T ! H ;
 : A,    ( w -- )        >address T here H relon T , H ;  : A,    ( w -- )        >address T here H relon T , H ;
   
   
   \ \ --------------------        Host/Target copy etc.           29aug01jaw
   
   
 >CROSS  >CROSS
   
   : TD! >image DS! ;
   : TD@ >image DS@ ;
   
   : th-count ( taddr -- host-addr len )
   \G returns host address of target string
     assert1( tbyte 1 = )
     dup X c@ swap X char+ >image swap ;
   
   : ht-move ( haddr taddr len -- )
   \G moves data from host-addr to destination in target-addr
   \G character by character
     swap -rot bounds ?DO I c@ over X c! X char+ LOOP drop ;
   
   2Variable last-string
   
   : ht-string,  ( addr count -- )
     dup there swap last-string 2!
     dup T c, H bounds  ?DO  I c@ T c, H  LOOP ; 
   
   >TARGET
   
   : count dup X c@ swap X char+ swap ;
   
   : on            -1 -1 rot TD!  ; 
   : off           T 0 swap ! H ;
   
 : tcmove ( source dest len -- )  : tcmove ( source dest len -- )
 \G cmove in target memory  \G cmove in target memory
   tchar * bounds    tchar * bounds
   ?DO  dup T c@ H I T c! H 1+    ?DO  dup T c@ H I T c! H 1+
   tchar +LOOP  drop ;    tchar +LOOP  drop ;
   
   : td, ( d -- )
   \G Store a host value as one cell into the target
     there tcell X allot TD! ;
   
 \ \ Load Assembler  \ \ Load Assembler
   
 >TARGET  >TARGET
 H also Forth definitions  H also Forth definitions
   
 : X     also target bl word find  \ FIXME: should we include the assembler really in the forth 
         IF      state @ IF compile,  \ dictionary?!?!?!? This conflicts with the existing assembler 
                 ELSE execute THEN  \ of the host forth system!!
         ELSE    previous ABORT" Cross: access method not supported!"  
         THEN   
         previous ; immediate  
   
 [IFDEF] asm-include asm-include [THEN] hex  [IFDEF] asm-include asm-include [THEN] hex
   
 previous  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 )  
   
 [IFUNDEF] ca>native  
 defer ca>native   
 [THEN]  
   
 >TARGET  
 DEFER >body             \ we need the system >body  
                         \ and the target >body  
 >CROSS  >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  : (cc) T a, H ;                                 ' (cc) plugin-of colon,
 DEFER comp[     \ ends compilation  : (prim) T a, H ;                               ' (prim) plugin-of prim,
   
 : (cc) T a, H ;                                 ' (cc) IS colon,  : (cr) >tempdp ]comp prim, comp[ tempdp> ;      ' (cr) plugin-of colon-resolve
   : (ar) T ! H ;                                  ' (ar) plugin-of addr-resolve
 : (cr) >tempdp ]comp colon, comp[ tempdp> ;     ' (cr) IS colon-resolve  
 : (ar) T ! H ;                                  ' (ar) IS addr-resolve  
 : (dr)  ( ghost res-pnt target-addr addr )  : (dr)  ( ghost res-pnt target-addr addr )
         >tempdp drop over           >tempdp drop over 
         dup >magic @ <do:> =          dup >magic @ <do:> =
         IF      doer,          IF      doer,
         ELSE    dodoes,          ELSE    dodoes,
         THEN           THEN 
         tempdp> ;                               ' (dr) IS doer-resolve          tempdp> ;                               ' (dr) plugin-of doer-resolve
   
 : (cm) ( -- addr )  : (cm) ( -- addr )
     T here align H      T here align H
     -1 colon, ;                                 ' (cm) IS colonmark,      -1 prim, ;                                  ' (cm) plugin-of colonmark,
   
 >TARGET  >TARGET
 : compile, colon, ;  : compile, ( xt -- )
     dup xt>ghost >comp @ EXECUTE ;
 >CROSS  >CROSS
   
 \ file loading  
   
 : >fl-id   1 cells + ;  
 : >fl-name 2 cells + ;  
   
 Variable filelist 0 filelist !  
 Create NoFile ," #load-file#"  
 0 Value  filemem  
 : loadfile  FileMem ?dup IF >fl-name ELSE NoFile THEN ;  
   
 1 [IF] \ !! JAW WIP  
   
 : add-included-file ( adr len -- )  
         dup char+ >fl-name allocate throw >r  
         r@ >fl-name place  
         filelist @ r@ !  
         r> dup filelist ! to FileMem  
         ;  
   
 : included? ( c-addr u -- f )  
         filelist  
         BEGIN   @ dup  
         WHILE   >r r@ 1 cells + count compare 0=  
                 IF rdrop 2drop true EXIT THEN  
                 r>  
         REPEAT  
         2drop drop false ;        
   
 false DebugFlag showincludedfiles  
   
 : included   
         [d?] showincludedfiles  
         IF      cr ." Including: " 2dup type ." ..." THEN  
         FileMem >r  
         2dup add-included-file included   
         r> to FileMem ;  
   
 : include bl word count included ;  
   
 : require bl word count included ;  
   
 [THEN]  
   
 \ resolve structure  \ resolve structure
   
 : >next ;               \ link to next field  : >next ;               \ link to next field
Line 931  false DebugFlag showincludedfiles Line 1699  false DebugFlag showincludedfiles
   
 : (refered) ( ghost addr tag -- )  : (refered) ( ghost addr tag -- )
 \G creates a reference to ghost at address taddr  \G creates a reference to ghost at address taddr
     rot >r here r@ >link @ , r> >link !       >space
       rot >link linked
     ( taddr tag ) ,      ( taddr tag ) ,
     ( taddr ) ,       ( taddr ) , 
     last-header-ghost @ ,       last-header-ghost @ , 
     loadfile ,       loadfile , 
     sourceline# ,       sourceline# , 
       space>
   ;    ;
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
Line 959  false DebugFlag showincludedfiles Line 1729  false DebugFlag showincludedfiles
 Defer resolve-warning  Defer resolve-warning
   
 : reswarn-test ( ghost res-struct -- ghost res-struct )  : reswarn-test ( ghost res-struct -- ghost res-struct )
   over cr ." Resolving " >ghostname type dup ."  in " >ghost @ >ghostname type ;    over cr ." Resolving " .ghost dup ."  in " >ghost @ .ghost ;
   
 : reswarn-forward ( ghost res-struct -- ghost res-struct )  : reswarn-forward ( ghost res-struct -- ghost res-struct )
   over warnhead >ghostname type dup ."  is referenced in "     over warnhead .ghost dup ."  is referenced in " 
   >ghost @ >ghostname type ;    >ghost @ .ghost ;
   
 \ ' reswarn-test IS resolve-warning  \ ' reswarn-test IS resolve-warning
     
Line 990  Defer resolve-warning Line 1760  Defer resolve-warning
   
 \ exists                                                9may93jaw  \ exists                                                9may93jaw
   
 Variable TWarnings  
 TWarnings on  
 Variable Exists-Warnings  
 Exists-Warnings on  
   
 : exists ( ghost tcfa -- )  : exists ( ghost tcfa -- )
   over GhostNames  \G print warning and set new target link in ghost
   BEGIN @ dup    swap exists-warning
   WHILE 2dup cell+ @ =    >link ! ;
   UNTIL  
         2 cells + count  : colon-resolved   ( ghost -- )
         TWarnings @ Exists-Warnings @ and      >link @ colon, ; \ compile-call
         IF warnhead type ."  exists"  
         ELSE 2drop THEN  : prim-resolved  ( ghost -- )
         drop swap >link !      >link @ prim, ;
   ELSE  true abort" CROSS: Ghostnames inconsistent "  
   THEN ;  \ FIXME: not used currently
   : does-resolved ( ghost -- )
       dup g>body alit, >do:ghost @ g>body colon, ;
   
   : (is-forward)   ( ghost -- )
     colonmark, 0 (refered) ; \ compile space for call
   ' (is-forward) IS is-forward
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
 \G resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
     \ is ghost resolved?, second resolve means another definition with the      dup taddr>region 0<> IF
     \ same name        2dup (>regiontype) define-addr-struct addr-xt-ghost 
   
         \ we define new address only if empty
         \ this is for not to take over the alias ghost
         \ (different ghost, but identical xt)
         \ but the very first that really defines it
         dup @ 0= IF ! ELSE 2drop THEN
       THEN
   
       \ is ghost resolved?, second resolve means another 
       \ definition with the same name
     over undefined? 0= IF  exists EXIT THEN      over undefined? 0= IF  exists EXIT THEN
     \ get linked-list      \ get linked-list
     swap >r r@ >link @ swap \ ( list tcfa R: ghost )      swap >r r@ >link @ swap \ ( list tcfa R: ghost )
     \ mark ghost as resolved      \ mark ghost as resolved
     dup r@ >link ! <res> r@ >magic !      dup r@ >link ! <res> r@ >magic !
       r@ >comp @ ['] is-forward = IF
           ['] prim-resolved  r@ >comp !  THEN
     \ loop through forward referencies      \ loop through forward referencies
     r> -rot       r> -rot 
     comp-state @ >r Resolving comp-state !      comp-state @ >r Resolving comp-state !
Line 1028  Exists-Warnings on Line 1811  Exists-Warnings on
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
 : is-forward   ( ghost -- )  : (gexecute)   ( ghost -- )
   colonmark, 0 (refered) ; \ compile space for call    dup >comp @ EXECUTE ;
   
 : is-resolved   ( ghost -- )  : gexecute ( ghost -- )
   >link @ colon, ; \ compile-call    dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN
     (gexecute) ;
 : gexecute   ( ghost -- )  
   dup @ <fwd> = IF  is-forward  ELSE  is-resolved  THEN ;  
   
 : addr,  ( ghost -- )  : addr,  ( ghost -- )
   dup @ <fwd> = IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;    dup forward? IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;
   
 \ !! : ghost,     ghost  gexecute ;  
   
 \ .unresolved                                          11may93jaw  \ .unresolved                                          11may93jaw
   
Line 1052  variable ResolveFlag Line 1831  variable ResolveFlag
                                0 <> and ;                                 0 <> and ;
   
 : .forwarddefs ( ghost -- )  : .forwarddefs ( ghost -- )
         ."  appeared in:"    ."  appeared in:"
         >link    >link
         BEGIN   @ dup    BEGIN @ dup
         WHILE   cr 5 spaces    WHILE cr 5 spaces
                 dup >ghost @ >ghostname type          dup >ghost @ .ghost
                 ."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN          ."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN
                 ."  line " dup >line @ .dec          ."  line " dup >line @ .dec
         REPEAT     REPEAT 
         drop ;    drop ;
   
 : ?resolved  ( ghostname -- )  : ?resolved  ( ghost -- )
   dup cell+ @ ?touched    dup ?touched
   IF    dup     IF    ResolveFlag on 
         cell+ cell+ count cr type ResolveFlag on           dup cr .ghost .forwarddefs
         cell+ @ .forwarddefs  
   ELSE  drop     ELSE  drop 
   THEN ;    THEN ;
   
 >MINIMAL  
 : .unresolved  ( -- )  : .unresolved  ( -- )
   ResolveFlag off cr ." Unresolved: "    ResolveFlag off cr ." Unresolved: "
   Ghostnames    ghost-list
   BEGIN @ dup    BEGIN @ dup
   WHILE dup ?resolved    WHILE dup ?resolved
   REPEAT drop ResolveFlag @    REPEAT drop ResolveFlag @
Line 1089  variable ResolveFlag Line 1866  variable ResolveFlag
   cr ." named Headers: " headers-named @ .     cr ." named Headers: " headers-named @ . 
   r> base ! ;    r> base ! ;
   
   >MINIMAL
   
   : .unresolved .unresolved ;
   
 >CROSS  >CROSS
 \ Header states                                        12dec92py  \ Header states                                        12dec92py
   
 : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;  \ : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;
   bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+
   : flag! ( w -- )   tlast @ flag+ + dup >r T c@ xor r> c! H ;
   
 VARIABLE ^imm  VARIABLE ^imm
   
   \ !! should be target wordsize specific
   $80 constant alias-mask
   $40 constant immediate-mask
   $20 constant restrict-mask
   
 >TARGET  >TARGET
 : immediate     40 flag!  : immediate     immediate-mask flag!
                 ^imm @ @ dup <imm> = IF  drop  EXIT  THEN                  ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
                 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"                  <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                 <imm> ^imm @ ! ;                  <imm> ^imm @ ! ;
 : restrict      20 flag! ;  : restrict      restrict-mask flag! ;
   
 : isdoer          : isdoer        
 \G define a forth word as doer, this makes obviously only sence on  \G define a forth word as doer, this makes obviously only sence on
Line 1109  VARIABLE ^imm Line 1897  VARIABLE ^imm
                 <do:> last-header-ghost @ >magic ! ;                  <do:> last-header-ghost @ >magic ! ;
 >CROSS  >CROSS
   
 \ ALIAS2 ansforth conform alias                          9may93jaw  
   
 : ALIAS2 create here 0 , DOES> @ execute ;  
 \ usage:  
 \ ' <name> alias2 bla !  
   
 \ Target Header Creation                               01nov92py  \ Target Header Creation                               01nov92py
   
   : ht-lstring, ( addr count -- )
     dup T , H bounds  ?DO  I c@ T c, H  LOOP ;
   
 >TARGET  >TARGET
 : string,  ( addr count -- )  : name,  ( "name" -- )  bl word count ht-lstring, X cfalign ;
   dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;   
 : name,  ( "name" -- )  bl word count T string, cfalign H ;  
 : view,   ( -- ) ( dummy ) ;  : view,   ( -- ) ( dummy ) ;
 >CROSS  >CROSS
   
Line 1140  Variable to-doc  to-doc on Line 1923  Variable to-doc  to-doc on
     IF      IF
         s" " doc-file-id write-line throw          s" " doc-file-id write-line throw
         s" make-doc " doc-file-id write-file throw          s" make-doc " doc-file-id write-file throw
         tlast @ >image count $1F and doc-file-id write-file throw  
           Last-Header-Ghost @ >ghostname doc-file-id write-file throw
         >in @          >in @
         [char] ( parse 2drop          [char] ( parse 2drop
         [char] ) parse doc-file-id write-file throw          [char] ) parse doc-file-id write-file throw
Line 1162  Create tag-bof 1 c,  0C c, Line 1946  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
         sourcefilename 2dup          sourcefilename 2dup
Line 1177  Create tag-bof 1 c,  0C c, Line 1961  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 sourceline# 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
Line 1189  Create tag-bof 1 c,  0C c, Line 1973  Create tag-bof 1 c,  0C c,
   
 Defer skip? ' false IS skip?  Defer skip? ' false IS skip?
   
 : skipdef ( <name> -- )  : skipdef ( "name" -- )
 \G skip definition of an undefined word in undef-words mode  \G skip definition of an undefined word in undef-words and
     ghost dup forward?  \G all-words mode
       Ghost dup forward?
     IF  >magic <skip> swap !      IF  >magic <skip> swap !
     ELSE drop THEN ;      ELSE drop THEN ;
   
 : defined? ( -- flag ) \ name  : tdefined? ( "name" -- flag ) 
     ghost undefined? 0= ;      Ghost undefined? 0= ;
   
 : defined2? ( -- flag ) \ name  : defined2? ( "name" -- flag ) 
 \G return true for anything else than forward, even for <skip>  \G return true for anything else than forward, even for <skip>
 \G that's what we want  \G that's what we want
     ghost forward? 0= ;      Ghost forward? 0= ;
   
   : forced? ( "name" -- flag )
   \G return ture if it is a foreced skip with defskip
       Ghost >magic @ <skip> = ;
   
 : needed? ( -- flag ) \ name  : needed? ( -- flag ) \ name
 \G returns a false flag when  \G returns a false flag when
Line 1215  Defer skip? ' false IS skip? Line 2004  Defer skip? ' false IS skip?
     ELSE  drop true  THEN ;      ELSE  drop true  THEN ;
   
 : doer? ( -- flag ) \ name  : doer? ( -- flag ) \ name
     ghost >magic @ <do:> = ;      Ghost >magic @ <do:> = ;
   
 : skip-defs ( -- )  : skip-defs ( -- )
     BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;      BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;
   
 \ Target header creation  \ Target header creation
   
 Variable CreateFlag  
 CreateFlag off  
   
 Variable NoHeaderFlag  Variable NoHeaderFlag
 NoHeaderFlag off  NoHeaderFlag off
   
Line 1232  NoHeaderFlag off Line 2018  NoHeaderFlag off
     base @ >r hex       base @ >r hex 
     0 swap <# 0 ?DO # LOOP #> type       0 swap <# 0 ?DO # LOOP #> type 
     r> base ! ;      r> base ! ;
 : .sym  
   : .sym ( adr len -- )
   \G escapes / and \ to produce sed output
   bounds     bounds 
   DO I c@ dup    DO I c@ dup
         CASE    '/ OF drop ." \/" ENDOF          CASE    [char] / OF drop ." \/" ENDOF
                 '\ OF drop ." \\" ENDOF                  [char] \ OF drop ." \\" ENDOF
                 dup OF emit ENDOF                  dup OF emit ENDOF
         ENDCASE          ENDCASE
     LOOP ;      LOOP ;
   
 : (Theader ( "name" -- ghost )  Defer setup-execution-semantics
   0 Value lastghost
   
   : (THeader ( "name" -- ghost )
     \  >in @ bl word count type 2 spaces >in !      \  >in @ bl word count type 2 spaces >in !
     \ wordheaders will always be compiled to rom      \ wordheaders will always be compiled to rom
     switchrom      switchrom
Line 1250  NoHeaderFlag off Line 2041  NoHeaderFlag off
     IF  NoHeaderFlag off      IF  NoHeaderFlag off
     ELSE      ELSE
         T align H view,          T align H view,
         tlast @ dup 0> IF  T 1 cells - H THEN T A, H  there tlast !          tlast @ dup 0> IF tcell - THEN T A, H  there tlast !
         1 headers-named +!      \ Statistic          1 headers-named +!      \ Statistic
         >in @ T name, H >in !          >in @ T name, H >in !
     THEN      THEN
     T cfalign here H tlastcfa !      T cfalign here H tlastcfa !
     \ Symbol table      \ Old Symbol table sed-script
 \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !  \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
     CreateFlag @      HeaderGhost
     IF  \ for a created word we need also a definition in target      \ output symbol table to extra file
         \ to execute the created word while compile time      [ [IFDEF] fd-symbol-table ]
         \ dont mind if a alias is defined twice        base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !
         Warnings @ >r Warnings off        s" :" fd-symbol-table write-file throw
         >in @ alias2 swap >in !         \ create alias in target        dup >ghostname fd-symbol-table write-line throw
         r> Warnings !      [ [THEN] ]
         >in @ ghost swap >in !      dup Last-Header-Ghost ! dup to lastghost
         swap also ghosts ' previous swap !     \ tick ghost and store in alias  
         CreateFlag off  
     ELSE ghost  
     THEN  
     dup Last-Header-Ghost !  
     dup >magic ^imm !     \ a pointer for immediate      dup >magic ^imm !     \ a pointer for immediate
     Already @      alias-mask flag!
     IF  dup >end tdoes !      cross-doc-entry cross-tag-entry 
     ELSE 0 tdoes !      setup-execution-semantics
     THEN      ;
     80 flag!  
     cross-doc-entry cross-tag-entry ;  
   
 VARIABLE ;Resolve 1 cells allot  
 \ this is the resolver information from ":"  \ this is the resolver information from ":"
 \ resolving is done by ";"  \ resolving is done by ";"
   Variable ;Resolve 1 cells allot
   
   : hereresolve ( ghost -- )
     there resolve 0 ;Resolve ! ;
   
 : Theader  ( "name" -- ghost )  : Theader  ( "name" -- ghost )
   (THeader dup there resolve 0 ;Resolve ! ;    (THeader dup hereresolve ;
   
   Variable aprim-nr -20 aprim-nr !
   
   : copy-execution-semantics ( ghost-from ghost-dest -- )
     >r
     dup >exec @ r@ >exec !
     dup >exec2 @ r@ >exec2 !
     dup >exec-compile @ r@ >exec-compile !
     dup >ghost-xt @ r@ >ghost-xt !
     dup >created @ r@ >created !
     rdrop drop ;
   
 >TARGET  >TARGET
   
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
     >in @ skip? IF  2drop  EXIT  THEN  >in !    >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< s" prims" T $has? H 0= and    (THeader ( S xt ghost )
     IF    2dup swap xt>ghost swap copy-execution-semantics
         .sourcepos ." needs prim: " >in @ bl word count type >in ! cr    over resolve T A, H alias-mask flag! ;
     THEN  
     (THeader over resolve T A, H 80 flag! ;  Variable last-prim-ghost
   0 last-prim-ghost !
   
   : asmprimname, ( ghost -- : name ) 
     dup last-prim-ghost !
     >r
     here bl word count string, r@ >asm-name !
     aprim-nr @ r> >asm-dummyaddr ! ;
   
   Defer setup-prim-semantics
   
   : aprim   ( -- ) 
     THeader -1 aprim-nr +! aprim-nr @ T A, H
     asmprimname, 
     setup-prim-semantics ;
   
   : aprim:   ( -- ) 
     -1 aprim-nr +! aprim-nr @
     Ghost tuck swap resolve <do:> swap tuck >magic !
     asmprimname, ;
   
 : Alias:   ( cfa -- ) \ name  : Alias:   ( cfa -- ) \ name
     >in @ skip? IF  2drop  EXIT  THEN  >in !    >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< s" prims" T $has? H 0= and    dup 0< s" prims" T $has? H 0= and
     IF    IF
         .sourcepos ." needs doer: " >in @ bl word count type >in ! cr        .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
     THEN    THEN
     ghost tuck swap resolve <do:> swap >magic ! ;    Ghost tuck swap resolve <do:> swap >magic ! ;
   
 Variable prim#  Variable prim#
 : first-primitive ( n -- )  prim# ! ;  : first-primitive ( n -- )  prim# ! ;
 : Primitive  ( -- ) \ name  : Primitive  ( -- ) \ name
     prim# @ T Alias H  -1 prim# +! ;    >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< s" prims" T $has? H 0= and
     IF
        .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
     THEN
     prim# @ (THeader ( S xt ghost )
     dup >ghost-flags <primitive> set-flag
     over resolve T A, H alias-mask flag!
     -1 prim# +! ;
 >CROSS  >CROSS
   
 \ Conditionals and Comments                            11may93jaw  \ Conditionals and Comments                            11may93jaw
   
   \G saves the existing cond action, this is used for redefining in
   \G instant
   Variable cond-xt-old
   
   : cond-target ( -- )
   \G Compiles semantic of redefined cond into new one
     cond-xt-old @ compile, ; immediate restrict
   
 : ;Cond  : ;Cond
   postpone ;    postpone ;
   swap ! ;  immediate    swap ! ;  immediate
   
 : Cond: ( -- ) \ name {code } ;  : Cond: ( "name" -- ) 
   atonce on  \g defines a conditional or another word that must
   ghost  \g be executed directly while compiling
   >exec  \g these words have no interpretative semantics by default
     Ghost
     >exec-compile
     dup @ cond-xt-old !
   :NONAME ;    :NONAME ;
   
 : restrict? ( -- )  
 \ aborts on interprete state - ae  
   state @ 0= ABORT" CROSS: Restricted" ;  
   
 : Comment ( -- )  : Comment ( -- )
   >in @ atonce on ghost swap >in ! ' swap >exec ! ;    >in @ Ghost swap >in ! ' swap 
     2dup >exec-compile ! >exec ! ;
   
 Comment (       Comment \  Comment (       Comment \
   
 \ compile                                              10may93jaw  \ compile                                              10may93jaw
   
 : compile  ( -- ) \ name  : compile  ( "name" -- ) \ name
   restrict?  \  bl word gfind 0= ABORT" CROSS: Can't compile "
   bl word gfind dup 0= ABORT" CROSS: Can't compile "    ghost
   0> ( immediate? )    dup >exec-compile @ ?dup
   IF    >exec @ compile,    IF    nip compile,
   ELSE  postpone literal postpone gexecute  THEN ;    ELSE  postpone literal postpone gexecute  THEN ;  immediate restrict
                                         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 )   : '  ( -- xt ) 
 \ returns the target-cfa of a ghost  \G returns the target-cfa of a ghost
   bl word gfind 0= ABORT" CROSS: Ghost don't exists"    bl word gfind 0= ABORT" CROSS: Ghost don't exists"
   ghost>cfa ;    g>xt ;
   
   \ FIXME: this works for the current use cases, but is not
   \ in all cases correct ;-) 
   : comp' X ' 0 ;
   
 Cond: [']  T ' H alit, ;Cond  Cond: [']  T ' H alit, ;Cond
   
Line 1361  Cond: [']  T ' H alit, ;Cond Line 2190  Cond: [']  T ' H alit, ;Cond
   
 : [T']  : [T']
 \ returns the target-cfa of a ghost, or compiles it as literal  \ returns the target-cfa of a ghost, or compiles it as literal
   postpone [G'] state @ IF postpone ghost>cfa ELSE ghost>cfa THEN ; immediate    postpone [G'] state @ IF postpone g>xt ELSE g>xt THEN ; immediate
   
 \ \ threading modell                                    13dec92py  \ \ threading modell                                    13dec92py
 \ modularized                                           14jun97jaw  \ modularized                                           14jun97jaw
   
 : fillcfa   ( usedcells -- )  T 2 cells H Value xt>body
   T cells H xt>body swap - 0 ?DO 0 T c, tchar H +LOOP ;  
   : (>body)   ( cfa -- pfa ) 
     xt>body + ;                                           ' (>body) plugin-of t>body
   
 : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H  : fillcfa   ( usedcells -- )
     T cells H xt>body swap -
     assert1( dup 0 >= )
     0 ?DO 0 X c, tchar +LOOP ;
   
 : (doer,)   ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ;   ' (doer,) IS doer,  : (doer,)   ( ghost -- ) 
     addr, 1 fillcfa ;                                     ' (doer,) plugin-of doer,
   
 : (docol,)  ( -- ) [G'] :docol doer, ;          ' (docol,) IS docol,  : (docol,)  ( -- ) [G'] :docol (doer,) ;                ' (docol,) plugin-of docol,
   
 : (doprim,) ( -- )  : (doprim,) ( -- )
   there xt>body + ca>native T a, H 1 fillcfa ;  ' (doprim,) IS doprim,    there xt>body + ca>native T a, H 1 fillcfa ;          ' (doprim,) plugin-of doprim,
   
 : (doeshandler,) ( -- )   : (doeshandler,) ( -- ) 
   T cfalign H compile :doesjump T 0 , H ;       ' (doeshandler,) IS doeshandler,    T cfalign H compile :doesjump T 0 , H ;               ' (doeshandler,) plugin-of doeshandler,
   
 : (dodoes,) ( does-action-ghost -- )  : (dodoes,) ( does-action-ghost -- )
   ]comp [G'] :dodoes gexecute comp[    ]comp [G'] :dodoes gexecute comp[
   addr,    addr,
   T here H tcell - reloff 2 fillcfa ;           ' (dodoes,) IS dodoes,    \ the relocator in the c engine, does not like the
     \ does-address to marked for relocation
     [ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ]
     2 fillcfa ;                                           ' (dodoes,) plugin-of dodoes,
   
 : (lit,) ( n -- )   compile lit T  ,  H ;       ' (lit,) IS lit,  : (dlit,) ( n -- ) compile lit td, ;                    ' (dlit,) plugin-of dlit,
   
   : (lit,) ( n -- )  s>d dlit, ;                          ' (lit,) plugin-of lit,
   
 \ if we dont produce relocatable code alit, defaults to lit, jaw  \ if we dont produce relocatable code alit, defaults to lit, jaw
 has? relocate  \ this is just for convenience, so we don't have to define alit,
   \ seperately for embedded systems....
   T has? relocate H
 [IF]  [IF]
 : (alit,) ( n -- )  compile lit T  a, H ;       ' (alit,) IS alit,  : (alit,) ( n -- )  compile lit T  a, H ;               ' (alit,) plugin-of alit,
 [ELSE]  [ELSE]
 : (alit,) ( n -- )  lit, ;                      ' (alit,) IS alit,  : (alit,) ( n -- )  lit, ;                              ' (alit,) plugin-of alit,
 [THEN]  [THEN]
   
 : (fini,)         compile ;s ;                ' (fini,) IS fini,  : (fini,)         compile ;s ;                          ' (fini,) plugin-of fini,
   
 [IFUNDEF] (code)   [IFUNDEF] (code) 
 Defer (code)  Defer (code)
Line 1414  Defer (end-code) Line 2256  Defer (end-code)
   
 : Code:  : Code:
   defempty?    defempty?
     ghost dup there ca>native resolve  <do:> swap >magic !      Ghost dup there ca>native resolve  <do:> swap >magic !
     depth (code) ;      depth (code) ;
   
 : end-code  : end-code
Line 1423  Defer (end-code) Line 2265  Defer (end-code)
     ELSE true ABORT" CROSS: Stack empty" THEN      ELSE true ABORT" CROSS: Stack empty" THEN
     ;      ;
   
 ( Cond ) : chars tchar * ; ( Cond )  
   
 >CROSS  >CROSS
   
 \ tLiteral                                             12dec92py  \ tLiteral                                             12dec92py
Line 1432  Defer (end-code) Line 2272  Defer (end-code)
 >TARGET  >TARGET
 Cond: \G  T-\G ;Cond  Cond: \G  T-\G ;Cond
   
 Cond:  Literal ( n -- )   restrict? lit, ;Cond  Cond: Literal  ( n -- )   lit, ;Cond
 Cond: ALiteral ( n -- )   restrict? alit, ;Cond  Cond: ALiteral ( n -- )   alit, ;Cond
   
 : Char ( "<char>" -- )  bl word char+ c@ ;  : Char ( "<char>" -- )  bl word char+ c@ ;
 Cond: [Char]   ( "<char>" -- )  restrict? Char  lit, ;Cond  Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond
   
   tchar 1 = [IF]
   Cond: chars ;Cond 
   [THEN]
   
 \ some special literals                                 27jan97jaw  \ some special literals                                 27jan97jaw
   
 \ !! Known Bug: Special Literals and plug-ins work only correct  \ !! Known Bug: Special Literals and plug-ins work only correct
 \ on 16 and 32 Bit Targets and 32 Bit Hosts!  \ on 16 and 32 Bit Targets and 32 Bit Hosts!
   
   \ This section could be done with dlit, now. But first I need
   \ some test code JAW
   
 Cond: MAXU  Cond: MAXU
   restrict?   
   tcell 1 cells u>     tcell 1 cells u> 
   IF    compile lit tcell 0 ?DO FF T c, H LOOP     IF    compile lit tcell 0 ?DO FF T c, H LOOP 
   ELSE  $ffffffff lit, THEN    ELSE  ffffffff lit, THEN
   ;Cond    ;Cond
   
 Cond: MINI  Cond: MINI
   restrict?  
   tcell 1 cells u>    tcell 1 cells u>
   IF    compile lit bigendian     IF    compile lit bigendian 
         IF      80 T c, H tcell 1 ?DO 0 T c, H LOOP           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          ELSE    tcell 1 ?DO 0 T c, H LOOP 80 T c, H
         THEN          THEN
   ELSE  tcell 2 = IF $8000 ELSE $80000000 THEN lit, THEN    ELSE  tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN
   ;Cond    ;Cond
     
 Cond: MAXI  Cond: MAXI
  restrict?  
  tcell 1 cells u>   tcell 1 cells u>
  IF     compile lit bigendian    IF     compile lit bigendian 
         IF      7F T c, H tcell 1 ?DO FF T c, H LOOP          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          ELSE    tcell 1 ?DO FF T c, H LOOP 7F T c, H
         THEN          THEN
  ELSE   tcell 2 = IF $7fff ELSE $7fffffff THEN lit, THEN   ELSE   tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN
  ;Cond   ;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 
   number? dup  IF    0> IF swap lit,  THEN  lit,  drop    IF    >r ( discard saved input state ) discard r>
                ELSE  2drop >in !          dup >exec-compile @ ?dup
                ghost gexecute THEN  ;          IF   nip execute-exec-compile 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  : compiling-state ( -- )
   \G set states to compililng
     Compiling comp-state !      Compiling comp-state !
       \ if we have a state in target, change it with the compile state
       [G'] state dup undefined? 0= 
       IF >ghost-xt @ execute X on ELSE drop THEN ;
   
   : interpreting-state ( -- )
   \G set states to interpreting
      \ if target has a state variable, change it according to our state
      [G'] state dup undefined? 0= 
      IF >ghost-xt @ execute X off ELSE drop THEN
      Interpreting comp-state ! ;
   
   : ] 
       compiling-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
         state @          compiling? 0=
         0=  
     UNTIL ;      UNTIL ;
   
 \ by the way: defining a second interpreter (a compiler-)loop  \ by the way: defining a second interpreter (a compiler-)loop
 \             is not allowed if a system should be ans conform  \             is not allowed if a system should be ans conform
   
   : (:) ( ghost -- ) 
   \ common factor of : and :noname. Prepare ;Resolve and start definition
      ;Resolve ! there ;Resolve cell+ !
      docol, ]comp  colon-start depth T ] H ;
   
 : : ( -- colon-sys ) \ Name  : : ( -- colon-sys ) \ Name
   defempty?    defempty?
   constflag off \ don't let this flag work over colon defs    constflag off \ don't let this flag work over colon defs
                 \ just to go sure nothing unwanted happens                  \ just to go sure nothing unwanted happens
   >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !    >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !
   (THeader ;Resolve ! there ;Resolve cell+ !    (THeader (:) ;
   docol, ]comp depth T ] H ;  
   
 : :noname ( -- colon-sys )  : :noname ( -- colon-sys )
   T cfalign H there docol, 0 ;Resolve ! depth T ] H ;    X cfalign there 
     \ define a nameless ghost
     here ghostheader dup last-header-ghost ! dup to lastghost
     (:) ;  
   
 Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond  Cond: EXIT ( -- )   compile ;S  ;Cond
   
 Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond  Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
   
Line 1523  Cond: ?EXIT ( -- ) 1 abort" CROSS: using Line 2395  Cond: ?EXIT ( -- ) 1 abort" CROSS: using
   
 >TARGET  >TARGET
   
 Cond: recurse ( -- ) Last-Ghost @ gexecute ;Cond  Cond: recurse ( -- ) Last-Header-Ghost @ gexecute ;Cond
   
   Cond: ; ( -- ) 
           depth ?dup 
           IF   1- <> ABORT" CROSS: Stack changed"
           ELSE true ABORT" CROSS: Stack empty" 
           THEN
           colon-end
           fini,
           comp[
           ;Resolve @ 
           IF      ;Resolve @ ;Resolve cell+ @ resolve 
                   ['] colon-resolved ;Resolve @ >comp !
           THEN
           interpreting-state
           ;Cond
   
 Cond: ; ( -- ) restrict?  Cond: [ ( -- ) interpreting-state ;Cond
                depth ?dup IF   1- <> ABORT" CROSS: Stack changed"  
                           ELSE true ABORT" CROSS: Stack empty" THEN  
                fini,  
                comp[  
                state off  
                ;Resolve @  
                IF ;Resolve @ ;Resolve cell+ @ resolve THEN  
                 Interpreting comp-state !  
                ;Cond  
 Cond: [  restrict? state off Interpreting comp-state ! ;Cond  
   
 >CROSS  >CROSS
   
Line 1550  Create GhostDummy ghostheader Line 2427  Create GhostDummy ghostheader
     GhostDummy >link ! GhostDummy       GhostDummy >link ! GhostDummy 
     tlastcfa @ >tempdp dodoes, tempdp> ;      tlastcfa @ >tempdp dodoes, tempdp> ;
   
   
   Defer instant-interpret-does>-hook
   
   : resolve-does>-part ( -- )
   \ resolve words made by builders
     Last-Header-Ghost @ >do:ghost @ ?dup 
     IF    there resolve 
           \ TODO: set special DOES> resolver action here
     THEN ;
   
 >TARGET  >TARGET
 Cond: DOES> restrict?  Cond: DOES>
         compile (does>) doeshandler,           compile (does>) doeshandler,
         \ resolve words made by builders          resolve-does>-part
         tdoes @ ?dup IF  @ T here H resolve THEN  
         ;Cond          ;Cond
 : DOES> switchrom doeshandler, T here H !does depth T ] H ;  
   : DOES> switchrom doeshandler, T here H !does 
     instant-interpret-does>-hook
     depth T ] H ;
   
 >CROSS  >CROSS
 \ Creation                                             01nov92py  \ Creation                                              01nov92py
   
 \ Builder                                               11may93jaw  \ Builder                                               11may93jaw
   
 : Builder    ( Create-xt do:-xt "name" -- )  0 Value built
   
   : Builder    ( Create-xt do-ghost "name" -- )
 \ builds up a builder in current vocabulary  \ builds up a builder in current vocabulary
 \ create-xt is executed when word is interpreted  \ create-xt is executed when word is interpreted
 \ do:-xt is executet when the created word from builder is executed  \ do:-xt is executed when the created word from builder is executed
 \ for do:-xt an additional entry after the normal ghost-enrys is used  \ for do:-xt an additional entry after the normal ghost-entrys is used
   
   >in @ alias2 swap dup >in ! >r >r    ghost to built 
   Make-Ghost     built >created @ 0= IF
   rot swap >exec dup @ ['] NoExec <>      built >created on
   IF 2drop ELSE ! THEN      ['] prim-resolved built >comp ! 
   ,    THEN ;
   r> r> >in !  
   also ghosts ' previous swap ! ;  
 \  DOES>  dup >exec @ execute ;  
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
   >end @ dup undefined? 0=    >do:ghost @ dup undefined? 0=
   IF    IF
         dup >magic @ <do:> =          dup >magic @ <do:> =
         IF       doer,           IF       doer, 
Line 1594  Cond: DOES> restrict? Line 2482  Cond: DOES> restrict?
   0 fillcfa    0 fillcfa
   ;    ;
   
   : takeover-x-semantics ( S constructor-ghost new-ghost -- )
   \g stores execution semantic and compilation semantic in the built word
      swap >do:ghost @ 
      \ we use the >exec2 field for the semantic of a created word,
      \ using exec or exec2 makes no difference for normal cross-compilation
      \ but is usefull for instant where the exec field is already
      \ defined (e.g. Vocabularies)
      2dup >exec @ swap >exec2 ! 
      >comp @ swap >comp ! ;
   
 : TCreate ( <name> -- )  : TCreate ( <name> -- )
   executed-ghost @  
   CreateFlag on  
   create-forward-warn    create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   Theader >r dup gdoes,    executed-ghost @ (Theader
 \ stores execution symantic in the built word    dup >created on
   >end @ >exec @ r> >exec ! ;    2dup takeover-x-semantics hereresolve gdoes, ;
   
 : RTCreate ( <name> -- )  : RTCreate ( <name> -- )
 \ creates a new word with code-field in ram  \ creates a new word with code-field in ram
   executed-ghost @  
   CreateFlag on  
   create-forward-warn    create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   \ make Alias    \ make Alias
   (THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost )    executed-ghost @ (THeader 
   \ store  poiter to code-field    dup >created on
     2dup takeover-x-semantics
     there 0 T a, H alias-mask flag!
     \ store poiter to code-field
   switchram T cfalign H    switchram T cfalign H
   there swap T ! H    there swap T ! H
   there tlastcfa !     there tlastcfa ! 
   dup there resolve 0 ;Resolve !    hereresolve gdoes, ;
   >r dup gdoes,  
   >end @ >exec @ r> >exec ! ;  
   
 : Build:  ( -- [xt] [colon-sys] )  : Build:  ( -- [xt] [colon-sys] )
   :noname postpone TCreate ;    :noname postpone TCreate ;
Line 1630  Cond: DOES> restrict? Line 2525  Cond: DOES> restrict?
   postpone TCreate     postpone TCreate 
   [ [THEN] ] ;    [ [THEN] ] ;
   
   : ;Build
     postpone ; built >exec ! ; immediate
   
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
   executed-ghost @    executed-ghost @ g>body ;
   state @ IF  gexecute true EXIT  THEN  
   >link @ T >body H false ;  
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  
   
 : DO:     ( -- addr [xt] [colon-sys] )  : do:ghost! ( ghost -- ) built >do:ghost ! ;
   here ghostheader  : doexec! ( xt -- ) built >do:ghost @ >exec ! ;
   :noname postpone gdoes> postpone ?EXIT ;  
   
 : by:     ( -- addr [xt] [colon-sys] ) \ name  
   ghost  
   :noname postpone gdoes> postpone ?EXIT ;  
   
 : ;DO ( addr [xt] [colon-sys] -- addr )  : DO:     ( -- [xt] [colon-sys] )
   postpone ;    ( S addr xt )    here ghostheader do:ghost!
   over >exec ! ; immediate    :noname postpone gdoes> ;
   
   : by:     ( -- [xt] [colon-sys] ) \ name
     Ghost do:ghost!
     :noname postpone gdoes> ;
   
   : ;DO ( [xt] [colon-sys] -- )
     postpone ; doexec! ; immediate
   
   : by      ( -- ) \ Name
     Ghost >do:ghost @ do:ghost! ;
   
   : compile: ( --[xt] [colon-sys] )
   \G defines a compile time action for created words
   \G by this builder
     :noname ;
   
 : by      ( -- addr ) \ Name  : ;compile ( [xt] [colon-sys] -- )
   ghost >end @ ;    postpone ; built >do:ghost @ >comp ! ; immediate
   
 >TARGET  
 \ Variables and Constants                              05dec92py  \ Variables and Constants                              05dec92py
   
 Build:  ( n -- ) ;  
 by: :docon ( ghost -- n ) T @ H ;DO  
 Builder (Constant)  Builder (Constant)
   Build:  ( n -- ) ;Build
   by: :docon ( target-body-addr -- n ) T @ H ;DO
   
 Build:  ( n -- ) T , H ;  
 by (Constant)  
 Builder Constant  Builder Constant
   Build:  ( n -- ) T , H ;Build
 Build:  ( n -- ) T A, H ;  
 by (Constant)  by (Constant)
   
 Builder AConstant  Builder AConstant
   Build:  ( n -- ) T A, H ;Build
   by (Constant)
   
 Build:  ( d -- ) T , , H ;  
 DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO  
 Builder 2Constant  Builder 2Constant
   Build:  ( d -- ) T , , H ;Build
   DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
   
 BuildSmart: ;  
 by: :dovar ( ghost -- addr ) ;DO  
 Builder Create  Builder Create
   BuildSmart: ;Build
   by: :dovar ( target-body-addr -- addr ) ;DO
   
   Builder Variable
 T has? rom H [IF]  T has? rom H [IF]
 Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;  Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , H ( switchrom ) ;Build
 by (Constant)  by (Constant)
 Builder Variable  
 [ELSE]  [ELSE]
 Build: T 0 , H ;  Build: T 0 , H ;Build
 by Create  by Create
 Builder Variable  
 [THEN]  [THEN]
   
   Builder 2Variable
 T has? rom H [IF]  T has? rom H [IF]
 Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;  Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;Build
 by (Constant)  by (Constant)
 Builder 2Variable  
 [ELSE]  [ELSE]
 Build: T 0 , 0 , H ;  Build: T 0 , 0 , H ;Build
 by Create  by Create
 Builder 2Variable  
 [THEN]  [THEN]
   
   Builder AVariable
 T has? rom H [IF]  T has? rom H [IF]
 Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;  Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 A, H ( switchrom ) ;Build
 by (Constant)  by (Constant)
 Builder AVariable  
 [ELSE]  [ELSE]
 Build: T 0 A, H ;  Build: T 0 A, H ;Build
 by Create  by Create
 Builder AVariable  
 [THEN]  [THEN]
   
 \ User variables                                       04may94py  \ User variables                                       04may94py
   
 >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  
   
 Build: T 0 u, , H ;  
 by: :douser ( ghost -- up-addr )  T @ H tup @ + ;DO  
 Builder User  Builder User
   Build: 0 u, X , ;Build
   by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO
   
 Build: T 0 u, , 0 u, drop H ;  
 by User  
 Builder 2User  Builder 2User
   Build: 0 u, X , 0 u, drop ;Build
 Build: T 0 au, , H ;  
 by User  by User
   
 Builder AUser  Builder AUser
   Build: 0 au, X , ;Build
   by User
   
   Builder (Value)
   Build:  ( n -- ) ;Build
   by: :docon ( target-body-addr -- n ) T @ H ;DO
   
 BuildSmart: T , H ;  
 by (Constant)  
 Builder Value  Builder Value
   BuildSmart: T , H ;Build
   by (Value)
   
 BuildSmart: T A, H ;  
 by (Constant)  
 Builder AValue  Builder AValue
   BuildSmart: T A, H ;Build
   by (Value)
   
   Defer texecute
   
 BuildSmart:  ( -- ) [T'] noop T A, H ;  
 by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  
 Builder Defer  Builder Defer
   BuildSmart:  ( -- ) [T'] noop T A, H ;Build
   by: :dodefer ( ghost -- ) X @ texecute ;DO
   
 BuildSmart:  ( inter comp -- ) swap T immediate A, A, H ;  
 DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  
 Builder interpret/compile:  Builder interpret/compile:
   Build: ( inter comp -- ) swap T immediate A, A, H ;Build
   DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
   
 \ Sturctures                                           23feb95py  \ Sturctures                                           23feb95py
   
 >CROSS  
 : nalign ( addr1 n -- addr2 )  : nalign ( addr1 n -- addr2 )
 \ addr2 is the aligned version of addr1 wrt the alignment size n  \ addr2 is the aligned version of addr1 wrt the alignment size n
  1- tuck +  swap invert and ;   1- tuck +  swap invert and ;
 >TARGET  
   
 Build: ;  
 by: :dofield T @ H + ;DO  
 Builder (Field)  Builder (Field)
   Build: ;Build
   by: :dofield T @ H + ;DO
   
   Builder Field
 Build: ( align1 offset1 align size "name" --  align2 offset2 )  Build: ( align1 offset1 align size "name" --  align2 offset2 )
     rot dup T , H ( align1 align size offset1 )      rot dup T , H ( align1 align size offset1 )
     + >r nalign r> ;      + >r nalign r> ;Build
 by (Field)  by (Field)
 Builder Field  
   
   >TARGET
 : struct  T 1 chars 0 H ;  : struct  T 1 chars 0 H ;
 : end-struct  T 2Constant H ;  : end-struct  T 2Constant H ;
   
 : cell% ( n -- size align )  : cell% ( n -- size align )
     T 1 cells H dup ;      T 1 cells H dup ;
   >CROSS
   
   \ Input-Methods                                            01py
   
 \ ' 2Constant Alias2 end-struct  Builder input-method
 \ 0 1 T Chars H 2Constant struct  Build: ( m v -- m' v )  dup T , cell+ H ;Build
   DO:  abort" Not in cross mode" ;DO
   
   Builder input-var
   Build: ( m v size -- m v' )  over T , H + ;Build
   DO:  abort" Not in cross mode" ;DO
   
   \ Peephole optimization                                 05sep01jaw
   
   \ this section defines different compilation
   \ actions for created words
   \ this will help the peephole optimizer
   \ I (jaw) took this from bernds lates cross-compiler
   \ changes but seperated it from the original
   \ Builder words. The final plan is to put this
   \ into a seperate file, together with the peephole
   \ optimizer for cross
   
   
   T has? peephole H [IF]
   
   >CROSS
   : (callc) compile call T >body a, H ;           ' (callc) plugin-of colon,
   
   \ if we want this, we have to spilt aconstant
   \ and constant!!
   \ Builder (Constant)
   \ compile: g>body X @ lit, ;compile
   
   Builder (Constant)
   compile: g>body alit, compile @ ;compile
   
   Builder (Value)
   compile: g>body alit, compile @ ;compile
   
   \ this changes also Variable, AVariable and 2Variable
   Builder Create
   \ compile: g>body alit, ;compile
   
   Builder User
   compile: g>body compile useraddr T @ , H ;compile
   
   Builder Defer
   compile: g>body alit, compile @ compile execute ;compile
   
   Builder (Field)
   compile: g>body T @ H lit, compile + ;compile
   
   [THEN]
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS
 : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;  : (ncontrols?) ( n -- ) 
 : sys?        ( sys -- sys )    dup 0= ?struc ;  \g We expect n open control structures
     depth over u<= 
     ABORT" CROSS: unstructured, stack underflow"
     0 ?DO I pick 0= 
           ABORT" CROSS: unstructured" 
     LOOP ;                                        ' (ncontrols?) plugin-of ncontrols?
   
   \ : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;
   \ : sys?        ( sys -- sys )    dup 0= ?struc ;
   
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;
   
 : branchoffset ( src dest -- ) - tchar / ; \ ?? jaw  : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
   
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  : >resolve    ( sys -- )        
           X here ( dup ." >" hex. ) over branchoffset swap X ! ;
   
 : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;  : <resolve    ( sys -- )
           X here ( dup ." <" hex. ) branchoffset X , ;
   
 :noname compile branch T here branchoffset , H ;  :noname compile branch X here branchoffset X , ;
   IS branch, ( target-addr -- )    IS branch, ( target-addr -- )
 :noname compile ?branch T here branchoffset , H ;  :noname compile ?branch X here branchoffset X , ;
   IS ?branch, ( target-addr -- )    IS ?branch, ( target-addr -- )
 :noname compile branch T here 0 , H ;  :noname compile branch T here 0 , H ;
   IS branchmark, ( -- branchtoken )    IS branchmark, ( -- branchtoken )
Line 1797  Builder Field Line 2766  Builder Field
   IS ?branchmark, ( -- branchtoken )    IS ?branchmark, ( -- branchtoken )
 :noname T here 0 , H ;  :noname T here 0 , H ;
   IS ?domark, ( -- branchtoken )    IS ?domark, ( -- branchtoken )
 :noname dup T @ H ?struc T here over branchoffset swap ! H ;  :noname dup X @ ?struc X here over branchoffset swap X ! ;
   IS branchtoresolve, ( branchtoken -- )    IS branchtoresolve, ( branchtoken -- )
 :noname branchto, T here H ;  :noname branchto, X here ;
   IS branchtomark, ( -- target-addr )    IS branchtomark, ( -- target-addr )
   
 >TARGET  >TARGET
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 Cond: BUT       restrict? sys? swap ;Cond  \ CLEANUP Cond: BUT       sys? swap ;Cond
 Cond: YET       restrict? sys? dup ;Cond  \ CLEANUP Cond: YET       sys? dup ;Cond
   
 0 [IF]  
 >CROSS  
 Variable tleavings  
 >TARGET  
   
 Cond: DONE   ( addr -- )  restrict? tleavings @  
       BEGIN  2dup u> 0=  WHILE  dup T @ H swap >resolve REPEAT  
       tleavings ! drop ;Cond  
   
 >CROSS  >CROSS
 : (leave)  T here H tleavings @ T , H  tleavings ! ;  
 >TARGET  
   
 Cond: LEAVE     restrict? compile branch (leave) ;Cond  
 Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave)  ;Cond  
   
 [ELSE]  
     \ !! This is WIP  
     \ The problem is (?DO)!  
     \ perhaps we need a plug-in for (?DO)  
       
 >CROSS  
 Variable tleavings 0 tleavings !  Variable tleavings 0 tleavings !
   
 : (done) ( addr -- )  : (done) ( addr -- )
     tleavings @      tleavings @
     BEGIN  dup      BEGIN  dup
Line 1847  Variable tleavings 0 tleavings ! Line 2797  Variable tleavings 0 tleavings !
   
 >TARGET  >TARGET
   
 Cond: DONE   ( addr -- )  restrict? (done) ;Cond  \ What for? ANS? JAW Cond: DONE   ( addr -- )  (done) ;Cond
   
 >CROSS  >CROSS
 : (leave) ( branchtoken -- )  : (leave) ( branchtoken -- )
Line 1858  Cond: DONE   ( addr -- )  restrict? (don Line 2808  Cond: DONE   ( addr -- )  restrict? (don
     r> tleavings ! ;      r> tleavings ! ;
 >TARGET  >TARGET
   
 Cond: LEAVE     restrict? branchmark, (leave) ;Cond  : (leave,) ( -- ) 
 Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave)  ;Cond    branchmark, (leave) ;                         ' (leave,) plugin-of leave,
   
 [THEN]  : (?leave,) ( -- )
     compile 0= ?branchmark, (leave) ;             ' (?leave,) plugin-of ?leave,
   
   Cond: LEAVE     leave, ;Cond
   Cond: ?LEAVE    ?leave, ;Cond
   
 >CROSS  >CROSS
 \ !!JW ToDo : Move to general tools section  \ !!JW ToDo : Move to general tools section
   
 : to1 ( x1 x2 xn n -- addr )  : to1 ( x1 x2 xn n -- addr )
 \G packs n stack elements in a allocated memory region  \G packs n stack elements in am allocated memory region
    dup dup 1+ cells allocate throw dup >r swap 1+     dup dup 1+ cells allocate throw dup >r swap 1+
    0 DO tuck ! cell+ LOOP     0 DO tuck ! cell+ LOOP
    drop r> ;     drop r> ;
   
 : 1to ( addr -- x1 x2 xn )  : 1to ( addr -- x1 x2 xn )
 \G unpacks the elements saved by to1  \G unpacks the elements saved by to1
     dup @ swap over cells + swap      dup @ swap over cells + swap
Line 1885  Cond: ?LEAVE    restrict? compile 0=  ?b Line 2840  Cond: ?LEAVE    restrict? compile 0=  ?b
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
   : (cs-swap) ( x1 x2 -- x2 x1 )
     swap ;                                        ' (cs-swap) plugin-of cs-swap
   
   : (ahead,) branchmark, ;                        ' (ahead,) plugin-of ahead,
   
   : (if,) ?branchmark, ;                          ' (if,) plugin-of if,
   
   : (then,) branchto, branchtoresolve, ;          ' (then,) plugin-of then,
   
   : (else,) ( ahead ) branchmark, 
             swap 
             ( then ) branchto, branchtoresolve, ; ' (else,) plugin-of else,
   
   : (begin,) branchtomark, ;                      ' (begin,) plugin-of begin,
   
   : (while,) ( if ) ?branchmark,
              swap ;                               ' (while,) plugin-of while,
   
   : (again,) branch, ;                            ' (again,) plugin-of again,
   
   : (until,) ?branch, ;                           ' (until,) plugin-of until,
   
   : (repeat,) ( again ) branch,
               ( then ) branchto, branchtoresolve, ; ' (repeat,) plugin-of repeat,
   
   : (case,)   ( -- n )
     0 ;                                           ' (case,) plugin-of case,
   
   : (of,) ( n -- x1 n )
     1+ >r 
     compile over compile = 
     if, compile drop r> ;                         ' (of,) plugin-of of,
   
   : (endof,) ( x1 n -- x2 n )
     >r 1 ncontrols? else, r> ;                    ' (endof,) plugin-of endof,
   
   : (endcase,) ( x1 .. xn n -- )
     compile drop 0 ?DO 1 ncontrols? then, LOOP ;  ' (endcase,) plugin-of endcase,
   
 >TARGET  >TARGET
 Cond: AHEAD     restrict? branchmark, ;Cond  Cond: AHEAD     ahead, ;Cond
 Cond: IF        restrict? ?branchmark, ;Cond  Cond: IF        if,  ;Cond
 Cond: THEN      restrict? sys? branchto, branchtoresolve, ;Cond  Cond: THEN      1 ncontrols? then, ;Cond
 Cond: ELSE      restrict? sys? compile AHEAD swap compile THEN ;Cond  Cond: ENDIF     1 ncontrols? then, ;Cond
   Cond: ELSE      1 ncontrols? else, ;Cond
 Cond: BEGIN     restrict? branchtomark, ;Cond  
 Cond: WHILE     restrict? sys? compile IF swap ;Cond  Cond: BEGIN     begin, ;Cond
 Cond: AGAIN     restrict? sys? branch, ;Cond  Cond: WHILE     1 ncontrols? while, ;Cond
 Cond: UNTIL     restrict? sys? ?branch, ;Cond  Cond: AGAIN     1 ncontrols? again, ;Cond
 Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond  Cond: UNTIL     1 ncontrols? until, ;Cond
   Cond: REPEAT    2 ncontrols? repeat, ;Cond
 Cond: CASE      restrict? 0 ;Cond  
 Cond: OF        restrict? 1+ >r compile over compile =  Cond: CASE      case, ;Cond
                 compile IF compile drop r> ;Cond  Cond: OF        of, ;Cond
 Cond: ENDOF     restrict? >r compile ELSE r> ;Cond  Cond: ENDOF     endof, ;Cond
 Cond: ENDCASE   restrict? compile drop 0 ?DO  compile THEN  LOOP ;Cond  Cond: ENDCASE   endcase, ;Cond
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 :noname \ ?? i think 0 is too much! jaw  : (do,) ( -- target-addr )
     \ ?? i think 0 is too much! jaw
     0 compile (do)      0 compile (do)
     branchtomark,  2 to1 ;      branchtomark,  2 to1 ;                      ' (do,) plugin-of do,
   IS do, ( -- target-addr )  
   
 \ :noname  \ alternative for if no ?do
   \ : (do,)
 \     compile 2dup compile = compile IF  \     compile 2dup compile = compile IF
 \     compile 2drop compile ELSE  \     compile 2drop compile ELSE
 \     compile (do) branchtomark, 2 to1 ;  \     compile (do) branchtomark, 2 to1 ;
 \   IS ?do,  
           
 :noname  : (?do,) ( -- target-addr )
     0 compile (?do)  ?domark, (leave)      0 compile (?do)  ?domark, (leave)
     branchtomark,  2 to1 ;      branchtomark,  2 to1 ;                      ' (?do,) plugin-of ?do,
   IS ?do, ( -- target-addr )  
 :noname compile (for) branchtomark, ;  : (for,) ( -- target-addr )
   IS for, ( -- target-addr )    compile (for) branchtomark, ;                 ' (for,) plugin-of for,
 :noname 1to compile (loop)  loop] compile unloop skiploop] ;  
   IS loop, ( target-addr -- )  : (loop,) ( target-addr -- )
 :noname 1to compile (+loop)  loop] compile unloop skiploop] ;    1to compile (loop)  loop] 
   IS +loop, ( target-addr -- )    compile unloop skiploop] ;                    ' (loop,) plugin-of loop,
 :noname compile (next)  loop] compile unloop ;  
   IS next, ( target-addr -- )  : (+loop,) ( target-addr -- )
     1to compile (+loop)  loop] 
 Cond: DO        restrict? do, ;Cond    compile unloop skiploop] ;                    ' (+loop,) plugin-of +loop,
 Cond: ?DO       restrict? ?do, ;Cond  
 Cond: FOR       restrict? for, ;Cond  : (next,) 
     compile (next)  loop] compile unloop ;        ' (next,) plugin-of next,
 Cond: LOOP      restrict? sys? loop, ;Cond  
 Cond: +LOOP     restrict? sys? +loop, ;Cond  Cond: DO        do, ;Cond
 Cond: NEXT      restrict? sys? next, ;Cond  Cond: ?DO       ?do, ;Cond
   Cond: FOR       for, ;Cond
   
   Cond: LOOP      1 ncontrols? loop, ;Cond
   Cond: +LOOP     1 ncontrols? +loop, ;Cond
   Cond: NEXT      1 ncontrols? next, ;Cond
   
 \ String words                                         23feb93py  \ String words                                         23feb93py
   
 : ,"            [char] " parse T string, align H ;  : ,"            [char] " parse ht-string, X align ;
   
 Cond: ."        restrict? compile (.")     T ," H ;Cond  Cond: ."        compile (.")     T ," H ;Cond
 Cond: S"        restrict? compile (S")     T ," H ;Cond  Cond: S"        compile (S")     T ," H ;Cond
 Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond  Cond: C"        compile (C")     T ," H ;Cond
   Cond: ABORT"    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 >address ' >body ! H ;  : IS            T >address ' >body ! H ;
Line 1951  Cond: TO        T ' >body H compile ALit Line 2951  Cond: TO        T ' >body H compile ALit
 : TO            T ' >body ! H ;  : TO            T ' >body ! H ;
   
 Cond: defers    T ' >body @ compile, H ;Cond  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 ;  : chained       T linked A, H ;
   
 : err"   s" ErrLink linked" evaluate T , H  : err"   s" ErrLink linked" evaluate T , H
          [char] " parse T string, align H ;           [char] " parse ht-string, X align ;
   
 : env"  [char] " parse s" EnvLink linked" evaluate  : env"  [char] " parse s" EnvLink linked" evaluate
         T string, align , H ;          ht-string, X align X , ;
   
 : 2env" [char] " parse s" EnvLink linked" evaluate  : 2env" [char] " parse s" EnvLink linked" evaluate
         here >r T string, align , , H          here >r ht-string, X align X , X ,
         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
   
 Cond: compile ( -- ) restrict? \ name  Cond: [compile] ( -- ) \ name
       bl word gfind dup 0= ABORT" CROSS: Can't compile"  \g For immediate words, works even if forward reference
       0> IF    gexecute        bl word gfind 0= ABORT" CROSS: Can't compile"
          ELSE  dup >magic @ <imm> =        (gexecute) ;Cond
                IF   gexecute  
                ELSE compile (compile) addr, THEN THEN ;Cond  
   
 Cond: postpone ( -- ) restrict? \ name  
       bl word gfind dup 0= ABORT" CROSS: Can't compile"  
       0> IF    gexecute  
          ELSE  dup >magic @ <imm> =  
                IF   gexecute  
                ELSE compile (compile) addr, THEN THEN ;Cond  
                         
   Cond: postpone ( -- ) \ name
         bl word gfind 0= ABORT" CROSS: Can't compile"
         dup >magic @ <fwd> =
         ABORT" CROSS: Can't postpone on forward declaration"
         dup >magic @ <imm> =
         IF   (gexecute)
         ELSE compile (compile) addr, 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 ;
   
   \ save-asm-region                                       29aug01jaw
   
   Variable name-ptr
   Create name-buf 200 chars allot
   : init-name-buf name-buf name-ptr ! ;
   : nb, name-ptr @ c! 1 chars name-ptr +! ;
   : $nb, ( adr len -- ) bounds ?DO I c@ nb, LOOP ;
   : @nb name-ptr @ name-buf tuck - ;
   
   \ stores a usefull string representation of the character
   \ in the name buffer
   : name-char, ( c -- )
     dup 'a 'z 1+ within IF nb, EXIT THEN
     dup 'A 'Z 1+ within IF $20 + nb, EXIT THEN
     dup '0 '9 1+ within IF nb, EXIT THEN
     CASE '+ OF s" _PLUS" $nb, ENDOF
          '- OF s" _MINUS" $nb, ENDOF
          '* OF s" _STAR" $nb, ENDOF
          '/ OF s" _SLASH" $nb, ENDOF
          '' OF s" _TICK" $nb, ENDOF
          '( OF s" _OPAREN" $nb, ENDOF
          ') OF s" _CPAREN" $nb, ENDOF
          '[ OF s" _OBRACKET" $nb, ENDOF
          '] OF s" _CBRACKET" $nb, ENDOF
          '! OF s" _STORE" $nb, ENDOF
          '@ OF s" _FETCH" $nb, ENDOF
          '> OF s" _GREATER" $nb, ENDOF
          '< OF s" _LESS" $nb, ENDOF
          '= OF s" _EQUAL" $nb, ENDOF
          '# OF s" _HASH" $nb, ENDOF
          '? OF s" _QUEST" $nb, ENDOF
          ': OF s" _COL" $nb, ENDOF
          '; OF s" _SEMICOL" $nb, ENDOF
          ', OF s" _COMMA" $nb, ENDOF
          '. OF s" _DOT" $nb, ENDOF
          '" OF s" _DQUOT" $nb, ENDOF
          dup 
          base @ >r hex s>d <# #s 'X hold '_ hold #> $nb, r> base !
     ENDCASE ;
    
   : label-from-ghostname ( ghost -- addr len )
     dup >ghostname init-name-buf 'L nb, bounds 
     ?DO I c@ name-char, LOOP 
     \ we add the address to a name to make in unique
     \ because one name may appear more then once
     \ there are names (e.g. boot) that may be reference from other
     \ assembler source files, so we declare them as unique
     \ and don't add the address suffix
     dup >ghost-flags @ <unique> and 0= 
     IF   s" __" $nb, >link @ base @ >r hex 0 <# #s 'L hold #> r> base ! $nb, 
     ELSE drop 
     THEN
     @nb ;
   
   \ FIXME why disabled?!
   : label-from-ghostnameXX ( ghost -- addr len )
   \ same as (label-from-ghostname) but caches generated names
     dup >asm-name @ ?dup IF nip count EXIT THEN
    \ dup >r (label-from-ghostname) 2dup
     align here >r string, align
     r> r> >asm-name ! ;
   
   : primghostdiscover ( xt -- ghost true | xt false )
     dup 0= IF false EXIT THEN
     >r last-prim-ghost
     BEGIN @ dup
     WHILE dup >asm-dummyaddr @ r@ =
           IF rdrop true EXIT THEN
     REPEAT
     drop r> false ;
   
   : gdiscover2 ( xt -- ghost true | xt false ) 
     dup taddr>region 0= IF false EXIT THEN
     dup (>regiontype) @ dup 0= IF drop false EXIT THEN
     addr-xt-ghost @ dup 0= IF drop false EXIT THEN
     nip true ;
   \  dup >ghost-name @ IF nip true ELSE drop false THEN ;
   
   \ generates a label name for the target address
   : generate-label-name ( taddr -- addr len )
     gdiscover2
     IF dup >magic @ <do:> =
        IF >asm-name @ count EXIT THEN
        label-from-ghostname
     ELSE
        primghostdiscover
        IF   >asm-name @ count 
        ELSE base @ >r hex 0 <# #s 'L hold #> r> base !
        THEN
     THEN ;
   
   Variable outfile-fd
   
   : $out ( adr len -- ) outfile-fd @ write-file throw  ;
   : nlout newline $out ;
   : .ux ( n -- ) 
     base @ hex swap 0 <# #S #> $out base ! ;
   
   : save-asm-region-part-aligned ( taddr len -- 'taddr 'len )
     dup cell/ 0 
     ?DO nlout s"    .word " $out over @relbit 
         IF   over X @ generate-label-name $out
         ELSE over X @ s" 0x0" $out .ux
         THEN
         tcell /string
     LOOP ;
   
   : print-bytes ( taddr len n -- taddr' len' )
     over min dup 0> 
     IF   nlout s"    .byte " $out 0 
          ?DO  I 0> IF s" , " $out THEN
               over X c@ s" 0x0" $out .ux 1 /string 
          LOOP 
     THEN ;
   
   : save-asm-region-part ( addr len -- )
     over dup X aligned swap - ?dup
     IF   print-bytes THEN
     save-asm-region-part-aligned
     dup dup X aligned swap - ?dup
     IF   2 pick @relbit ABORT" relocated field splitted"
          print-bytes
     THEN
     2drop ;
   
   : print-label ( taddr -- )
     nlout generate-label-name $out s" :" $out ;
   
   : snl-calc ( taddr taddr2 -- )
     tuck over - ;
   
   : skip-nolables ( taddr -- taddr2 taddr len )
   \G skips memory region where no lables are defined
   \G starting from taddr+1
   \G Labels will be introduced for each reference mark
   \G in addr-refs.
   \G This word deals with lables at byte addresses as well.
   \G The main idea is to have an intro part which
   \G skips until the next cell boundary, the middle part
   \G which skips whole cells very efficiently and the third
   \G part which skips the bytes to the label in a cell
     dup 1+ dup (>regiontype) 
     ( S taddr taddr-realstart type-addr )
     dup @ dup IF addr-refs @ THEN
     swap >r
     over align+ tuck tcell swap - rshift swap 0
     DO dup 1 and 
        IF drop rdrop snl-calc UNLOOP EXIT THEN 
        2/ swap 1+ swap 
     LOOP
     drop r> cell+
     ( S .. taddr2 type-addr ) dup
     BEGIN dup @ dup IF addr-refs @ THEN 0= WHILE cell+ REPEAT
     dup >r swap - 1 cells / tcell * + r>
     ( S .. taddr2+skiplencells type-addr )
     @ addr-refs @ 1 tcell lshift or
     BEGIN dup 1 and 0= WHILE swap 1+ swap 2/ REPEAT drop
     ( S .. taddr2+skiplencells+skiplenbytes )
     snl-calc ;
   
   : insert-label ( taddr -- )
     dup 0= IF drop EXIT THEN
     \ ignore everything which points outside our memory regions
     \ maybe a primitive pointer or whatever
     dup taddr>region 0= IF drop EXIT THEN
     dup >r (>regiontype) define-addr-struct addr-refs dup @ 
     r> tcell 1- and 1 swap lshift or swap ! ;
   
   \ this generates a sorted list of addresses which must be labels
   \ it scans therefore a whole region
   : generate-label-list-region ( taddr len -- )
     BEGIN over @relbit IF over X @ insert-label THEN
           tcell /string dup 0< 
     UNTIL 2drop ;
   
   : generate-label-list ( -- )
     region-link
     BEGIN @ dup WHILE 
           dup 0 >rlink - extent 
           ?dup IF generate-label-list-region ELSE drop THEN
     REPEAT drop ;
   
   : create-outfile ( addr len -- )
     w/o bin create-file throw outfile-fd ! ;
   
   : close-outfile ( -- )
     outfile-fd @ close-file throw ;
   
   : (save-asm-region) ( region -- )
     \ ." label list..."
     generate-label-list
     \ ." ok!" cr
     extent ( S taddr len )
     over insert-label
     2dup + dup insert-label >r ( R end-label )
     ( S taddr len ) drop
     BEGIN
        dup print-label
        dup r@ <> WHILE
        skip-nolables save-asm-region-part
     REPEAT drop rdrop ;
   
   : lineout ( addr len -- )
     outfile-fd @ write-line throw ;  
   
   : save-asm-region ( region adr len -- )
     create-outfile (save-asm-region) close-outfile ;
   
 \ \ minimal definitions  \ \ minimal definitions
                         
 >MINIMAL  >MINIMAL also minimal
 also minimal  
 \ Usefull words                                        13feb93py  \ Usefull words                                        13feb93py
   
 : KB  400 * ;  : KB  400 * ;
Line 1997  also minimal Line 3250  also minimal
 \ \ [IF] [ELSE] [THEN] ...                              14sep97jaw  \ \ [IF] [ELSE] [THEN] ...                              14sep97jaw
   
 \ it is useful to define our own structures and not to rely  \ it is useful to define our own structures and not to rely
 \ on the words in the compiler  \ on the words in the host system
 \ The words in the compiler might be defined with vocabularies  \ The words in the host system might be defined with vocabularies
 \ this doesn't work with our self-made compile-loop  \ this doesn't work with our self-made compile-loop
   
 Create parsed 20 chars allot    \ store word we parsed  Create parsed 20 chars allot    \ store word we parsed
Line 2010  Create parsed 20 chars allot \ store wor Line 3263  Create parsed 20 chars allot \ store wor
 : [ELSE]  : [ELSE]
     1 BEGIN      1 BEGIN
         BEGIN bl word count dup WHILE          BEGIN bl word count dup WHILE
             comment? parsed place upcase parsed count              comment? 20 umin parsed place upcase parsed count
             2dup s" [IF]" compare 0= >r               2dup s" [IF]" compare 0= >r 
             2dup s" [IFUNDEF]" compare 0= >r              2dup s" [IFUNDEF]" compare 0= >r
             2dup s" [IFDEF]" compare 0= r> or r> or              2dup s" [IFDEF]" compare 0= r> or r> or
Line 2043  Cond: [ELSE]    postpone [ELSE] ;Cond Line 3296  Cond: [ELSE]    postpone [ELSE] ;Cond
   
 \ define new [IFDEF] and [IFUNDEF]                      20may93jaw  \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
   
 : defined? defined? ;  : defined? tdefined? ;
 : needed? needed? ;  : needed? needed? ;
 : doer? doer? ;  : doer? doer? ;
   
 \ we want to use IFDEF on compiler directives (e.g. E?) in the source, too  \ we want to use IFDEF on compiler directives (e.g. E?) in the source, too
   
 : directive?   : directive? 
   bl word count [ ' target >wordlist ] aliteral search-wordlist     bl word count [ ' target >wordlist ] literal search-wordlist 
   dup IF nip THEN ;    dup IF nip THEN ;
   
 : [IFDEF]  >in @ directive? swap >in !  : [IFDEF]  >in @ directive? swap >in !
            0= IF defined? ELSE name 2drop true THEN             0= IF tdefined? ELSE name 2drop true THEN
            postpone [IF] ;             postpone [IF] ;
   
 : [IFUNDEF] defined? 0= postpone [IF] ;  : [IFUNDEF] tdefined? 0= postpone [IF] ;
   
 Cond: [IFDEF]   postpone [IFDEF] ;Cond  Cond: [IFDEF]   postpone [IFDEF] ;Cond
   
Line 2065  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 3318  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
   
 \ C: \- \+ Conditional Compiling                         09jun93jaw  \ C: \- \+ Conditional Compiling                         09jun93jaw
   
 : C: >in @ defined? 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 2075  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 3328  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
         AGAIN          AGAIN
      THEN ;       THEN ;
   
 also minimal  
   
 : d? d? ;  : d? d? ;
   
 \G doesn't skip line when debug switch is on  \G doesn't skip line when debug switch is on
 : \D D? 0= IF postpone \ THEN ;  : \D D? 0= IF postpone \ THEN ;
   
 \G interprets the line if word is not defined  \G interprets the line if word is not defined
 : \- defined? IF postpone \ THEN ;  : \- tdefined? IF postpone \ THEN ;
   
 \G interprets the line if word is defined  \G interprets the line if word is defined
 : \+ defined? 0= IF postpone \ THEN ;  : \+ tdefined? 0= IF postpone \ THEN ;
   
 Cond: \- \- ;Cond  Cond: \- \- ;Cond
 Cond: \+ \+ ;Cond  Cond: \+ \+ ;Cond
Line 2096  Cond: \D \D ;Cond Line 3347  Cond: \D \D ;Cond
   
 : needed:  : needed:
 \G defines ghost for words that we want to be compiled  \G defines ghost for words that we want to be compiled
   BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;    BEGIN >in @ bl word c@ WHILE >in ! Ghost drop REPEAT drop ;
   
 previous  
   
 \ save-cross                                           17mar93py  
   
 >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"  -i"   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 ;  
   
 \ words that should be in minimal  \ words that should be in minimal
   
 create s-buffer 50 chars allot  create s-buffer 50 chars allot
   
 >MINIMAL  
 also minimal  
   
 bigendian Constant bigendian  bigendian Constant bigendian
   
 : here there ;  : here there ;
 : equ constant ;  : equ constant ;
 : mark there constant ;  : mark there constant ;
Line 2165  bigendian Constant bigendian Line 3366  bigendian Constant bigendian
 : >tempdp >tempdp ;  : >tempdp >tempdp ;
 : tempdp> tempdp> ;  : tempdp> tempdp> ;
 : const constflag on ;  : const constflag on ;
 : warnings name 3 = 0= twarnings ! drop ;  
   : Redefinitions-start
   \G Starts a redefinition section. Warnings are disabled and
   \G existing ghosts are reused. This is used in the kernel
   \G where ( and \ and the like are redefined
     twarnings off warnings off reuse-ghosts on ;
   
   : Redefinitions-end
   \G Ends a redefinition section. Warnings are enabled again.
     twarnings on warnings on reuse-ghosts off ;
   
   : warnings name 3 = 
     IF twarnings off warnings off ELSE twarnings on warnings on THEN drop ;
   
 : | ;  : | ;
 \ : | NoHeaderFlag on ; \ This is broken (damages the last word)  \ : | NoHeaderFlag on ; \ This is broken (damages the last word)
   
Line 2176  bigendian Constant bigendian Line 3390  bigendian Constant bigendian
 also forth   also forth 
 [IFDEF] Label           : Label defempty? Label ; [THEN]   [IFDEF] Label           : Label defempty? Label ; [THEN] 
 [IFDEF] start-macros    : start-macros defempty? start-macros ; [THEN]  [IFDEF] start-macros    : start-macros defempty? start-macros ; [THEN]
 [IFDEF] builttag        : builttag builttag ;   [THEN]  \ [IFDEF] builttag      : builttag builttag ;   [THEN]
 previous  previous
   
 : s" [char] " parse s-buffer place s-buffer count ; \ for environment?  : s" [char] " parse s-buffer place s-buffer count ; \ for environment?
 : + + ;  : + + ;
 : 1+ 1 + ;  : 1+ 1 + ;
 : 2+ 2 + ;  : 2+ 2 + ;
 : or or ;  
 : 1- 1- ;  : 1- 1- ;
 : - - ;  : - - ;
 : and and ;  : and and ;
Line 2200  previous Line 3413  previous
 : 0=   0= ;  : 0=   0= ;
 : lshift lshift ;  : lshift lshift ;
 : 2/ 2/ ;  : 2/ 2/ ;
 : . . ;  \ : . . ;
   
 : all-words    ['] false    IS skip? ;  : all-words    ['] forced?    IS skip? ;
 : needed-words ['] needed?  IS skip? ;  : needed-words ['] needed?  IS skip? ;
 : undef-words  ['] defined2? IS skip? ;  : undef-words  ['] defined2? IS skip? ;
 : skipdef skipdef ;  : skipdef skipdef ;
Line 2211  previous Line 3424  previous
 : \G T-\G ; immediate  : \G T-\G ; immediate
 : (  postpone ( ;  immediate  : (  postpone ( ;  immediate
 : include bl word count included ;  : include bl word count included ;
   : included swap >image swap included ;
 : require require ;  : require require ;
   : needs require ;
 : .( [char] ) parse type ;  : .( [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 [g'] decimal >exec2 @ ?dup IF EXECUTE THEN ;
 : hex           hex ;  : hex           hex [g'] hex >exec2 @ ?dup IF EXECUTE THEN ;
   
 : tudp          T tudp H ;  \ : tudp          X tudp ;
 : tup           T tup H ;  \ : tup           X tup ;
   
 : doc-off       false T to-doc H ! ;  : doc-off       false to-doc ! ;
 : doc-on        true  T to-doc H ! ;  : doc-on        true  to-doc ! ;
 [IFDEF] dbg : dbg dbg ; [THEN]  
   
 minimal  : declareunique ( "name" -- )
   \G Sets the unique flag for a ghost. The assembler output
   \G generates labels with the ghostname concatenated with the address
   \G while cross-compiling. The address is concatenated
   \G because we have double occurences of the same name.
   \G If we want to reference the labels from the assembler or C
   \G code we declare them unique, so the address is skipped.
     Ghost >ghost-flags dup @ <unique> or swap ! ;
   
   \ [IFDEF] dbg : dbg dbg ; [THEN]
   
 \ for debugging...  \ for debugging...
 : order         order ;  \ : dbg dbg ;
 : hwords         words ;  : horder         order ;
 : words         also ghosts words previous ;  : hwords        words ;
   \ : words       also ghosts 
   \                words previous ;
 : .s            .s ;  : .s            .s ;
 : bye           bye ;  : bye           bye ;
   
   \ dummy
   : group 0 word drop ;
   
 \ turnkey direction  \ turnkey direction
 : H forth ; immediate  : H forth ; immediate
 : T minimal ; immediate  : T minimal ; immediate
 : G ghosts ; immediate  : G ghosts ; immediate
   
 : turnkey  0 set-order also Target definitions  
            also Minimal also ;  
   
 \ these ones are pefered:  \ these ones are pefered:
   
 : lock   turnkey ;  
 : unlock previous forth also cross ;  : unlock previous forth also cross ;
   
 : [[ also unlock ;  \ also minimal
 : ]] previous previous ;  >cross
   
   : turnkey 
      ghosts-wordlist 1 set-order
      also target definitions
      also Minimal also ;
   
   >minimal
   
   : [[+++
     turnkey unlock ;
   
 unlock definitions also minimal  unlock definitions also minimal
 : lock   lock ;  
 lock  : lock   turnkey ;
   
   Defer +++]]-hook
   : +++]] +++]]-hook lock ;
   
   LOCK
   \ load cross compiler extension defined in mach file
   
   UNLOCK >CROSS
   
   [IFDEF] extend-cross extend-cross [THEN]
   
   LOCK
   
   
   

Removed from v.1.76  
changed lines
  Added in v.1.111


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