Diff for /gforth/cross.fs between versions 1.52 and 1.96

version 1.52, 1997/08/31 19:31:28 version 1.96, 2001/03/18 22:20:26
Line 1 Line 1
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
   
 \ Copyright (C) 1995 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 17 Line 17
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
 \ Log:  0 
 \       changed in ; [ to state off           12may93jaw  [IF]
 \       included place +place                 12may93jaw  
 \       for a created word (variable, constant...)  
 \       is now an alias in the target voabulary.  
 \       this means it is no longer necessary to  
 \       switch between vocabularies for variable  
 \       initialization                        12may93jaw  
 \       discovered error in DOES>  
 \       replaced !does with (;code)           16may93jaw  
 \       made complete redesign and  
 \       introduced two vocs method  
 \       to be asure that the right words  
 \       are found                             08jun93jaw  
 \       btw:  ! works not with 16 bit  
 \             targets                         09jun93jaw  
 \       added: 2user and value                11jun93jaw  
   
 \       needed? works better now!!!             01mar97jaw  
 \       mach file is only loaded into target  
 \       cell corrected  
 \       romable extansions                      27apr97-5jun97jaw  
   
   ToDo:
   Crossdoc destination ./doc/crossdoc.fd makes no sense when
   cross.fs is uses seperately. jaw
   Do we need this char translation with >address and in branchoffset? 
   (>body also affected) jaw
   Clean up mark> and >resolve stuff jaw
   
 hex     \ the defualt base for the cross-compiler is hex !!  [THEN]
 Warnings off  
   
 \ words that are generaly useful  hex
   
 : >wordlist ( vocabulary-xt -- wordlist-struct )  \ debugging for compiling
   also execute get-order swap >r 1- set-order r> ;  
   
 : umax 2dup u< IF swap THEN drop ;  \ print stack at each colon definition
 : umin 2dup u> IF swap THEN drop ;  \ : : save-input cr bl word count type restore-input throw .s : ;
   
 : string, ( c-addr u -- )  \ print stack at each created word
     \ puts down string as cstring  \ : create save-input cr bl word count type restore-input throw .s create ;
     dup c, here swap chars dup allot move ;  
   
 : SetValue ( n -- <name> )  
 \G Same behaviour as "Value" when the <name> is not defined  
 \G Same behaviour as "to" when <name> is defined  
 \G SetValue searches in the current vocabulary  
  save-input bl word >r restore-input throw r> count  
  get-current search-wordlist  
  IF bl word drop >body ! ELSE Value THEN ;  
   
 : DefaultValue ( n -- <name> )  \ \ -------------  Setup Vocabularies
 \G Same behaviour as "Value" when the <name> is not defined  
 \G SetValue searches in the current vocabulary  
  save-input bl word >r restore-input throw r> count  
  get-current search-wordlist  
  IF bl word drop drop drop ELSE Value THEN ;  
   
 hex  \ Remark: Vocabulary is not ANS, but it should work...
   
 Vocabulary Cross  Vocabulary Cross
 Vocabulary Target  Vocabulary Target
 Vocabulary Ghosts  Vocabulary Ghosts
 VOCABULARY Minimal  Vocabulary Minimal
 only Forth also Target also also  only Forth also Target also also
 definitions Forth  definitions Forth
   
 : T  previous Cross also Target ; immediate  : T  previous Ghosts also Target ; immediate
 : G  Ghosts ; immediate  : G  Ghosts ; immediate
 : H  previous Forth also Cross ; immediate  : H  previous Forth also Cross ; immediate
   
 forth definitions  forth definitions
   
 : T  previous Cross also Target ; immediate  : T  previous Ghosts also Target ; immediate
 : G  Ghosts ; immediate  : G  Ghosts ; immediate
   
 : >cross  also Cross definitions previous ;  : >cross  also Cross definitions previous ;
Line 99  H Line 70  H
   
 >CROSS  >CROSS
   
   \ find out whether we are compiling with gforth
   
   : defined? bl word find nip ;
   defined? emit-file defined? toupper and \ drop 0
   [IF]
   \ use this in a gforth system
   : \GFORTH ; immediate
   : \ANSI postpone \ ; immediate
   [ELSE]
   : \GFORTH postpone \ ; immediate
   : \ANSI ; immediate
   [THEN]
   
   \ANSI : [IFUNDEF] defined? 0= postpone [IF] ; immediate
   \ANSI : [IFDEF] defined? postpone [IF] ; immediate
   0 \ANSI drop 1
   [IF]
   : \G postpone \ ; immediate
   : rdrop postpone r> postpone drop ; immediate
   : name bl word count ;
   : bounds over + swap ;
   : scan >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN rdrop ;
   : linked here over @ , swap ! ;
   : alias create , DOES> @ EXECUTE ;
   : defer ['] noop alias ;
   : is state @ 
     IF ' >body postpone literal postpone ! 
     ELSE ' >body ! THEN ; immediate
   : 0>= 0< 0= ;
   : d<> rot <> -rot <> or ;
   : toupper dup [char] a [char] z 1+ within IF [char] A [char] a - + THEN ;
   Variable ebuf
   : emit-file ( c fd -- ior ) swap ebuf c! ebuf 1 chars rot write-file ;
   0a Constant #lf
   0d Constant #cr
   
   [IFUNDEF] Warnings Variable Warnings [THEN]
   
   \ \ Number parsing                                      23feb93py
   
   \ number? number                                       23feb93py
   
   Variable dpl
   
   hex
   Create bases   10 ,   2 ,   A , 100 ,
   \              16     2    10   character
   
   \ !! protect BASE saving wrapper against exceptions
   : getbase ( addr u -- addr' u' )
       over c@ [char] $ - dup 4 u<
       IF
           cells bases + @ base ! 1 /string
       ELSE
           drop
       THEN ;
   
   : sign? ( addr u -- addr u flag )
       over c@ [char] - =  dup >r
       IF
           1 /string
       THEN
       r> ;
   
   : s>unumber? ( addr u -- ud flag )
       over [char] ' =
       IF  \ a ' alone is rather unusual :-)
           drop char+ c@ 0 true EXIT 
       THEN
       base @ >r  dpl on  getbase
       0. 2swap
       BEGIN ( d addr len )
           dup >r >number dup
       WHILE \ there are characters left
           dup r> -
       WHILE \ the last >number parsed something
           dup 1- dpl ! over c@ [char] . =
       WHILE \ the current char is '.'
           1 /string
       REPEAT  THEN \ there are unparseable characters left
           2drop false
       ELSE
           rdrop 2drop true
       THEN
       r> base ! ;
   
   \ ouch, this is complicated; there must be a simpler way - anton
   : s>number? ( addr len -- d f )
       \ converts string addr len into d, flag indicates success
       sign? >r
       s>unumber?
       0= IF
           rdrop false
       ELSE \ no characters left, all ok
           r>
           IF
               dnegate
           THEN
           true
       THEN ;
   
   : s>number ( addr len -- d )
       \ don't use this, there is no way to tell success
       s>number? drop ;
   
   : snumber? ( c-addr u -- 0 / n -1 / d 0> )
       s>number? 0=
       IF
           2drop false  EXIT
       THEN
       dpl @ dup 0< IF
           nip
       ELSE
           1+
       THEN ;
   
   : number? ( string -- string 0 / n -1 / d 0> )
       dup >r count snumber? dup if
           rdrop
       else
           r> swap
       then ;
   
   : number ( string -- d )
       number? ?dup 0= abort" ?"  0<
       IF
           s>d
       THEN ;
   
   [THEN]
   
   hex     \ the defualt base for the cross-compiler is hex !!
   \ Warnings off
   
   \ words that are generaly useful
   
   : KB  400 * ;
   : >wordlist ( vocabulary-xt -- wordlist-struct )
     also execute get-order swap >r 1- set-order r> ;
   
   : umax 2dup u< IF swap THEN drop ;
   : umin 2dup u> IF swap THEN drop ;
   
   : string, ( c-addr u -- )
       \ puts down string as cstring
       dup c, here swap chars dup allot move ;
   
   : ," [char] " parse string, ;
   
   : SetValue ( n -- <name> )
   \G Same behaviour as "Value" if the <name> is not defined
   \G Same behaviour as "to" if <name> is defined
   \G SetValue searches in the current vocabulary
     save-input bl word >r restore-input throw r> count
     get-current search-wordlist
     IF    drop >r
           \ we have to set current to be topmost context wordlist
           get-order get-order get-current swap 1+ set-order
           r> ['] to execute
           set-order
     ELSE Value THEN ;
   
   : DefaultValue ( n -- <name> )
   \G Same behaviour as "Value" if the <name> is not defined
   \G DefaultValue searches in the current vocabulary
    save-input bl word >r restore-input throw r> count
    get-current search-wordlist
    IF bl word drop 2drop ELSE Value THEN ;
   
   hex
   
 \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are  \ 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 111  H Line 253  H
   
 \ Begin CROSS COMPILER:  \ Begin CROSS COMPILER:
   
   \ debugging
   
   0 [IF]
   
   This implements debugflags for the cross compiler and the compiled
   images. It works identical to the has-flags in the environment.
   The debugflags are defined in a vocabluary. If the word exists and
   its value is true, the flag is switched on.
   
   [THEN]
   
   >CROSS
   
   Vocabulary debugflags   \ debug flags for cross
   also debugflags get-order over
   Constant debugflags-wl
   set-order previous
   
   : DebugFlag
     get-current >r debugflags-wl set-current
     SetValue
     r> set-current ;
   
   : Debug? ( adr u -- flag )
   \G return true if debug flag is defined or switched on
     debugflags-wl search-wordlist
     IF EXECUTE
     ELSE false THEN ;
   
   : D? ( <name> -- flag )
   \G return true if debug flag is defined or switched on
   \G while compiling we do not return the current value but
     bl word count debug? ;
   
   : [d?]
   \G compile the value-xt so the debug flag can be switched
   \G the flag must exist!
     bl word count debugflags-wl search-wordlist
     IF    compile,
     ELSE  -1 ABORT" unknown debug flag"
           \ POSTPONE false 
     THEN ; immediate
   
   \ \ --------------------        source file
   
   decimal
   
   Variable cross-file-list
   0 cross-file-list !
   Variable target-file-list
   0 target-file-list !
   Variable host-file-list
   0 host-file-list !
   
   cross-file-list Value file-list
   0 Value source-desc
   
   \ file loading
   
   : >fl-id   1 cells + ;
   : >fl-name 2 cells + ;
   
   Variable filelist 0 filelist !
   Create NoFile ," #load-file#"
   
   : loadfile ( -- adr )
     source-desc ?dup IF >fl-name ELSE NoFile THEN ;
   
   : sourcefilename ( -- adr len ) 
     loadfile count ;
   
   \ANSI : sourceline# 0 ;
   
   \ \ --------------------        path handling from kernel/paths.fs
   
   \ paths.fs path file handling                                    03may97jaw
   
   \ -Changing the search-path:
   \ fpath+ <path>         adds a directory to the searchpath
   \ fpath= <path>|<path>  makes complete now searchpath
   \                       seperator is |
   \ .fpath                displays the search path
   \ remark I: 
   \ a ./ in the beginning of filename is expanded to the directory the
   \ current file comes from. ./ can also be included in the search-path!
   \ ~+/ loads from the current working directory
   
   \ remark II:
   \ if there is no sufficient space for the search path increase it!
   
   
   \ -Creating custom paths:
   
   \ It is possible to use the search mechanism on yourself.
   
   \ Make a buffer for the path:
   \ create mypath 100 chars ,     \ maximum length (is checked)
   \               0 ,             \ real len
   \               100 chars allot \ space for path
   \ use the same functions as above with:
   \ mypath path+ 
   \ mypath path=
   \ mypath .path
   
   \ do a open with the search path:
   \ open-path-file ( adr len path -- fd adr len ior )
   \ the file is opened read-only; if the file is not found an error is generated
   
   \ questions to: wilke@jwdt.com
   
   [IFUNDEF] +place
   : +place ( adr len adr )
           2dup >r >r
           dup c@ char+ + swap move
           r> r> dup c@ rot + swap c! ;
   [THEN]
   
   [IFUNDEF] place
   : place ( c-addr1 u c-addr2 )
           2dup c! char+ swap move ;
   [THEN]
   
   \ if we have path handling, use this and the setup of it
   [IFUNDEF] open-fpath-file
   
   create sourcepath 1024 chars , 0 , 1024 chars allot \ !! make this dynamic
   sourcepath value fpath
   
   : also-path ( adr len path^ -- )
     >r
     \ len check
     r@ cell+ @ over + r@ @ u> ABORT" path buffer too small!"
     \ copy into
     tuck r@ cell+ dup @ cell+ + swap cmove
     \ make delimiter
     0 r@ cell+ dup @ cell+ + 2 pick + c! 1 + r> cell+ +!
     ;
   
   : only-path ( adr len path^ -- )
     dup 0 swap cell+ ! also-path ;
   
   : path+ ( path-addr  "dir" -- ) \ gforth
       \G Add the directory @var{dir} to the search path @var{path-addr}.
       name rot also-path ;
   
   : fpath+ ( "dir" ) \ gforth
       \G Add directory @var{dir} to the Forth search path.
       fpath path+ ;
   
   : path= ( path-addr "dir1|dir2|dir3" ) \ gforth
       \G Make a complete new search path; the path separator is |.
       name 2dup bounds ?DO i c@ [char] | = IF 0 i c! THEN LOOP
       rot only-path ;
   
   : fpath= ( "dir1|dir2|dir3" ) \ gforth
       \G Make a complete new Forth search path; the path separator is |.
       fpath path= ;
   
   : path>counted  cell+ dup cell+ swap @ ;
   
   : next-path ( adr len -- adr2 len2 )
     2dup 0 scan
     dup 0= IF     2drop 0 -rot 0 -rot EXIT THEN
     >r 1+ -rot r@ 1- -rot
     r> - ;
   
   : previous-path ( path^ -- )
     dup path>counted
     BEGIN tuck dup WHILE repeat ;
   
   : .path ( path-addr -- ) \ gforth
       \G Display the contents of the search path @var{path-addr}.
       path>counted
       BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ;
   
   : .fpath ( -- ) \ gforth
       \G Display the contents of the Forth search path.
       fpath .path ;
   
   : absolut-path? ( addr u -- flag ) \ gforth
       \G A path is absolute if it starts with a / or a ~ (~ expansion),
       \G or if it is in the form ./*, extended regexp: ^[/~]|./, or if
       \G it has a colon as second character ("C:...").  Paths simply
       \G containing a / are not absolute!
       2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....
       over c@ [char] / = >r
       over c@ [char] ~ = >r
       \ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic
       2 min S" ./" compare 0=
       r> r> r> or or or ;
   
   Create ofile 0 c, 255 chars allot
   Create tfile 0 c, 255 chars allot
   
   : pathsep? dup [char] / = swap [char] \ = or ;
   
   : need/   ofile dup c@ + c@ pathsep? 0= IF s" /" ofile +place THEN ;
   
   : extractpath ( adr len -- adr len2 )
     BEGIN dup WHILE 1-
           2dup + c@ pathsep? IF EXIT THEN
     REPEAT ;
   
   : remove~+ ( -- )
       ofile count 3 min s" ~+/" compare 0=
       IF
           ofile count 3 /string ofile place
       THEN ;
   
   : expandtopic ( -- ) \ stack effect correct? - anton
       \ expands "./" into an absolute name
       ofile count 2 min s" ./" compare 0=
       IF
           ofile count 1 /string tfile place
           0 ofile c! sourcefilename extractpath ofile place
           ofile c@ IF need/ THEN
           tfile count over c@ pathsep? IF 1 /string THEN
           ofile +place
       THEN ;
   
   : compact.. ( adr len -- adr2 len2 )
       \ deletes phrases like "xy/.." out of our directory name 2dec97jaw
       over swap
       BEGIN  dup  WHILE
           dup >r '/ scan 2dup 4 min s" /../" compare 0=
           IF
               dup r> - >r 4 /string over r> + 4 -
               swap 2dup + >r move dup r> over -
           ELSE
               rdrop dup 1 min /string
           THEN
       REPEAT  drop over - ;
   
   : reworkdir ( -- )
     remove~+
     ofile count compact..
     nip ofile c! ;
   
   : open-ofile ( -- fid ior )
       \G opens the file whose name is in ofile
       expandtopic reworkdir
       ofile count r/o open-file ;
   
   : check-path ( adr1 len1 adr2 len2 -- fd 0 | 0 <>0 )
     0 ofile ! >r >r ofile place need/
     r> r> ofile +place
     open-ofile ;
   
   : open-path-file ( addr1 u1 path-addr -- wfileid addr2 u2 0 | ior ) \ gforth
       \G Look in path @var{path-addr} for the file specified by @var{addr1 u1}.
       \G If found, the resulting path and an open file descriptor
       \G are returned. If the file is not found, @var{ior} is non-zero.
     >r
     2dup absolut-path?
     IF    rdrop
           ofile place open-ofile
           dup 0= IF >r ofile count r> THEN EXIT
     ELSE  r> path>counted
           BEGIN  next-path dup
           WHILE  5 pick 5 pick check-path
           0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN
     REPEAT
           2drop 2drop 2drop -38
     THEN ;
   
   : open-fpath-file ( addr1 u1 -- wfileid addr2 u2 0 | ior ) \ gforth
       \G Look in the Forth search path for the file specified by @var{addr1 u1}.
       \G If found, the resulting path and an open file descriptor
       \G are returned. If the file is not found, @var{ior} is non-zero.
       fpath open-path-file ;
   
   fpath= ~+
   
   [THEN]
   
   \ \ --------------------        include require                 13may99jaw
   
   >CROSS
   
   : add-included-file ( adr len -- adr )
     dup >fl-name char+ allocate throw >r
     file-list @ r@ ! r@ file-list !
     r@ >fl-name place r> ;
   
   : included? ( c-addr u -- f )
     file-list
     BEGIN @ dup
     WHILE >r 2dup r@ >fl-name count compare 0=
           IF rdrop 2drop true EXIT THEN
           r>
     REPEAT
     2drop drop false ;    
   
   false DebugFlag showincludedfiles
   
   : included1 ( fd adr u -- )
   \ include file adr u / fd
   \ we don't use fd with include-file, because the forth system
   \ doesn't know the name of the file to get a nice error report
     [d?] showincludedfiles
     IF    cr ." Including: " 2dup type ." ..." THEN
     rot close-file throw
     source-desc >r
     add-included-file to source-desc 
     sourcefilename
     ['] included catch
     r> to source-desc 
     throw ;
   
   : included ( adr len -- )
           cross-file-list to file-list
           open-fpath-file throw 
           included1 ;
   
   : required ( adr len -- )
           cross-file-list to file-list
           open-fpath-file throw \ 2dup cr ." R:" type
           2dup included?
           IF      2drop close-file throw
           ELSE    included1
           THEN ;
   
   : include bl word count included ;
   
   : require bl word count required ;
   
   0 [IF]
   
   also forth definitions previous
   
   : included ( adr len -- ) included ;
   
   : required ( adr len -- ) required ;
   
   : include include ;
   
   : require require ;
   
   [THEN]
   
   >CROSS
   hex
   
 \ \ --------------------        Error Handling                  05aug97jaw  \ \ --------------------        Error Handling                  05aug97jaw
   
Line 123  also forth definitions  \ these values m Line 606  also forth definitions  \ these values m
 false DefaultValue stack-warn            \ check on empty stack at any definition  false DefaultValue stack-warn            \ check on empty stack at any definition
 false DefaultValue create-forward-warn   \ warn on forward declaration of created words  false DefaultValue create-forward-warn   \ warn on forward declaration of created words
   
 [IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN]  
 [IFUNDEF] DebugMaskCross  Variable DebugMaskCross  0 DebugMaskCross  ! [THEN]  
   
 previous >CROSS  previous >CROSS
   
   : .dec
     base @ decimal swap . base ! ;
   
 : .sourcepos  : .sourcepos
   cr sourcefilename type ." :"    cr sourcefilename type ." :"
   base @ decimal sourceline# . base ! ;    sourceline# .dec ;
   
 : warnhead  : warnhead
 \G display error-message head  \G display error-message head
Line 145  stack-warn [IF] Line 628  stack-warn [IF]
 : defempty? ; immediate  : defempty? ; immediate
 [THEN]  [THEN]
   
   
 \ \ GhostNames Ghosts                                  9may93jaw  \ \ GhostNames Ghosts                                  9may93jaw
   
 \ second name source to search trough list  \ second name source to search trough list
Line 154  VARIABLE GhostNames Line 636  VARIABLE GhostNames
 0 GhostNames !  0 GhostNames !
   
 : GhostName ( -- addr )  : GhostName ( -- addr )
     here GhostNames @ , GhostNames ! here 0 ,      align here GhostNames @ , GhostNames ! here 0 ,
     bl word count      bl word count
     \ 2dup type space      \ 2dup type space
     string, \ !! cfalign ?      string, \ !! cfalign ?
Line 172  VARIABLE VocTemp Line 654  VARIABLE VocTemp
 hex  hex
 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>
   
 \ iForth makes only immediate directly after create  \  Compiler States
 \ make atonce trick! ?  
   
 Variable atonce atonce off  Variable comp-state
   0 Constant interpreting
   1 Constant compiling
   2 Constant resolving
   3 Constant assembling
   
   Defer lit, ( n -- )
   Defer alit, ( n -- )
   
 : NoExec true ABORT" CROSS: Don't execute ghost" ;  Defer branch, ( target-addr -- )        \ compiles a branch
   Defer ?branch, ( target-addr -- )       \ compiles a ?branch
   Defer branchmark, ( -- branch-addr )    \ reserves room for a branch
   Defer ?branchmark, ( -- branch-addr )   \ reserves room for a ?branch
   Defer ?domark, ( -- branch-addr )       \ reserves room for a ?do branch
   Defer branchto, ( -- )                  \ actual program position is target of a branch (do e.g. alignment)
   Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
   Defer branchfrom, ( -- )                \ ?!
   Defer branchtomark, ( -- target-addr )  \ marks a branch destination
   
   Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position
   Defer prim, ( tcfa -- )                 \ compiles a primitive invocation
                                           \ at current position
   Defer colonmark, ( -- addr )            \ marks a colon call
   Defer colon-resolve ( tcfa addr -- )
   
   Defer addr-resolve ( target-addr addr -- )
   Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
   
 : GhostHeader <fwd> , 0 , ['] NoExec , ;  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]
   
   \ ghost structure
   
 : >magic ;              \ type of ghost  : >magic ;              \ type of ghost
 : >link cell+ ;         \ pointer where ghost is in target, or if unresolved  : >link cell+ ;         \ pointer where ghost is in target, or if unresolved
                         \ points to the where we have to resolve (linked-list)                          \ points to the where we have to resolve (linked-list)
 : >exec cell+ cell+ ;   \ execution symantics (while target compiling) of ghost  : >exec cell+ cell+ ;   \ execution symantics (while target compiling) of ghost
 : >end 3 cells + ;      \ room for additional tags  : >comp 3 cells + ;     \ compilation semantics
   : >end 4 cells + ;      \ room for additional tags
                         \ for builder (create, variable...) words the                          \ for builder (create, variable...) words the
                         \ execution symantics of words built are placed here                          \ execution symantics of words built are placed here
   
   \ resolve structure
   
   : >next ;               \ link to next field
   : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address, 2: doer
   : >taddr cell+ cell+ ;  
   : >ghost 3 cells + ;
   : >file 4 cells + ;
   : >line 5 cells + ;
   
   \ refer variables
   
 Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>  Variable 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
   
   : (refered) ( ghost addr tag -- )
   \G creates a reference to ghost at address taddr
       rot >r here r@ >link @ , r> >link ! 
       ( taddr tag ) ,
       ( taddr ) , 
       last-header-ghost @ , 
       loadfile , 
       sourceline# , 
     ;
   
   \ iForth makes only immediate directly after create
   \ make atonce trick! ?
   
   Variable atonce atonce off
   
   : NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;
   
   : is-forward   ( ghost -- )
     colonmark, 0 (refered) ; \ compile space for call
   
   : GhostHeader <fwd> , 0 , ['] NoExec , ['] is-forward , ;
   
 : Make-Ghost ( "name" -- ghost )  : Make-Ghost ( "name" -- ghost )
   >in @ GhostName swap >in !    >in @ GhostName swap >in !
   <T Create atonce @ IF immediate atonce off THEN    <T Create atonce @ IF immediate atonce off THEN
Line 206  Variable last-header-ghost \ last ghost Line 757  Variable last-header-ghost \ last ghost
   
 : gfind   ( string -- ghost true/1 / string false )  : gfind   ( string -- ghost true/1 / 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 [ ' ghosts >wordlist ] Literal search-wordlist
   dup IF >r >body nip r>  THEN ;    dup IF >r >body nip r>  THEN ;
   
 : gdiscover ( xt -- ghost true | xt false )  : gdiscover ( xt -- ghost true | xt false )
Line 223  VARIABLE Already Line 774  VARIABLE Already
   
 : ghost   ( "name" -- ghost )  : ghost   ( "name" -- ghost )
   Already off    Already off
   >in @  bl word gfind   IF  Already on 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 )
Line 231  VARIABLE Already Line 782  VARIABLE Already
   BEGIN @ dup    BEGIN @ dup
   WHILE 2dup cell+ @ =    WHILE 2dup cell+ @ =
   UNTIL nip 2 cells + count    UNTIL nip 2 cells + count
   ELSE  2drop true abort" CROSS: Ghostnames inconsistent"    ELSE  2drop 
           \ true abort" CROSS: Ghostnames inconsistent"
           s" ?!?!?!"
   THEN ;    THEN ;
   
 ' >ghostname ALIAS @name  : .ghost ( ghost -- ) >ghostname type ;
   
   \ ' >ghostname ALIAS @name
   
 : forward? ( ghost -- flag )  : forward? ( ghost -- flag )
   >magic @ <fwd> = ;    >magic @ <fwd> = ;
   
   : undefined? ( ghost -- flag )
     >magic @ dup <fwd> = swap <skip> = or ;
   
 \ Predefined ghosts                                    12dec92py  \ Predefined ghosts                                    12dec92py
   
 ghost 0=                                        drop  ghost 0=                                        drop
Line 250  ghost (next) Line 808  ghost (next)
 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    ghost :dodefer  ghost :dofield  2drop drop
 ghost over      ghost =         ghost drop      2drop drop  ghost over      ghost =         ghost drop      2drop drop
 ghost - drop  ghost call      ghost useraddr  ghost execute   2drop drop
   ghost +         ghost -         ghost @         2drop drop
   ghost 2drop drop
   ghost 2dup drop
   
 \ \ Parameter for target systems                         06oct92py  \ \ Parameter for target systems                         06oct92py
   
Line 268  VARIABLE env-current \ save information Line 830  VARIABLE env-current \ save information
   
 >TARGET  >TARGET
   
 : environment?  : environment? ( adr len -- [ x ] true | false )
   target-environment search-wordlist     target-environment search-wordlist 
   IF execute true ELSE false THEN ;    IF execute true ELSE false THEN ;
   
 : e? name T environment? H 0= ABORT" environment variable not defined!" ;  : e? bl word count T environment? H 0= ABORT" environment variable not defined!" ;
   
 : has? name T environment? H IF ELSE false THEN ;  : has?  bl word count T environment? H 
           IF      \ environment variable is present, return its value
           ELSE    \ environment variable is not present, return false
                   false \ debug true ABORT" arg" 
           THEN ;
   
 : $has? T environment? H IF ELSE false THEN ;  : $has? T environment? H IF ELSE false THEN ;
   
   >ENVIRON get-order get-current swap 1+ set-order
   true SetValue compiler
   true SetValue cross
   true SetValue standard-threading
   >TARGET previous
   
   0
   [IFDEF] mach-file mach-file count 1 [THEN]
   [IFDEF] machine-file machine-file 1 [THEN]
   [IF]    included hex drop
   [ELSE]  cr ." No machine description!" ABORT 
   [THEN]
   
 >ENVIRON  >ENVIRON
 true Value cross  
 >TARGET  
   
 mach-file count included hex  T has? ec H
   [IF]
   false DefaultValue relocate
   false DefaultValue file
   false DefaultValue OS
   false DefaultValue prims
   false DefaultValue floating
   false DefaultValue glocals
   false DefaultValue dcomps
   false DefaultValue hash
   false DefaultValue xconds
   false DefaultValue header
   false DefaultValue backtrace
   false DefaultValue new-input
   [THEN]
   
 >TARGET  true DefaultValue interpreter
   true DefaultValue ITC
   false DefaultValue rom
   true DefaultValue standardthreading
   
 [IFUNDEF] has-interpreter true Value has-interpreter [THEN]  >TARGET
 [IFUNDEF] itc true Value itc [THEN]  s" relocate" T environment? H 
 [IFUNDEF] has-rom false Value has-rom [THEN]  [IF]    SetValue NIL
   [ELSE]  >ENVIRON T NIL H SetValue relocate
   [THEN]
   
 >CROSS  >CROSS
   
 \ \ Create additional parameters                         19jan95py  \ \ Create additional parameters                         19jan95py
   
   \ currently cross only works for host machines with address-unit-bits
   \ eual to 8 because of s! and sc!
   \ but I start to query the environment just to modularize a little bit
   
   : check-address-unit-bits ( -- )        
   \       s" ADDRESS-UNIT-BITS" environment?
   \       IF 8 <> ELSE true THEN
   \       ABORT" ADDRESS-UNIT-BITS unknown or not equal to 8!"
   
   \       shit, this doesn't work because environment? is only defined for 
   \       gforth.fi and not kernl???.fi
           ;
   
   check-address-unit-bits
   8 Constant bits/byte    \ we define: byte is address-unit
   
   1 bits/byte lshift Constant maxbyte 
   \ this sets byte size for the target machine, (probably right guess) jaw
   
 T  T
 NIL                Constant TNIL  NIL                     Constant TNIL
 cell               Constant tcell  cell                    Constant tcell
 cell<<             Constant tcell<<  cell<<                  Constant tcell<<
 cell>bit           Constant tcell>bit  cell>bit                Constant tcell>bit
 bits/byte          Constant tbits/byte  bits/char               Constant tbits/char
 float              Constant tfloat  bits/char H bits/byte T /      
 1 bits/byte lshift Constant maxbyte                          Constant tchar
   float                   Constant tfloat
   1 bits/char lshift      Constant tmaxchar
   [IFUNDEF] bits/byte
   8                       Constant tbits/byte
   [ELSE]
   bits/byte               Constant tbits/byte
   [THEN]
 H  H
   tbits/char bits/byte /  Constant tbyte
   
   
 \ Variables                                            06oct92py  \ Variables                                            06oct92py
   
Line 317  Variable bit$ Line 941  Variable bit$
 Variable headers-named 0 headers-named !  Variable headers-named 0 headers-named !
 Variable user-vars 0 user-vars !  Variable user-vars 0 user-vars !
   
 \ Memory initialisation                                05dec92py  : target>bitmask-size ( u1 -- u2 )
     1- tcell>bit rshift 1+ ;
 [IFDEF] Memory \ Memory is a bigFORTH feature  
    also Memory  
    : initmem ( var len -- )  
      2dup swap handle! >r @ r> erase ;  
    toss  
 [ELSE]  
    : initmem ( var len -- )  
      tuck allocate abort" CROSS: No memory for target"  
      ( len var adr ) dup rot !  
      ( len adr ) swap erase ;  
 [THEN]  
   
 \ MakeKernal                                           12dec92py  
   
 : makekernel ( targetsize -- targetsize )  
   bit$  over 1- tcell>bit rshift 1+ initmem  
   image over initmem ;  
   
 >MINIMAL  : allocatetarget ( size --- adr )
 : makekernel makekernel ;    dup allocate ABORT" CROSS: No memory for target"
     swap over swap erase ;
   
   \ \ memregion.fs
 >CROSS  
   
 \ memregion.fs  
   
   
 Variable last-defined-region    \ pointer to last defined region  Variable last-defined-region    \ pointer to last defined region
Line 352  Variable mirrored-link          \ linked Line 957  Variable mirrored-link          \ linked
 0 dup mirrored-link ! region-link !  0 dup mirrored-link ! region-link !
   
   
   : >rname 6 cells + ;
   : >rbm   5 cells + ;
   : >rmem  4 cells + ;
   : >rlink 3 cells + ;
 : >rdp 2 cells + ;  : >rdp 2 cells + ;
 : >rlen cell+ ;  : >rlen cell+ ;
 : >rstart ;  : >rstart ;
Line 365  Variable mirrored-link          \ linked Line 974  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 name string,          region-link linked 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@ cell+ ! dup r@ ! r> 2 cells + !          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 @ swap cell+ @ 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 @ swap 2 cells + @ over - ;    dup >rstart @ swap >rdp @ over - ;
   
 : area ( region -- startaddr totallen ) \G returns the total area  : area ( region -- startaddr totallen ) \G returns the total area
   dup @ swap cell+ @ ;    dup >rstart @ swap >rlen @ ;
   
 : mirrored                              \G mark a region as mirrored  : mirrored                              \G mark a region as mirrored
   mirrored-link    mirrored-link
   linked last-defined-region @ , ;    align linked last-defined-region @ , ;
   
 : .addr  : .addr ( u -- )
   \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 ! ;
   
Line 399  Variable mirrored-link          \ linked Line 1009  Variable mirrored-link          \ linked
   0 region-link @    0 region-link @
   BEGIN dup WHILE dup @ REPEAT drop    BEGIN dup WHILE dup @ REPEAT drop
   BEGIN dup    BEGIN dup
   WHILE cr 3 cells - >r    WHILE cr
         r@ 4 cells + count tuck type          0 >rlink - >r
           r@ >rname count tuck type
         12 swap - 0 max spaces space          12 swap - 0 max spaces space
         ." Start: " r@ @ dup .addr space          ." Start: " r@ >rstart @ dup .addr space
         ." End: " r@ 1 cells + @ + .addr space          ." End: " r@ >rlen @ + .addr space
         ." DP: " r> 2 cells + @ .addr           ." DP: " r> >rdp @ .addr
   REPEAT drop    REPEAT drop
   s" rom" $has? 0= ?EXIT    s" rom" T $has? H 0= ?EXIT
   cr ." Mirrored:"    cr ." Mirrored:"
   mirrored-link @    mirrored-link @
   BEGIN dup    BEGIN dup
   WHILE space dup cell+ @ 4 cells + count type @    WHILE space dup cell+ @ >rname count type @
   REPEAT drop cr    REPEAT drop cr
   ;    ;
   
Line 422  Variable mirrored-link          \ linked Line 1033  Variable mirrored-link          \ linked
 0 0 region dictionary  0 0 region dictionary
 \ rom area for the compiler  \ rom area for the compiler
   
 has? rom   T has? rom H
 [IF]  [IF]
 0 0 region ram-dictionary mirrored  0 0 region ram-dictionary mirrored
 \ ram area for the compiler  \ ram area for the compiler
Line 440  has? rom Line 1051  has? rom
   
   
 : setup-target ( -- )   \G initialize targets memory space  : setup-target ( -- )   \G initialize targets memory space
   s" rom" $has?    s" rom" T $has? H
   IF  \ check for ram and rom...    IF  \ check for ram and rom...
       address-space area nip        \ address-space area nip 0<>
       ram-dictionary area nip        ram-dictionary area nip 0<>
       rom-dictionary area nip        rom-dictionary area nip 0<>
       and and 0=        and 0=
       ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!"        ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!"
   THEN    THEN
   address-space area nip    address-space area nip
Line 454  has? rom Line 1065  has? rom
   ELSE    ELSE
       dictionary area        dictionary area
   THEN    THEN
   dup 0=    nip 0=
   ABORT" CROSS: define at least address-space or dictionary!!"    ABORT" CROSS: define at least address-space or dictionary!!"
   + makekernel drop ;  
   
 \ switched tdp for rom support                          03jun97jaw    \ allocate target for each region
     region-link
     BEGIN @ dup
     WHILE dup
           0 >rlink - >r
           r@ >rlen @
           IF      \ allocate mem
                   r@ >rlen @ dup
   
                   allocatetarget dup image !
                   r@ >rmem !
   
                   target>bitmask-size allocatetarget
                   dup bit$ !
                   r> >rbm !
   
           ELSE    r> drop THEN
      REPEAT drop ;
   
   \ MakeKernal                                                    22feb99jaw
   
   : makekernel ( targetsize -- targetsize )
     dup dictionary >rlen ! setup-target ;
   
   >MINIMAL
   : makekernel makekernel ;
   >CROSS
   
   \ \ switched tdp for rom support                                03jun97jaw
   
 \ second value is here to store some maximal value for statistics  \ second value is here to store some maximal value for statistics
 \ tempdp is also embedded here but has nothing to do with rom support  \ tempdp is also embedded here but has nothing to do with rom support
Line 492  variable fixed  \ flag: true: no automat Line 1130  variable fixed  \ flag: true: no automat
   
 variable constflag constflag off  variable constflag constflag off
   
   : activate ( region -- )
   \G next code goes to this region
     >rdp to tdp ;
   
 : (switchram)  : (switchram)
   fixed @ ?EXIT has-rom 0= ?EXIT    fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
   ram-dictionary >rdp to tdp ;    ram-dictionary activate ;
   
 : switchram  : switchram
   constflag @    constflag @
   IF constflag off ELSE (switchram) THEN ;    IF constflag off ELSE (switchram) THEN ;
   
 : switchrom  : switchrom
   fixed @ ?EXIT rom-dictionary >rdp to tdp ;    fixed @ ?EXIT rom-dictionary activate ;
   
 : >tempdp ( addr -- )   : >tempdp ( addr -- ) 
   tdp tempdp-save ! tempdp to tdp tdp ! ;    tdp tempdp-save ! tempdp to tdp tdp ! ;
Line 517  variable constflag constflag off Line 1159  variable constflag constflag off
 \ : romstart dup sromdp ! romdp ! ;  \ : romstart dup sromdp ! romdp ! ;
 \ : ramstart dup sramdp ! ramdp ! ;  \ : ramstart dup sramdp ! ramdp ! ;
   
 \ default compilation goed to rom  \ default compilation goes to rom
 \ when romable support is off, only the rom switch is used (!!)  \ when romable support is off, only the rom switch is used (!!)
 >auto  >auto
   
Line 531  variable constflag constflag off Line 1173  variable constflag constflag off
   
 : cell+         tcell + ;  : cell+         tcell + ;
 : cells         tcell<< lshift ;  : cells         tcell<< lshift ;
 : chars         ;  : chars         tchar * ;
 : char+         1 + ;  : char+         tchar + ;
 : floats        tfloat * ;  : floats        tfloat * ;
           
 >CROSS  >CROSS
Line 549  bigendian Line 1191  bigendian
      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     : S@  ( addr -- n )  >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 d>s ;
      : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-
        DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
      : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds
        DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
 [ELSE]  [ELSE]
    : S!  ( n addr -- )  >r s>d r> tcell bounds     : S!  ( n addr -- )  >r s>d r> tcell bounds
      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
    : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-     : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
      : Sc!  ( n addr -- )  >r s>d r> tchar bounds
        DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
      : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds swap 1-
        DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
 [THEN]  [THEN]
   
 >CROSS  : taddr>region ( taddr -- region | 0 )
   \G finds for a target-address the correct region
   \G returns 0 if taddr is not in range of a target memory region
     region-link
     BEGIN @ dup
     WHILE dup >r
           0 >rlink - >r
           r@ >rlen @
           IF      dup r@ borders within
                   IF r> r> drop nip EXIT THEN
           THEN
           r> drop
           r>
     REPEAT
     2drop 0 ;
   
   : (>regionimage) ( taddr -- 'taddr )
     dup
     \ find region we want to address
     taddr>region dup 0= ABORT" Address out of range!"
     >r
     \ calculate offset in region
     r@ >rstart @ -
     \ add regions real address in our memory
     r> >rmem @ + ;
   
 \ 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 565  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 1240  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;  : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
 : +bit ( addr n -- )  >bit over c@ or swap c! ;  : +bit ( addr n -- )  >bit over c@ or swap c! ;
 : -bit ( addr n -- )  >bit invert over c@ and swap c! ;  : -bit ( addr n -- )  >bit invert over c@ and swap c! ;
 : relon ( taddr -- )  bit$ @ swap cell/ +bit ;  
 : reloff ( taddr -- )  bit$ @ swap cell/ -bit ;  : (relon) ( taddr -- )  
     [ [IFDEF] fd-relocation-table ]
     s" +" fd-relocation-table write-file throw
     dup s>d <# #s #> fd-relocation-table write-line throw
     [ [THEN] ]
     bit$ @ swap cell/ +bit ;
   
   : (reloff) ( taddr -- ) 
     [ [IFDEF] fd-relocation-table ]
     s" -" fd-relocation-table write-file throw
     dup s>d <# #s #> fd-relocation-table write-line throw
     [ [THEN] ]
     bit$ @ swap cell/ -bit ;
   
   : (>image) ( taddr -- absaddr ) image @ + ;
   
   DEFER >image
   DEFER relon
   DEFER reloff
   DEFER correcter
   
   T has? relocate H
   [IF]
   ' (relon) IS relon
   ' (reloff) IS reloff
   ' (>image) IS >image
   [ELSE]
   ' drop IS relon
   ' drop IS reloff
   ' (>regionimage) IS >image
   [THEN]
   
 \ Target memory access                                 06oct92py  \ Target memory access                                 06oct92py
   
Line 584  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 1289  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
     \ see kernel.fs      \ see kernel.fs
     dup cfalign+ + ;      dup cfalign+ + ;
   
 >CROSS  
 : >image ( taddr -- absaddr )  image @ + ;  
 >TARGET  
 : @  ( taddr -- w )     >image S@ ;  : @  ( taddr -- w )     >image S@ ;
 : !  ( w taddr -- )     >image S! ;  : !  ( w taddr -- )     >image S! ;
 : c@ ( taddr -- char )  >image c@ ;  : c@ ( taddr -- char )  >image Sc@ ;
 : c! ( char taddr -- )  >image c! ;  : 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    1 allot c! H ;  : c,    ( char -- )     T here H tchar T allot c! H ;
 : align ( -- )          T here H align+ 0 ?DO  bl T c, H LOOP ;  : align ( -- )          T here H align+ 0 ?DO  bl T c, H tchar +LOOP ;
 : cfalign ( -- )  : cfalign ( -- )
     T here H cfalign+ 0 ?DO  bl T c, H LOOP ;      T here H cfalign+ 0 ?DO  bl T c, H tchar +LOOP ;
   
 : A!                    dup relon T ! H ;  : >address              dup 0>= IF tbyte / THEN ; \ ?? jaw 
 : A,    ( w -- )        T here H relon T , H ;  : A!                    swap >address swap dup relon T ! H ;
   : A,    ( w -- )        >address T here H relon T , H ;
   
 >CROSS  >CROSS
   
 : tcmove ( source dest len -- )  : tcmove ( source dest len -- )
 \G cmove in target memory  \G cmove in target memory
   bounds    tchar * bounds
   ?DO  dup T c@ H I T c! H 1+    ?DO  dup T c@ H I T c! H 1+
   LOOP  drop ;    tchar +LOOP  drop ;
   
   \ \ Load Assembler
   
 >TARGET  >TARGET
 H also Forth definitions \ ." asm: " order  H also Forth definitions
   
 : X     also target bl word find  : X     bl word count [ ' target >wordlist ] Literal search-wordlist
         IF      state @ IF compile,          IF      state @ IF compile,
                 ELSE execute THEN                  ELSE execute THEN
         ELSE    previous ABORT" Cross: access method not supported!"          ELSE    -1 ABORT" Cross: access method not supported!"
         THEN           THEN ; immediate
         previous ; immediate  
   
 [IFDEF] asm-include asm-include [THEN] hex  [IFDEF] asm-include asm-include [THEN] hex
   
Line 633  previous Line 1337  previous
   
 \ \ --------------------        Compiler Plug Ins               01aug97jaw  \ \ --------------------        Compiler Plug Ins               01aug97jaw
   
 Defer lit, ( n -- )  
 Defer alit, ( n -- )  
 Defer branch, ( target-addr -- )  
 Defer ?branch, ( target-addr -- )  
 Defer branchmark, ( -- branch-addr )  
 Defer ?branchmark, ( -- branch-addr )  
 Defer branchto,  
 Defer branchtoresolve, ( branch-addr -- )  
 Defer branchfrom, ( -- )  
 Defer branchtomark, ( -- target-addr )  
 Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position  
 Defer colon-resolve ( tcfa addr -- )  
 Defer addr-resolve ( target-addr addr -- )  
   
 [IFUNDEF] ca>native  
 defer ca>native   
 [THEN]  
   
 >TARGET  >TARGET
 DEFER >body             \ we need the system >body  DEFER >body             \ we need the system >body
                         \ and the target >body                          \ and the target >body
 >CROSS  >CROSS
 T 2 cells H VALUE xt>body  T 2 cells H VALUE xt>body
 DEFER doprim,  DEFER doprim,   \ compiles start of a primitive
 DEFER docol,     \ compiles start of definition and doer  DEFER docol,    \ compiles start of a colon definition
 DEFER doer,               DEFER doer,             
 DEFER fini,      \ compiles end of definition ;s  DEFER fini,      \ compiles end of definition ;s
 DEFER doeshandler,  DEFER doeshandler,
Line 666  DEFER dodoes, Line 1352  DEFER dodoes,
 DEFER ]comp     \ starts compilation  DEFER ]comp     \ starts compilation
 DEFER comp[     \ ends compilation  DEFER comp[     \ ends compilation
   
 : (cc) T a, H ;                 ' (cc) IS colon,  : (prim) T a, H ;                               ' (prim) IS prim,
 : (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve  
 : (ar) T ! H ;                  ' (ar) IS addr-resolve  
   
 >TARGET  
 : compile, colon, ;  
 >CROSS  
   
   : (cr) >tempdp ]comp prim, comp[ tempdp> ;      ' (cr) IS colon-resolve
   : (ar) T ! H ;                                  ' (ar) IS addr-resolve
   : (dr)  ( ghost res-pnt target-addr addr )
           >tempdp drop over 
           dup >magic @ <do:> =
           IF      doer,
           ELSE    dodoes,
           THEN 
           tempdp> ;                               ' (dr) IS doer-resolve
   
   : (cm) ( -- addr )
       T here align H
       -1 prim, ;                                  ' (cm) IS colonmark,
   
 \ resolve structure  >TARGET
   : compile, prim, ;
 : >next ;               \ link to next field  >CROSS
 : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address  
 : >taddr cell+ cell+ ;  
 : >ghost 3 cells + ;  
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
   swap >r here r@ >link @ , r@ >link ! ( tag ) ,  \G creates a resolve structure
   T here aligned H , r> drop  last-header-ghost @ , ;      T here aligned H swap (refered)
     ;
   
   : killref ( addr ghost -- )
   \G kills a forward reference to ghost at position addr
   \G this is used to eleminate a :dovar refence after making a DOES>
       dup >magic @ <fwd> <> IF 2drop EXIT THEN
       swap >r >link
       BEGIN dup @ dup  ( addr last this )
       WHILE dup >taddr @ r@ =
            IF   @ over !
            ELSE nip THEN
       REPEAT rdrop 2drop 
     ;
   
 Defer resolve-warning  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
     
 \ resolve                                              14oct92py  \ resolve                                              14oct92py
   
  : resolve-loop ( ghost tcfa -- ghost tcfa )   : resolve-loop ( ghost resolve-list tcfa -- )
   >r dup >link      >r
   BEGIN @ dup WHILE       BEGIN dup WHILE 
         resolve-warning   \         dup >tag @ 2 = IF reswarn-forward THEN
         r@ over >taddr @             resolve-warning 
         2 pick >tag @            r@ over >taddr @ 
         IF      addr-resolve            2 pick >tag @
         ELSE    colon-resolve            CASE  0 OF colon-resolve ENDOF
         THEN                  1 OF addr-resolve ENDOF
   REPEAT drop r> ;                  2 OF doer-resolve ENDOF
             ENDCASE
             @ \ next list element
       REPEAT 2drop rdrop 
     ;
   
 \ : resolve-loop ( ghost tcfa -- ghost tcfa )  \ : resolve-loop ( ghost tcfa -- ghost tcfa )
 \  >r dup >link @  \  >r dup >link @
Line 735  Exists-Warnings on Line 1441  Exists-Warnings on
   ELSE  true abort" CROSS: Ghostnames inconsistent "    ELSE  true abort" CROSS: Ghostnames inconsistent "
   THEN ;    THEN ;
   
   : colon-resolved   ( ghost -- )
       >link @ colon, ; \ compile-call
   : prim-resolved  ( ghost -- )
       >link @ prim, ;
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
 \ resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
   over forward? 0= IF  exists EXIT THEN      \ is ghost resolved?, second resolve means another definition with the
   resolve-loop  over >link ! <res> swap >magic !       \ same name
   ['] noop IS resolve-warning       over undefined? 0= IF  exists EXIT THEN
       \ get linked-list
       swap >r r@ >link @ swap \ ( list tcfa R: ghost )
       \ mark ghost as resolved
       dup r@ >link ! <res> r@ >magic !
       r@ >comp @ ['] is-forward = IF
           ['] prim-resolved  r@ >comp !  THEN
       \ loop through forward referencies
       r> -rot 
       comp-state @ >r Resolving comp-state !
       resolve-loop 
       r> comp-state !
   
       ['] noop IS resolve-warning 
   ;    ;
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
 : is-forward   ( ghost -- )  
 \  >link dup @ there rot !  T  A,  H ;  
   0 refered  -1 colon, ;  
   
 : is-resolved   ( ghost -- )  
   >link @ colon, ; \ compile-call  
   
 : gexecute   ( ghost -- )  : gexecute   ( ghost -- )
   dup @ <fwd> = IF  is-forward  ELSE  is-resolved  THEN ;      dup >comp @ execute ;
   
 : 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 ;  \ !! : ghost,     ghost  gexecute ;
   
Line 768  variable ResolveFlag Line 1485  variable ResolveFlag
 : ?touched ( ghost -- flag ) dup forward? swap >link @  : ?touched ( ghost -- flag ) dup forward? swap >link @
                                0 <> and ;                                 0 <> and ;
   
   : .forwarddefs ( ghost -- )
           ."  appeared in:"
           >link
           BEGIN   @ dup
           WHILE   cr 5 spaces
                   dup >ghost @ .ghost
                   ."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN
                   ."  line " dup >line @ .dec
           REPEAT 
           drop ;
   
 : ?resolved  ( ghostname -- )  : ?resolved  ( ghostname -- )
   dup cell+ @ ?touched    dup cell+ @ ?touched
   IF  cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;    IF    dup 
           cell+ cell+ count cr type ResolveFlag on 
           cell+ @ .forwarddefs
     ELSE  drop 
     THEN ;
   
 >MINIMAL  
 : .unresolved  ( -- )  : .unresolved  ( -- )
   ResolveFlag off cr ." Unresolved: "    ResolveFlag off cr ." Unresolved: "
   Ghostnames    Ghostnames
Line 789  variable ResolveFlag Line 1520  variable ResolveFlag
 : .stats  : .stats
   base @ >r decimal    base @ >r decimal
   cr ." named Headers: " headers-named @ .     cr ." named Headers: " headers-named @ . 
 \  cr ." MaxRam*" ramdp @ .   
 \  cr ." MaxRom*" romdp @ .   
   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 ;  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        <do:> last-header-ghost @ >magic ! ;  : isdoer        
   \G define a forth word as doer, this makes obviously only sence on
   \G forth processors such as the PSC1000
                   <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
   
 >TARGET  >TARGET
 : string,  ( addr count -- )  : string,  ( addr count -- )
   dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;       dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;
 : name,  ( "name" -- )  bl word count T string, cfalign H ;  : lstring, ( addr count -- )
       dup T , H bounds  ?DO  I c@ T c, H  LOOP ;
   : name,  ( "name" -- )  bl word count T lstring, cfalign H ;
 : view,   ( -- ) ( dummy ) ;  : view,   ( -- ) ( dummy ) ;
 >CROSS  >CROSS
   
 \ Target Document Creation (goes to crossdoc.fd)       05jul95py  \ Target Document Creation (goes to crossdoc.fd)       05jul95py
   
 s" doc/crossdoc.fd" r/w create-file throw value doc-file-id  s" ./doc/crossdoc.fd" r/w create-file throw value doc-file-id
 \ contains the file-id of the documentation file  \ contains the file-id of the documentation file
   
 : T-\G ( -- )  : T-\G ( -- )
Line 841  Variable to-doc  to-doc on Line 1579  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  
           tlast @ >image count 1F and doc-file-id write-file throw
         >in @          >in @
         [char] ( parse 2drop          [char] ( parse 2drop
         [char] ) parse doc-file-id write-file throw          [char] ) parse doc-file-id write-file throw
Line 863  Create tag-bof 1 c,  0C c, Line 1602  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 878  Create tag-bof 1 c,  0C c, Line 1617  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 890  Create tag-bof 1 c,  0C c, Line 1629  Create tag-bof 1 c,  0C c,
   
 Defer skip? ' false IS skip?  Defer skip? ' false IS skip?
   
 : defined? ( -- flag ) \ name  : skipdef ( <name> -- )
   \G skip definition of an undefined word in undef-words and
   \G all-words mode
       ghost dup forward?
       IF  >magic <skip> swap !
       ELSE drop THEN ;
   
   : tdefined? ( -- flag ) \ name
       ghost undefined? 0= ;
   
   : defined2? ( -- flag ) \ name
   \G return true for anything else than forward, even for <skip>
   \G that's what we want
     ghost forward? 0= ;      ghost forward? 0= ;
   
   : forced? ( -- flag ) \ name
   \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
 \G a word is not defined  \G a word is not defined
 \G a forward reference exists  \G a forward reference exists
 \G so the definition is not skipped!  \G so the definition is not skipped!
     bl word gfind      bl word gfind
     IF dup forward?      IF dup undefined?
         nip          nip
         0=          0=
     ELSE  drop true  THEN ;      ELSE  drop true  THEN ;
Line 912  Defer skip? ' false IS skip? Line 1667  Defer skip? ' false IS skip?
   
 \ Target header creation  \ Target header creation
   
   Variable NoHeaderFlag
   NoHeaderFlag off
   
 VARIABLE CreateFlag CreateFlag off  : 0.r ( n1 n2 -- ) 
       base @ >r hex 
       0 swap <# 0 ?DO # LOOP #> type 
       r> base ! ;
   
 : 0.r ( n1 n2 -- ) 0 swap <# 0 ?DO # LOOP #> type ;  : .sym ( adr len -- )
 : .sym  \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 )  : (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
   T align H view,      \ build header in target
   tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !      NoHeaderFlag @
   1 headers-named +!    \ Statistic      IF  NoHeaderFlag off
   >in @ T name, H >in ! T here H tlastcfa !      ELSE
   \ Symbol table          T align H view,
   \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !          tlast @ dup 0> IF tcell - THEN T A, H  there tlast !
   CreateFlag @ IF          1 headers-named +!      \ Statistic
        >in @ alias2 swap >in !         \ create alias in target          >in @ T name, H >in !
        >in @ ghost swap >in !      THEN
        swap also ghosts ' previous swap !     \ tick ghost and store in alias      T cfalign here H tlastcfa !
        CreateFlag off      \ Old Symbol table sed-script
   ELSE ghost THEN  \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
   dup Last-Header-Ghost !      ghost
   dup >magic ^imm !     \ a pointer for immediate      \ output symbol table to extra file
   Already @ IF  dup >end tdoes !      [ [IFDEF] fd-symbol-table ]
   ELSE 0 tdoes ! THEN        base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !
   80 flag!        s" :" fd-symbol-table write-file throw
   cross-doc-entry cross-tag-entry ;        dup >ghostname fd-symbol-table write-line throw
       [ [THEN] ]
       dup Last-Header-Ghost !
       dup >magic ^imm !     \ a pointer for immediate
       Already @
       IF  dup >end tdoes !
       ELSE 0 tdoes !
       THEN
       alias-mask flag!
       cross-doc-entry cross-tag-entry ;
   
 VARIABLE ;Resolve 1 cells allot  VARIABLE ;Resolve 1 cells allot
 \ this is the resolver information from ":"  \ this is the resolver information from ":"
Line 958  VARIABLE ;Resolve 1 cells allot Line 1727  VARIABLE ;Resolve 1 cells allot
 >TARGET  >TARGET
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
     >in @ skip? IF  2drop  EXIT  THEN  >in !      >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< has-prims 0= and      dup 0< s" prims" T $has? H 0= and
     IF      IF
         ." needs prim: " >in @ bl word count type >in ! cr          .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
     THEN      THEN
     (THeader over resolve T A, H 80 flag! ;      (THeader over resolve T A, H alias-mask flag! ;
 : Alias:   ( cfa -- ) \ name  : Alias:   ( cfa -- ) \ name
     >in @ skip? IF  2drop  EXIT  THEN  >in !      >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< has-prims 0= and      dup 0< s" prims" T $has? H 0= and
     IF      IF
         ." 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#
   : first-primitive ( n -- )  prim# ! ;
   : Primitive  ( -- ) \ name
       prim# @ T Alias H  -1 prim# +! ;
 >CROSS  >CROSS
   
 \ Conditionals and Comments                            11may93jaw  \ Conditionals and Comments                            11may93jaw
Line 1003  Comment (       Comment \ Line 1777  Comment (       Comment \
   ELSE  postpone literal postpone gexecute  THEN ;    ELSE  postpone literal postpone gexecute  THEN ;
                                         immediate                                          immediate
   
   T has? peephole H [IF]
   : (cc) compile call T >body a, H ;              ' (cc) IS colon,
   [ELSE]
       ' (prim) IS colon,
   [THEN]
   
 : [G']   : [G'] 
 \G ticks a ghost and returns its address  \G ticks a ghost and returns its address
   bl word gfind 0= ABORT" CROSS: Ghost don't exists"    bl word gfind 0= ABORT" CROSS: Ghost don't exists"
Line 1011  Comment (       Comment \ Line 1791  Comment (       Comment \
   THEN ; immediate    THEN ; immediate
   
 : ghost>cfa  : ghost>cfa
   dup forward? ABORT" CROSS: forward " >link @ ;    dup undefined? ABORT" CROSS: forward " >link @ ;
                                 
 >TARGET  >TARGET
   
Line 1032  Cond: [']  T ' H alit, ;Cond Line 1812  Cond: [']  T ' H alit, ;Cond
 \ modularized                                           14jun97jaw  \ modularized                                           14jun97jaw
   
 : fillcfa   ( usedcells -- )  : fillcfa   ( usedcells -- )
   T cells H xt>body swap - 0 ?DO 0 T c, H LOOP ;    T cells H xt>body swap - 0 ?DO 0 X c, tchar +LOOP ;
   
 : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H  : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H
   
 : (doer,)   ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ;   ' (doer,) IS doer,  : (doer,)   ( ghost -- ) ]comp addr, comp[ 1 fillcfa ;   ' (doer,) IS doer,
   
 : (docol,)  ( -- ) [G'] :docol doer, ;          ' (docol,) IS docol,  : (docol,)  ( -- ) [G'] :docol doer, ;          ' (docol,) IS docol,
   
Line 1053  Cond: [']  T ' H alit, ;Cond Line 1833  Cond: [']  T ' H alit, ;Cond
   
 : (lit,) ( n -- )   compile lit T  ,  H ;       ' (lit,) IS lit,  : (lit,) ( n -- )   compile lit T  ,  H ;       ' (lit,) IS lit,
   
 : (alit,) ( n -- )  lit, T here cell - H relon ;        ' (alit,) IS alit,  \ if we dont produce relocatable code alit, defaults to lit, jaw
   \ this is just for convenience, so we don't have to define alit,
   \ seperately for embedded systems....
   T has? relocate H
   [IF]
   : (alit,) ( n -- )  compile lit T  a, H ;       ' (alit,) IS alit,
   [ELSE]
   : (alit,) ( n -- )  lit, ;                      ' (alit,) IS alit,
   [THEN]
   
 : (fini,)         compile ;s ;                ' (fini,) IS fini,  : (fini,)         compile ;s ;                ' (fini,) IS fini,
   
Line 1066  Defer (end-code) Line 1854  Defer (end-code)
 : Code  : Code
   defempty?    defempty?
   (THeader there resolve    (THeader there resolve
   [ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF]    [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
   doprim,     doprim, 
   [THEN]    [THEN]
   depth (code) ;    depth (code) ;
Line 1082  Defer (end-code) Line 1870  Defer (end-code)
     ELSE true ABORT" CROSS: Stack empty" THEN      ELSE true ABORT" CROSS: Stack empty" THEN
     ;      ;
   
 Cond: chars ;Cond  
   
 >CROSS  >CROSS
   
 \ tLiteral                                             12dec92py  \ tLiteral                                             12dec92py
Line 1100  Cond: [Char]   ( "<char>" -- )  restrict Line 1886  Cond: [Char]   ( "<char>" -- )  restrict
 \ 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 targets with char = 8 bit
   
 Cond: MAXU  Cond: MAXU
   restrict?     restrict? 
   tcell 1 cells u>     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  
   ;Cond    ;Cond
   
 Cond: MINI  Cond: MINI
   restrict?    restrict?
   tcell 1 cells u>    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  
   ;Cond    ;Cond
     
 Cond: MAXI  Cond: MAXI
  restrict?   restrict?
  tcell 1 cells u>   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  
  ;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  ?dup
   number? dup  IF    0> IF swap lit,  THEN  lit,  drop    IF    >r >r discard r> r>
                ELSE  2drop >in !          0> IF   >exec @ execute
                ghost gexecute THEN  ;          ELSE    gexecute  THEN 
           EXIT 
     THEN
     number? dup  
     IF    0> IF swap lit,  THEN  lit, discard
     ELSE  2drop restore-input throw ghost gexecute THEN  ;
   
 >TARGET  >TARGET
 \ : ; DOES>                                            13dec92py  \ : ; DOES>                                            13dec92py
 \ ]                                                     9may93py/jaw  \ ]                                                     9may93py/jaw
   
 : ] state on  : ] state on
       Compiling comp-state !
     BEGIN      BEGIN
         BEGIN >in @ bl word          BEGIN save-input bl word
               dup c@ 0= WHILE 2drop refill 0=                dup c@ 0= WHILE drop discard refill 0=
               ABORT" CROSS: End of file while target compiling"                ABORT" CROSS: End of file while target compiling"
         REPEAT          REPEAT
         tcom          tcom
Line 1190  Cond: ; ( -- ) restrict? Line 1979  Cond: ; ( -- ) restrict?
                comp[                 comp[
                state off                 state off
                ;Resolve @                 ;Resolve @
                IF ;Resolve @ ;Resolve cell+ @ resolve THEN                 IF ;Resolve @ ;Resolve cell+ @ resolve
                     ['] colon-resolved ;Resolve @ >comp ! THEN
                   Interpreting comp-state !
                ;Cond                 ;Cond
 Cond: [  restrict? state off ;Cond  Cond: [  restrict? state off Interpreting comp-state ! ;Cond
   
 >CROSS  >CROSS
   
   Create GhostDummy ghostheader
   <res> GhostDummy >magic !
   
 : !does ( does-action -- )  : !does ( does-action -- )
 \ !! zusammenziehen und dodoes, machen!  \ !! zusammenziehen und dodoes, machen!
     tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;      tlastcfa @ [G'] :dovar killref
   \    tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
 \ !! geht so nicht, da dodoes, ghost will!  \ !! geht so nicht, da dodoes, ghost will!
 \     tlastcfa @ >tempdp dodoes, tempdp> ;      GhostDummy >link ! GhostDummy 
       tlastcfa @ >tempdp dodoes, tempdp> ;
   
   : g>body ( ghost -- body )
       >link @ T >body H ;
   : does-resolved ( ghost -- )
       dup g>body alit, >end @ g>body colon, ;
   
 >TARGET  >TARGET
 Cond: DOES> restrict?  Cond: DOES> restrict?
         compile (does>) doeshandler,           compile (does>) doeshandler, 
         \ resolve words made by builders          \ resolve words made by builders
         tdoes @ ?dup IF  @ T here H resolve THEN          tdoes @ ?dup IF  @ dup T here H resolve
               ['] prim-resolved swap >comp !  THEN
         ;Cond          ;Cond
 : DOES> switchrom doeshandler, T here H !does depth T ] H ;  : DOES> switchrom doeshandler, T here H !does depth T ] H ;
   
Line 1214  Cond: DOES> restrict? Line 2017  Cond: DOES> restrict?
   
 \ Builder                                               11may93jaw  \ Builder                                               11may93jaw
   
 : Builder    ( Create-xt do:-xt "name" -- )  : 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 executet 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-enrys is used
   
   >in @ alias2 swap dup >in ! >r >r    Make-Ghost            ( Create-xt do-ghost ghost )
   Make-Ghost rot swap >exec ! ,    rot swap              ( do-ghost Create-xt ghost )
   r> r> >in !    >exec ! , ;
   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 forward? 0=    >end @ dup undefined? 0=
   IF    IF
         dup >magic @ <do:> =          dup >magic @ <do:> =
         IF  doer, EXIT THEN          IF       doer, 
           ELSE    dodoes,
           THEN
           EXIT
   THEN    THEN
 \  compile :dodoes gexecute  \  compile :dodoes gexecute
 \  T here H tcell - reloff   \  T here H tcell - reloff 
   dodoes,    2 refered 
 ;    0 fillcfa
     ;
   
 : TCreate ( <name> -- )  : TCreate ( <name> -- )
   executed-ghost @    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,    Theader >r dup , dup gdoes,
 \ stores execution symantic in the built word  \ stores execution semantic in the built word
   >end @ >exec @ r> >exec ! ;  \ if the word already has a semantic (concerns S", IS, .", DOES>)
   \ then keep it
     >end @
     dup >exec @ r@ >exec dup @ ['] NoExec =  IF ! ELSE 2drop THEN
     >comp @ r> >comp ! ;
   
 : RTCreate ( <name> -- )  : RTCreate ( <name> -- )
 \ creates a new word with code-field in ram  \ creates a new word with code-field in ram
   executed-ghost @    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 )    (THeader there 0 T a, H alias-mask flag! ( S executed-ghost new-ghost )
   \ store  poiter to code-field    \ 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 !    dup there resolve 0 ;Resolve !
   >r dup gdoes,    >r dup gdoes,
   >end @ >exec @ r> >exec ! ;  \ stores execution semantic in the built word
   \ if the word already has a semantic (concerns S", IS, .", DOES>)
   \ then keep it
     >end @ >exec @ r> >exec dup @ ['] NoExec =
     IF ! ELSE 2drop THEN ;
   
 : Build:  ( -- [xt] [colon-sys] )  : Build:  ( -- [xt] [colon-sys] )
   :noname postpone TCreate ;    :noname postpone TCreate ;
   
 : BuildSmart:  ( -- [xt] [colon-sys] )  : BuildSmart:  ( -- [xt] [colon-sys] )
   :noname    :noname
   [ has-rom [IF] ]    [ T has? rom H [IF] ]
   postpone RTCreate    postpone RTCreate
   [ [ELSE] ]    [ [ELSE] ]
   postpone TCreate     postpone TCreate 
Line 1277  Cond: DOES> restrict? Line 2088  Cond: DOES> restrict?
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
   executed-ghost @    executed-ghost @
   state @ IF  gexecute true EXIT  THEN    state @ IF  gexecute true EXIT  THEN
   >link @ T >body H false ;    g>body false ;
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  \ changed to ?EXIT                                      10may93jaw
   
 : DO:     ( -- addr [xt] [colon-sys] )  : DO:     ( -- ghost [xt] [colon-sys] )
   here ghostheader    here ghostheader
   :noname postpone gdoes> postpone ?EXIT ;    :noname postpone gdoes> postpone ?EXIT ;
   
 : by:     ( -- addr [xt] [colon-sys] ) \ name  : by:     ( -- ghost [xt] [colon-sys] ) \ name
   ghost    ghost
   :noname postpone gdoes> postpone ?EXIT ;    :noname postpone gdoes> postpone ?EXIT ;
   
 : ;DO ( addr [xt] [colon-sys] -- addr )  : ;DO ( ghost [xt] [colon-sys] -- ghost )
   postpone ;    ( S addr xt )    postpone ;    ( S addr xt )
   over >exec ! ; immediate    over >exec ! ; immediate
   
 : by      ( -- addr ) \ Name  T has? peephole H [IF]
   : compile: ( ghost -- ghost [xt] [colon-sys] )
       :noname  postpone g>body ;
   : ;compile ( ghost [xt] [colon-sys] -- ghost )
       postpone ;  over >comp ! ; immediate
   [ELSE]
   : compile:  ( ghost -- ghost xt colon-sys )  :noname ;
   : ;compile ( ghost xt colon-sys -- ghost )
       postpone ; drop ; immediate
   [THEN]
   
   : by      ( -- ghost ) \ Name
   ghost >end @ ;    ghost >end @ ;
   
 >TARGET  >TARGET
Line 1302  Cond: DOES> restrict? Line 2124  Cond: DOES> restrict?
   
 Build:  ( n -- ) ;  Build:  ( n -- ) ;
 by: :docon ( ghost -- n ) T @ H ;DO  by: :docon ( ghost -- n ) T @ H ;DO
   compile: alit, compile @ ;compile
 Builder (Constant)  Builder (Constant)
   
 Build:  ( n -- ) T , H ;  Build:  ( n -- ) T , H ;
Line 1318  Builder 2Constant Line 2141  Builder 2Constant
   
 BuildSmart: ;  BuildSmart: ;
 by: :dovar ( ghost -- addr ) ;DO  by: :dovar ( ghost -- addr ) ;DO
   \ compile: alit, ;compile
 Builder Create  Builder Create
   
 has-rom [IF]  T has? rom H [IF]
 Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;  Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
 by (Constant)  by (Constant)
 Builder Variable  Builder Variable
 [ELSE]  [ELSE]
 Build: T 0 , H ;  Build: T 0 , H ;
 by Create  by Create
   \ compile: alit, ;compile
 Builder Variable  Builder Variable
 [THEN]  [THEN]
   
 has-rom [IF]  T has? rom H [IF]
 Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;  Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;
   by (Constant)
   Builder 2Variable
   [ELSE]
   Build: T 0 , 0 , H ;
   by Create
   \ compile: alit, ;compile
   Builder 2Variable
   [THEN]
   
   T has? rom H [IF]
   Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
 by (Constant)  by (Constant)
 Builder AVariable  Builder AVariable
 [ELSE]  [ELSE]
 Build: T 0 A, H ;  Build: T 0 A, H ;
 by Create  by Create
   \ compile: alit, ;compile
 Builder AVariable  Builder AVariable
 [THEN]  [THEN]
   
 \ User variables                                       04may94py  \ User variables                                       04may94py
   
 >CROSS  >CROSS
   
 Variable tup  0 tup !  Variable tup  0 tup !
 Variable tudp 0 tudp !  Variable tudp 0 tudp !
   
 : u,  ( n -- udp )  : u,  ( n -- udp )
   tup @ tudp @ + T  ! H    tup @ tudp @ + T  ! H
   tudp @ dup T cell+ H tudp ! ;    tudp @ dup T cell+ H tudp ! ;
   
 : au, ( n -- udp )  : au, ( n -- udp )
   tup @ tudp @ + T A! H    tup @ tudp @ + T A! H
   tudp @ dup T cell+ H tudp ! ;    tudp @ dup T cell+ H tudp ! ;
   
 >TARGET  >TARGET
   
 Build: T 0 u, , H ;  Build: 0 u, X , ;
 by: :douser ( ghost -- up-addr )  T @ H tup @ + ;DO  by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO
   compile: compile useraddr T @ , H ;compile
 Builder User  Builder User
   
 Build: T 0 u, , 0 u, drop H ;  Build: 0 u, X , 0 u, drop ;
 by User  by User
 Builder 2User  Builder 2User
   
 Build: T 0 au, , H ;  Build: 0 au, X , ;
 by User  by User
 Builder AUser  Builder AUser
   
Line 1375  Builder AValue Line 2217  Builder AValue
   
 BuildSmart:  ( -- ) [T'] noop T A, H ;  BuildSmart:  ( -- ) [T'] noop T A, H ;
 by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
   compile: alit, compile @ compile execute ;compile
 Builder Defer  Builder Defer
   
 BuildSmart:  ( inter comp -- ) swap T immediate A, A, H ;  Build: ( inter comp -- ) swap T immediate A, A, H ;
 DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 Builder interpret/compile:  Builder interpret/compile:
   
Line 1391  Builder interpret/compile: Line 2234  Builder interpret/compile:
   
 Build: ;  Build: ;
 by: :dofield T @ H + ;DO  by: :dofield T @ H + ;DO
   compile: T @ H lit, compile + ;compile
 Builder (Field)  Builder (Field)
   
 Build: ( align1 offset1 align size "name" --  align2 offset2 )  Build: ( align1 offset1 align size "name" --  align2 offset2 )
Line 1405  Builder Field Line 2249  Builder Field
 : cell% ( n -- size align )  : cell% ( n -- size align )
     T 1 cells H dup ;      T 1 cells H dup ;
   
 \ ' 2Constant Alias2 end-struct  Build: ( m v -- m' v )  dup T , cell+ H ;
 \ 0 1 T Chars H 2Constant struct  DO:  abort" Not in cross mode" ;DO
   Builder input-method
 0 [IF]  
   Build: ( m v size -- m v' )  over T , H + ;
   DO:  abort" Not in cross mode" ;DO
   Builder input-var
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
Line 1417  Builder Field Line 2264  Builder Field
 : sys?        ( sys -- sys )    dup 0= ?struc ;  : 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 -- ) - ;  : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  
 : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;  
 >TARGET  
   
 \ Structural Conditionals                              12dec92py  : >resolve    ( sys -- )        
           X here ( dup ." >" hex. ) over branchoffset swap X ! ;
   
 Cond: BUT       restrict? sys? swap ;Cond  : <resolve    ( sys -- )
 Cond: YET       restrict? sys? dup ;Cond          X here ( dup ." <" hex. ) branchoffset X , ;
   
 >CROSS  
 Variable tleavings  
 >TARGET  
   
 Cond: DONE   ( addr -- )  restrict? tleavings @  :noname compile branch X here branchoffset X , ;
       BEGIN  2dup u> 0=  WHILE  dup T @ H swap >resolve REPEAT    IS branch, ( target-addr -- )
       tleavings ! drop ;Cond  :noname compile ?branch X here branchoffset X , ;
     IS ?branch, ( target-addr -- )
   :noname compile branch T here 0 , H ;
     IS branchmark, ( -- branchtoken )
   :noname compile ?branch T here 0 , H ;
     IS ?branchmark, ( -- branchtoken )
   :noname T here 0 , H ;
     IS ?domark, ( -- branchtoken )
   :noname dup X @ ?struc X here over branchoffset swap X ! ;
     IS branchtoresolve, ( branchtoken -- )
   :noname branchto, X here ;
     IS branchtomark, ( -- target-addr )
   
 >CROSS  
 : (leave  T here H tleavings @ T , H  tleavings ! ;  
 >TARGET  >TARGET
   
 Cond: LEAVE     restrict? compile branch (leave ;Cond  
 Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond  
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 Cond: AHEAD     restrict? compile branch >mark ;Cond  Cond: BUT       restrict? sys? swap ;Cond
 Cond: IF        restrict? compile ?branch >mark ;Cond  Cond: YET       restrict? sys? dup ;Cond
 Cond: THEN      restrict? sys? branchto, dup T @ H ?struc >resolve ;Cond  
 Cond: ELSE      restrict? sys? compile AHEAD swap compile THEN ;Cond  
   
 Cond: BEGIN     restrict? T branchto, here ( dup ." B" hex. ) H ;Cond  
 Cond: WHILE     restrict? sys? compile IF swap ;Cond  
 Cond: AGAIN     restrict? sys? compile branch <resolve ;Cond  
 Cond: UNTIL     restrict? sys? compile ?branch <resolve ;Cond  
 Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond  
   
 Cond: CASE      restrict? 0 ;Cond  >CROSS
 Cond: OF        restrict? 1+ >r compile over compile =  
                 compile IF compile drop r> ;Cond  
 Cond: ENDOF     restrict? >r compile ELSE r> ;Cond  
 Cond: ENDCASE   restrict? compile drop 0 ?DO  compile THEN  LOOP ;Cond  
   
 \ Structural Conditionals                              12dec92py  Variable tleavings 0 tleavings !
   
 Cond: DO        restrict? compile (do)   T here H ;Cond  : (done) ( addr -- )
 Cond: ?DO       restrict? compile (?do)  T (leave here H ;Cond      tleavings @
 Cond: FOR       restrict? compile (for)  T here H ;Cond      BEGIN  dup
       WHILE
           >r dup r@ cell+ @ \ address of branch
           u> 0=      \ lower than DO?     
       WHILE
           r@ 2 cells + @ \ branch token
           branchtoresolve,
           r@ @ r> free throw
       REPEAT  r>  THEN
       tleavings ! drop ;
   
 >CROSS  
 : loop]   dup <resolve tcell - compile DONE compile unloop ;  
 >TARGET  >TARGET
   
 Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond  Cond: DONE   ( addr -- )  restrict? (done) ;Cond
 Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond  
 Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond  
   
 [ELSE]  >CROSS
   : (leave) ( branchtoken -- )
       3 cells allocate throw >r
       T here H r@ cell+ !
       r@ 2 cells + !
       tleavings @ r@ !
       r> tleavings ! ;
   >TARGET
   
 \ structural conditionals                              17dec92py  Cond: LEAVE     restrict? branchmark, (leave) ;Cond
   Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave)  ;Cond
   
 >CROSS  >CROSS
 : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;  \ !!JW ToDo : Move to general tools section
 : sys?        ( sys -- sys )    dup 0= ?struc ;  
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  
   
 : branchoffset ( src dest -- ) - ;  : to1 ( x1 x2 xn n -- addr )
   \G packs n stack elements in a allocated memory region
      dup dup 1+ cells allocate throw dup >r swap 1+
      0 DO tuck ! cell+ LOOP
      drop r> ;
   : 1to ( addr -- x1 x2 xn )
   \G unpacks the elements saved by to1
       dup @ swap over cells + swap
       0 DO  dup @ swap 1 cells -  LOOP
       free throw ;
   
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  : loop]     branchto, dup <resolve tcell - (done) ;
   
 : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;  : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
   
 :noname compile branch T here branchoffset , H ; IS branch,  
 :noname compile ?branch T here branchoffset , H ; IS ?branch,  
 :noname compile branch T here 0 , H ; IS branchmark,  
 :noname compile ?branch T here 0 , H ; IS  ?branchmark,  
 :noname dup T @ H ?struc T here over branchoffset swap ! H ; IS branchtoresolve,  
 :noname branchto, T here H ; IS branchtomark,  
   
 >TARGET  >TARGET
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 Cond: BUT       restrict? sys? swap ;Cond  
 Cond: YET       restrict? sys? dup ;Cond  
   
 >CROSS  
 Variable tleavings  
 >TARGET  >TARGET
   
 Cond: DONE   ( addr -- )  restrict? tleavings @  
       BEGIN  2dup u> 0=  WHILE  dup T @ H swap >resolve REPEAT  
       tleavings ! drop ;Cond  
   
 >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  
   
 \ Structural Conditionals                              12dec92py  
   
 Cond: AHEAD     restrict? branchmark, ;Cond  Cond: AHEAD     restrict? branchmark, ;Cond
 Cond: IF        restrict? ?branchmark, ;Cond  Cond: IF        restrict? ?branchmark, ;Cond
 Cond: THEN      restrict? sys? branchto, branchtoresolve, ;Cond  Cond: THEN      restrict? sys? branchto, branchtoresolve, ;Cond
Line 1540  Cond: ENDCASE   restrict? compile drop 0 Line 2369  Cond: ENDCASE   restrict? compile drop 0
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 Cond: DO        restrict? compile (do)   T here H ;Cond  :noname \ ?? i think 0 is too much! jaw
 Cond: ?DO       restrict? compile (?do)  T (leave here H ;Cond      0 compile (do)
 Cond: FOR       restrict? compile (for)  T here H ;Cond      branchtomark,  2 to1 ;
     IS do, ( -- target-addr )
 >CROSS  
 : loop]   dup <resolve tcell - compile DONE compile unloop ;  \ :noname
 >TARGET  \     compile 2dup compile = compile IF
   \     compile 2drop compile ELSE
 Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond  \     compile (do) branchtomark, 2 to1 ;
 Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond  \   IS ?do,
 Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond      
   :noname
 [THEN]      0 compile (?do)  ?domark, (leave)
       branchtomark,  2 to1 ;
     IS ?do, ( -- target-addr )
   :noname compile (for) branchtomark, ;
     IS for, ( -- target-addr )
   :noname 1to compile (loop)  loop] compile unloop skiploop] ;
     IS loop, ( target-addr -- )
   :noname 1to compile (+loop)  loop] compile unloop skiploop] ;
     IS +loop, ( target-addr -- )
   :noname compile (next)  loop] compile unloop ;
     IS next, ( target-addr -- )
   
   Cond: DO        restrict? do, ;Cond
   Cond: ?DO       restrict? ?do, ;Cond
   Cond: FOR       restrict? for, ;Cond
   
   Cond: LOOP      restrict? sys? loop, ;Cond
   Cond: +LOOP     restrict? sys? +loop, ;Cond
   Cond: NEXT      restrict? sys? next, ;Cond
   
 \ String words                                         23feb93py  \ String words                                         23feb93py
   
 : ,"            [char] " parse T string, align H ;  : ,"            [char] " parse T string, align H ;
   
 Cond: ."        restrict? compile (.")     T ," H ;Cond  Cond: ."        restrict? compile (.")     T ," H ;Cond ( " )
 Cond: S"        restrict? compile (S")     T ," H ;Cond  Cond: S"        restrict? compile (S")     T ," H ;Cond ( " )
 Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond  Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond ( " )
   
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond  Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 : IS            T ' >body ! H ;  : IS            T >address ' >body ! H ;
 Cond: TO        T ' >body H compile ALiteral compile ! ;Cond  Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
 : TO            T ' >body ! H ;  : TO            T ' >body ! H ;
   
Line 1574  Cond: defers T ' >body @ compile, H ;Con Line 2421  Cond: defers T ' >body @ compile, H ;Con
 \ 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
Line 1594  Cond: compile ( -- ) restrict? \ name Line 2441  Cond: compile ( -- ) restrict? \ name
       0> IF    gexecute        0> IF    gexecute
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) gexecute THEN THEN ;Cond                 ELSE compile (compile) addr, THEN THEN ;Cond
   
 Cond: postpone ( -- ) restrict? \ name  Cond: postpone ( -- ) restrict? \ name
       bl word gfind dup 0= ABORT" CROSS: Can't compile"        bl word gfind dup 0= ABORT" CROSS: Can't compile"
       0> IF    gexecute        0> IF    gexecute
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) gexecute THEN THEN ;Cond                 ELSE compile (compile) addr, THEN THEN ;Cond
              
   \ save-cross                                           17mar93py
   
   hex
   
   >CROSS
   Create magic  s" Gforth2x" here over allot swap move
   
   bigendian 1+ \ strangely, in magic big=0, little=1
   tcell 1 = 0 and or
   tcell 2 = 2 and or
   tcell 4 = 4 and or
   tcell 8 = 6 and or
   tchar 1 = 00 and or
   tchar 2 = 28 and or
   tchar 4 = 50 and or
   tchar 8 = 78 and or
   magic 7 + c!
   
   : save-cross ( "image-name" "binary-name" -- )
     bl parse ." Saving to " 2dup type cr
     w/o bin create-file throw >r
     TNIL IF
         s" #! "           r@ write-file throw
         bl parse          r@ write-file throw
         s"  --image-file" r@ write-file throw
         #lf       r@ emit-file throw
         r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )
         ?do
             bl over emit-file throw
         loop
         drop
         magic 8       r@ write-file throw \ write magic
     ELSE
         bl parse 2drop
     THEN
     image @ there 
     r@ write-file throw \ write image
     TNIL IF
         bit$  @ there 1- tcell>bit rshift 1+
                   r@ write-file throw \ write tags
     THEN
     r> close-file throw ;
   
   : save-region ( addr len -- )
     bl parse w/o bin create-file throw >r
     swap >image swap r@ write-file throw
     r> close-file throw ;
   
   \ \ minimal definitions
              
   >MINIMAL also minimal
   
 >MINIMAL  
 also minimal  
 \ Usefull words                                        13feb93py  \ Usefull words                                        13feb93py
   
 : KB  400 * ;  : KB  400 * ;
   
   \ \ [IF] [ELSE] [THEN] ...                              14sep97jaw
   
   \ it is useful to define our own structures and not to rely
   \ on the words in the compiler
   \ The words in the compiler might be defined with vocabularies
   \ this doesn't work with our self-made compile-loop
   
   Create parsed 20 chars allot    \ store word we parsed
   
   : upcase
       parsed count bounds
       ?DO I c@ toupper I c! LOOP ;
   
   : [ELSE]
       1 BEGIN
           BEGIN bl word count dup WHILE
               comment? 20 umin parsed place upcase parsed count
               2dup s" [IF]" compare 0= >r 
               2dup s" [IFUNDEF]" compare 0= >r
               2dup s" [IFDEF]" compare 0= r> or r> or
               IF   2drop 1+
               ELSE 2dup s" [ELSE]" compare 0=
                   IF   2drop 1- dup
                       IF 1+
                       THEN
                   ELSE
                       2dup s" [ENDIF]" compare 0= >r
                       s" [THEN]" compare 0= r> or
                       IF 1- THEN
                   THEN
               THEN
               ?dup 0= ?EXIT
           REPEAT
           2drop refill 0=
       UNTIL drop ; immediate
     
   : [THEN] ( -- ) ; immediate
   
   : [ENDIF] ( -- ) ; immediate
   
   : [IF] ( flag -- )
       0= IF postpone [ELSE] THEN ; immediate 
   
   Cond: [IF]      postpone [IF] ;Cond
   Cond: [THEN]    postpone [THEN] ;Cond
   Cond: [ELSE]    postpone [ELSE] ;Cond
   
 \ define new [IFDEF] and [IFUNDEF]                      20may93jaw  \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
   
 : 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: [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 1639  also minimal Line 2587  also minimal
         AGAIN          AGAIN
      THEN ;       THEN ;
   
 also minimal  : d? d? ;
   
 \G doesn't skip line when bit is set in debugmask  \G doesn't skip line when debug switch is on
 : \D name evaluate debugmasksource @ and 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 1660  Cond: \D \D ;Cond Line 2608  Cond: \D \D ;Cond
 \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 ;
   
 : [IF]   postpone [IF] ;  
 : [THEN] postpone [THEN] ;  
 : [ELSE] postpone [ELSE] ;  
   
 Cond: [IF]      [IF] ;Cond  
 Cond: [IFDEF]   [IFDEF] ;Cond  
 Cond: [IFUNDEF] [IFUNDEF] ;Cond  
 Cond: [THEN]    [THEN] ;Cond  
 Cond: [ELSE]    [ELSE] ;Cond  
   
 previous  
   
 \ save-cross                                           17mar93py  
   
 >CROSS  
 Create magic  s" Gforth10" here over allot swap move  
   
 char 1 bigendian + tcell + 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 ;
   : mark there constant ;
   
   \ compiler directives
 : >ram >ram ;  : >ram >ram ;
 : >rom >rom ;  : >rom >rom ;
 : >auto >auto ;  : >auto >auto ;
Line 1725  bigendian Constant bigendian Line 2626  bigendian Constant bigendian
 : tempdp> tempdp> ;  : tempdp> tempdp> ;
 : const constflag on ;  : const constflag on ;
 : warnings name 3 = 0= twarnings ! drop ;  : warnings name 3 = 0= twarnings ! drop ;
   : | ;
   \ : | NoHeaderFlag on ; \ This is broken (damages the last word)
   
 : save-cross save-cross ;  : save-cross save-cross ;
 : save-region save-region ;  : save-region save-region ;
Line 1734  bigendian Constant bigendian Line 2636  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 1760  previous Line 2661  previous
 : 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  ['] defined? IS skip? ;  : undef-words  ['] defined2? IS skip? ;
   : skipdef skipdef ;
   
 : \  postpone \ ;  immediate  : \  postpone \ ;  immediate
 : \G T-\G ; immediate  : \G T-\G ; immediate
Line 1773  previous Line 2675  previous
 : ." [char] " parse type ;  : ." [char] " parse type ;
 : cr cr ;  : cr cr ;
   
 : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation  : times 0 ?DO dup X c, LOOP drop ; \ used for space table creation
 only forth also minimal definitions  
   \ only forth also cross also minimal definitions order
   
 \ cross-compiler words  \ cross-compiler words
   
 : decimal       decimal ;  : decimal       decimal ;
 : hex           hex ;  : hex           hex ;
   
 : tudp          T tudp H ;  \ : tudp          X tudp ;
 : tup           T tup H ;  \ : 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  [IFDEF] dbg : dbg dbg ; [THEN]
   
 \ for debugging...  \ for debugging...
 : order         order ;  : order         order ;
Line 1802  minimal Line 2704  minimal
 : T minimal ; immediate  : T minimal ; immediate
 : G ghosts ; immediate  : G ghosts ; immediate
   
 : turnkey  0 set-order also Target definitions  : turnkey 
            also Minimal also ;     \GFORTH 0 set-order also ghosts
      \ANSI [ ' ghosts >wordlist ] Literal 1 set-order
      also target definitions
      also Minimal also ;
   
 \ these ones are pefered:  \ these ones are pefered:
   
 : lock   turnkey ;  : lock   turnkey ;
 : unlock forth also cross ;  : unlock previous forth also cross ;
   
   \ also minimal
 : [[ also unlock ;  : [[ also unlock ;
 : ]] previous previous ;  : ]] previous previous also also ;
   
 unlock definitions also minimal  unlock definitions also minimal
 : lock   lock ;  : lock   lock ;
 lock  lock
   
   \ load cross compiler extension defined in mach file
   
   UNLOCK >CROSS
   
   [IFDEF] extend-cross extend-cross [THEN]
   
   LOCK

Removed from v.1.52  
changed lines
  Added in v.1.96


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