[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.73 and 1.86

version 1.73, Wed May 5 12:07:55 1999 UTC version 1.86, Sat Sep 23 15:05:58 2000 UTC
Line 1 
Line 1 
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
   
 \ Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 31 
Line 31 
   
 [THEN]  [THEN]
   
   hex
   
   \ debugging for compiling
   
   \ print stack at each colon definition
   \ : : save-input cr bl word count type restore-input throw .s : ;
   
   \ print stack at each created word
   \ : create save-input cr bl word count type restore-input throw .s create ;
   
   
   \ \ -------------  Setup Vocabularies
   
   \ Remark: Vocabulary is not ANS, but it should work...
   
   Vocabulary Cross
   Vocabulary Target
   Vocabulary Ghosts
   Vocabulary Minimal
   only Forth also Target also also
   definitions Forth
   
   : T  previous Ghosts also Target ; immediate
   : G  Ghosts ; immediate
   : H  previous Forth also Cross ; immediate
   
   forth definitions
   
   : T  previous Ghosts also Target ; immediate
   : G  Ghosts ; immediate
   
   : >cross  also Cross definitions previous ;
   : >target also Target definitions previous ;
   : >minimal also Minimal definitions previous ;
   
   H
   
   >CROSS
   
   \ find out whether we are compiling with gforth
   
   : defined? bl word find nip ;
   defined? emit-file defined? toupper and \ drop 0
   [IF]
   \ use this in a gforth system
   : \GFORTH ; immediate
   : \ANSI postpone \ ; immediate
   [ELSE]
   : \GFORTH postpone \ ; immediate
   : \ANSI ; immediate
   [THEN]
   
   \ANSI : [IFUNDEF] defined? 0= postpone [IF] ; immediate
   \ANSI : [IFDEF] defined? postpone [IF] ; immediate
   0 \ANSI drop 1
   [IF]
   : \G postpone \ ; immediate
   : rdrop postpone r> postpone drop ; immediate
   : name bl word count ;
   : bounds over + swap ;
   : scan >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN rdrop ;
   : linked here over @ , swap ! ;
   : alias create , DOES> @ EXECUTE ;
   : defer ['] noop alias ;
   : is state @
     IF ' >body postpone literal postpone !
     ELSE ' >body ! THEN ; immediate
   : 0>= 0< 0= ;
   : d<> rot <> -rot <> or ;
   : toupper dup [char] a [char] z 1+ within IF [char] A [char] a - + THEN ;
   Variable ebuf
   : emit-file ( c fd -- ior ) swap ebuf c! ebuf 1 chars rot write-file ;
   0a Constant #lf
   0d Constant #cr
   
   [IFUNDEF] Warnings Variable Warnings [THEN]
   
   \ \ Number parsing                                      23feb93py
   
   \ number? number                                       23feb93py
   
   Variable dpl
   
   hex
   Create bases   10 ,   2 ,   A , 100 ,
   \              16     2    10   character
   
   \ !! protect BASE saving wrapper against exceptions
   : getbase ( addr u -- addr' u' )
       over c@ [char] $ - dup 4 u<
       IF
           cells bases + @ base ! 1 /string
       ELSE
           drop
       THEN ;
   
   : sign? ( addr u -- addr u flag )
       over c@ [char] - =  dup >r
       IF
           1 /string
       THEN
       r> ;
   
   : s>unumber? ( addr u -- ud flag )
       over [char] ' =
       IF  \ a ' alone is rather unusual :-)
           drop char+ c@ 0 true EXIT
       THEN
       base @ >r  dpl on  getbase
       0. 2swap
       BEGIN ( d addr len )
           dup >r >number dup
       WHILE \ there are characters left
           dup r> -
       WHILE \ the last >number parsed something
           dup 1- dpl ! over c@ [char] . =
       WHILE \ the current char is '.'
           1 /string
       REPEAT  THEN \ there are unparseable characters left
           2drop false
       ELSE
           rdrop 2drop true
       THEN
       r> base ! ;
   
   \ ouch, this is complicated; there must be a simpler way - anton
   : s>number? ( addr len -- d f )
       \ converts string addr len into d, flag indicates success
       sign? >r
       s>unumber?
       0= IF
           rdrop false
       ELSE \ no characters left, all ok
           r>
           IF
               dnegate
           THEN
           true
       THEN ;
   
   : s>number ( addr len -- d )
       \ don't use this, there is no way to tell success
       s>number? drop ;
   
   : snumber? ( c-addr u -- 0 / n -1 / d 0> )
       s>number? 0=
       IF
           2drop false  EXIT
       THEN
       dpl @ dup 0< IF
           nip
       ELSE
           1+
       THEN ;
   
   : number? ( string -- string 0 / n -1 / d 0> )
       dup >r count snumber? dup if
           rdrop
       else
           r> swap
       then ;
   
   : number ( string -- d )
       number? ?dup 0= abort" ?"  0<
       IF
           s>d
       THEN ;
   
   [THEN]
   
 hex     \ the defualt base for the cross-compiler is hex !!  hex     \ the defualt base for the cross-compiler is hex !!
 Warnings off  \ Warnings off
   
 \ words that are generaly useful  \ words that are generaly useful
   
Line 48 
Line 217 
     \ puts down string as cstring      \ puts down string as cstring
     dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;
   
   : ," [char] " parse string, ;
   
 : SetValue ( n -- <name> )  : SetValue ( n -- <name> )
 \G Same behaviour as "Value" if the <name> is not defined  \G Same behaviour as "Value" if the <name> is not defined
 \G Same behaviour as "to" if <name> is defined  \G Same behaviour as "to" if <name> is defined
Line 58 
Line 229 
         \ we have to set current to be topmost context wordlist          \ we have to set current to be topmost context wordlist
         get-order get-order get-current swap 1+ set-order          get-order get-order get-current swap 1+ set-order
         r> ['] to execute          r> ['] to execute
         set-order order          set-order
   ELSE Value THEN ;    ELSE Value THEN ;
   
 : DefaultValue ( n -- <name> )  : DefaultValue ( n -- <name> )
Line 70 
Line 241 
   
 hex  hex
   
 Vocabulary Cross  
 Vocabulary Target  
 Vocabulary Ghosts  
 VOCABULARY Minimal  
 only Forth also Target also also  
 definitions Forth  
   
 : T  previous Cross also Target ; immediate  
 : G  Ghosts ; immediate  
 : H  previous Forth also Cross ; immediate  
   
 forth definitions  
   
 : T  previous Cross also Target ; immediate  
 : G  Ghosts ; immediate  
   
 : >cross  also Cross definitions previous ;  
 : >target also Target definitions previous ;  
 : >minimal also Minimal definitions previous ;  
   
 H  
   
 >CROSS  
   
 \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are  \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are
                         \ for cross-compiling                          \ for cross-compiling
 \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!  \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!
Line 106 
Line 253 
   
 \ 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 118 
Line 606 
 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  : .dec
Line 143 
Line 628 
 : 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 153 
Line 636 
 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 171 
Line 654 
 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  \ iForth makes only immediate directly after create
 \ make atonce trick! ?  \ make atonce trick! ?
   
 Variable atonce atonce off  Variable atonce atonce off
   
 : NoExec true ABORT" CROSS: Don't execute ghost" ;  : NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;
   
 : GhostHeader <fwd> , 0 , ['] NoExec , ;  : GhostHeader <fwd> , 0 , ['] NoExec , ;
   
Line 205 
Line 689 
   
 : 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 222 
Line 706 
   
 : 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 235 
Line 719 
         s" ?!?!?!"          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 281 
Line 770 
 : has?  bl word count T environment? H  : has?  bl word count T environment? H
         IF      \ environment variable is present, return its value          IF      \ environment variable is present, return its value
         ELSE    \ environment variable is not present, return false          ELSE    \ environment variable is not present, return false
                 \ !! JAW abort is just for testing                  false \ debug true ABORT" arg"
                 false true ABORT" arg"  
         THEN ;          THEN ;
   
 : $has? T environment? H IF ELSE false THEN ;  : $has? T environment? H IF ELSE false THEN ;
Line 293 
Line 781 
 true SetValue standard-threading  true SetValue standard-threading
 >TARGET previous  >TARGET previous
   
   0
 mach-file count included hex  [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
   
Line 344 
Line 836 
 8 Constant bits/byte    \ we define: byte is address-unit  8 Constant bits/byte    \ we define: byte is address-unit
   
 1 bits/byte lshift Constant maxbyte  1 bits/byte lshift Constant maxbyte
 \ this sets byte size for the target machine, an (probably right guess) jaw  \ this sets byte size for the target machine, (probably right guess) jaw
   
 T  T
 NIL                     Constant TNIL  NIL                     Constant TNIL
Line 362 
Line 854 
 bits/byte               Constant tbits/byte  bits/byte               Constant tbits/byte
 [THEN]  [THEN]
 H  H
 tbits/byte bits/byte /  Constant tbyte  tbits/char bits/byte /  Constant tbyte
   
   
 \ Variables                                            06oct92py  \ Variables                                            06oct92py
Line 425 
Line 917 
   dup >rstart @ swap >rdp @ 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 >rstart swap >rlen @ ;    dup >rstart @ swap >rlen @ ;
   
 : mirrored                              \G mark a region as mirrored  : mirrored                              \G mark a region as mirrored
   mirrored-link    mirrored-link
Line 435 
Line 927 
 \G prints a 16 or 32 Bit nice hex value  \G prints a 16 or 32 Bit nice hex value
   base @ >r hex    base @ >r hex
   tcell 2 u>    tcell 2 u>
   IF s>d <# # # # # '. hold # # # # #> type    IF s>d <# # # # # [char] . hold # # # # #> type
   ELSE s>d <# # # # # # #> type    ELSE s>d <# # # # # # #> type
   THEN r> base ! ;    THEN r> base ! ;
   
Line 678 
Line 1170 
 : +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 ;  : (relon) ( taddr -- )
 : (reloff) ( taddr -- ) bit$ @ swap cell/ -bit ;    [ [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 @ + ;  : (>image) ( taddr -- absaddr ) image @ + ;
   
Line 720 
Line 1223 
 : c@ ( taddr -- char )  >image Sc@ ;  : c@ ( taddr -- char )  >image Sc@ ;
 : c! ( char taddr -- )  >image Sc! ;  : c! ( char taddr -- )  >image Sc! ;
 : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;  : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
 : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;  : 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ;
   
 \ Target compilation primitives                        06oct92py  \ Target compilation primitives                        06oct92py
 \ included A!                                          16may93jaw  \ included A!                                          16may93jaw
   
 : here  ( -- there )    there ;  : here  ( -- there )    there ;
 : allot ( n -- )        tdp +! ;  : allot ( n -- )        tdp +! ;
 : ,     ( w -- )        T here H tcell T allot  ! H T here drop H ;  : ,     ( w -- )        T here H tcell T allot  ! H ;
 : c,    ( char -- )     T here    tchar allot c! H ;  : c,    ( char -- )     T here H tchar T allot c! H ;
 : align ( -- )          T here H align+ 0 ?DO  bl T c, tchar H +LOOP ;  : align ( -- )          T here H align+ 0 ?DO  bl T c, H tchar +LOOP ;
 : cfalign ( -- )  : cfalign ( -- )
     T here H cfalign+ 0 ?DO  bl T c, tchar H +LOOP ;      T here H cfalign+ 0 ?DO  bl T c, H tchar +LOOP ;
   
 : >address              dup 0>= IF tbyte / THEN ; \ ?? jaw  : >address              dup 0>= IF tbyte / THEN ; \ ?? jaw
 : A!                    swap >address swap dup relon T ! H ;  : A!                    swap >address swap dup relon T ! H ;
Line 748 
Line 1251 
 \ \ Load Assembler  \ \ 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 838 
Line 1340 
 : compile, colon, ;  : compile, colon, ;
 >CROSS  >CROSS
   
 \ file loading  
   
 : >fl-id   1 cells + ;  
 : >fl-name 2 cells + ;  
   
 Variable filelist 0 filelist !  
 Create NoFile ," #load-file#"  
 0 Value  filemem  
 : loadfile  FileMem ?dup IF >fl-name ELSE NoFile THEN ;  
   
 1 [IF] \ !! JAW WIP  
   
 : add-included-file ( adr len -- )  
         dup char+ >fl-name allocate throw >r  
         r@ >fl-name place  
         filelist @ r@ !  
         r> dup filelist ! to FileMem  
         ;  
   
 : included? ( c-addr u -- f )  
         filelist  
         BEGIN   @ dup  
         WHILE   >r r@ 1 cells + count compare 0=  
                 IF rdrop 2drop true EXIT THEN  
                 r>  
         REPEAT  
         2drop drop false ;  
   
 : included  
 \       cr ." Including: " 2dup type ." ..."  
         FileMem >r  
         2dup add-included-file included  
         r> to FileMem ;  
   
 : include bl word count included ;  
   
 : require bl word count included ;  
   
 [THEN]  
   
 \ resolve structure  \ resolve structure
   
 : >next ;               \ link to next field  : >next ;               \ link to next field
Line 917 
Line 1379 
 Defer resolve-warning  Defer resolve-warning
   
 : reswarn-test ( ghost res-struct -- ghost res-struct )  : reswarn-test ( ghost res-struct -- ghost res-struct )
   over cr ." Resolving " >ghostname type dup ."  in " >ghost @ >ghostname type ;    over cr ." Resolving " .ghost dup ."  in " >ghost @ .ghost ;
   
 : reswarn-forward ( ghost res-struct -- ghost res-struct )  : reswarn-forward ( ghost res-struct -- ghost res-struct )
   over warnhead >ghostname type dup ."  is referenced in "    over warnhead .ghost dup ."  is referenced in "
   >ghost @ >ghostname type ;    >ghost @ .ghost ;
   
 \ ' reswarn-test IS resolve-warning  \ ' reswarn-test IS resolve-warning
   
Line 970 
Line 1432 
 \G resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
     \ is ghost resolved?, second resolve means another definition with the      \ is ghost resolved?, second resolve means another definition with the
     \ same name      \ same name
     over forward? 0= IF  exists EXIT THEN      over undefined? 0= IF  exists EXIT THEN
     \ get linked-list      \ get linked-list
     swap >r r@ >link @ swap \ ( list tcfa R: ghost )      swap >r r@ >link @ swap \ ( list tcfa R: ghost )
     \ mark ghost as resolved      \ mark ghost as resolved
Line 1014 
Line 1476 
         >link          >link
         BEGIN   @ dup          BEGIN   @ dup
         WHILE   cr 5 spaces          WHILE   cr 5 spaces
                 dup >ghost @ >ghostname type                  dup >ghost @ .ghost
                 ."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN                  ."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN
                 ."  line " dup >line @ .dec                  ."  line " dup >line @ .dec
         REPEAT          REPEAT
Line 1028 
Line 1490 
   ELSE  drop    ELSE  drop
   THEN ;    THEN ;
   
 >MINIMAL  
 : .unresolved  ( -- )  : .unresolved  ( -- )
   ResolveFlag off cr ." Unresolved: "    ResolveFlag off cr ." Unresolved: "
   Ghostnames    Ghostnames
Line 1047 
Line 1508 
   cr ." named Headers: " headers-named @ .    cr ." named Headers: " headers-named @ .
   r> base ! ;    r> base ! ;
   
   >MINIMAL
   
   : .unresolved .unresolved ;
   
 >CROSS  >CROSS
 \ Header states                                        12dec92py  \ Header states                                        12dec92py
   
Line 1067 
Line 1532 
                 <do:> last-header-ghost @ >magic ! ;                  <do:> last-header-ghost @ >magic ! ;
 >CROSS  >CROSS
   
 \ ALIAS2 ansforth conform alias                          9may93jaw  
   
 : ALIAS2 create here 0 , DOES> @ execute ;  
 \ usage:  
 \ ' <name> alias2 bla !  
   
 \ Target Header Creation                               01nov92py  \ Target Header Creation                               01nov92py
   
 >TARGET  >TARGET
Line 1098 
Line 1557 
     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 1120 
Line 1580 
 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 1135 
Line 1595 
         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 1147 
Line 1607 
   
 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 1169 
Line 1645 
   
 \ Target header creation  \ Target header creation
   
 Variable CreateFlag  
 CreateFlag off  
   
 Variable NoHeaderFlag  Variable NoHeaderFlag
 NoHeaderFlag off  NoHeaderFlag off
   
Line 1179 
Line 1652 
     base @ >r hex      base @ >r hex
     0 swap <# 0 ?DO # LOOP #> type      0 swap <# 0 ?DO # LOOP #> type
     r> base ! ;      r> base ! ;
 : .sym  
   : .sym ( adr len -- )
   \G escapes / and \ to produce sed output
   bounds    bounds
   DO I c@ dup    DO I c@ dup
         CASE    '/ OF drop ." \/" ENDOF          CASE    [char] / OF drop ." \/" ENDOF
                 '\ OF drop ." \\" ENDOF                  [char] \ OF drop ." \\" ENDOF
                 dup OF emit ENDOF                  dup OF emit ENDOF
         ENDCASE          ENDCASE
     LOOP ;      LOOP ;
Line 1197 
Line 1672 
     IF  NoHeaderFlag off      IF  NoHeaderFlag off
     ELSE      ELSE
         T align H view,          T align H view,
         tlast @ dup 0> IF  T 1 cells - H THEN T A, H  there tlast !          tlast @ dup 0> IF tcell - THEN T A, H  there tlast !
         1 headers-named +!      \ Statistic          1 headers-named +!      \ Statistic
         >in @ T name, H >in !          >in @ T name, H >in !
     THEN      THEN
     T cfalign here H tlastcfa !      T cfalign here H tlastcfa !
     \ Symbol table      \ Old Symbol table sed-script
 \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !  \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
     CreateFlag @      ghost
     IF      \ output symbol table to extra file
         >in @ alias2 swap >in !         \ create alias in target      [ [IFDEF] fd-symbol-table ]
         >in @ ghost swap >in !        base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !
         swap also ghosts ' previous swap !     \ tick ghost and store in alias        s" :" fd-symbol-table write-file throw
         CreateFlag off        dup >ghostname fd-symbol-table write-line throw
     ELSE ghost      [ [THEN] ]
     THEN  
     dup Last-Header-Ghost !      dup Last-Header-Ghost !
     dup >magic ^imm !     \ a pointer for immediate      dup >magic ^imm !     \ a pointer for immediate
     Already @      Already @
Line 1289 
Line 1763 
   THEN ; immediate    THEN ; immediate
   
 : ghost>cfa  : ghost>cfa
   dup forward? ABORT" CROSS: forward " >link @ ;    dup undefined? ABORT" CROSS: forward " >link @ ;
   
 >TARGET  >TARGET
   
Line 1310 
Line 1784 
 \ modularized                                           14jun97jaw  \ modularized                                           14jun97jaw
   
 : fillcfa   ( usedcells -- )  : fillcfa   ( usedcells -- )
   T cells H xt>body swap - 0 ?DO 0 T c, tchar 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
   
Line 1332 
Line 1806 
 : (lit,) ( n -- )   compile lit T  ,  H ;       ' (lit,) IS lit,  : (lit,) ( n -- )   compile lit T  ,  H ;       ' (lit,) IS lit,
   
 \ if we dont produce relocatable code alit, defaults to lit, jaw  \ if we dont produce relocatable code alit, defaults to lit, jaw
 has? relocate  \ this is just for convenience, so we don't have to define alit,
   \ seperately for embedded systems....
   T has? relocate H
 [IF]  [IF]
 : (alit,) ( n -- )  compile lit T  a, H ;       ' (alit,) IS alit,  : (alit,) ( n -- )  compile lit T  a, H ;       ' (alit,) IS alit,
 [ELSE]  [ELSE]
Line 1366 
Line 1842 
     ELSE true ABORT" CROSS: Stack empty" THEN      ELSE true ABORT" CROSS: Stack empty" THEN
     ;      ;
   
 ( Cond ) : chars tchar * ; ( Cond )  
   
 >CROSS  >CROSS
   
 \ tLiteral                                             12dec92py  \ tLiteral                                             12dec92py
Line 1390 
Line 1864 
   restrict?    restrict?
   tcell 1 cells u>    tcell 1 cells u>
   IF    compile lit tcell 0 ?DO FF T c, H LOOP    IF    compile lit tcell 0 ?DO FF T c, H LOOP
   ELSE  $ffffffff lit, THEN    ELSE  ffffffff lit, THEN
   ;Cond    ;Cond
   
 Cond: MINI  Cond: MINI
Line 1400 
Line 1874 
         IF      80 T c, H tcell 1 ?DO 0 T c, H LOOP          IF      80 T c, H tcell 1 ?DO 0 T c, H LOOP
         ELSE    tcell 1 ?DO 0 T c, H LOOP 80 T c, H          ELSE    tcell 1 ?DO 0 T c, H LOOP 80 T c, H
         THEN          THEN
   ELSE  tcell 2 = IF $8000 ELSE $80000000 THEN lit, THEN    ELSE  tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN
   ;Cond    ;Cond
   
 Cond: MAXI  Cond: MAXI
Line 1410 
Line 1884 
         IF      7F T c, H tcell 1 ?DO FF T c, H LOOP          IF      7F T c, H tcell 1 ?DO FF T c, H LOOP
         ELSE    tcell 1 ?DO FF T c, H LOOP 7F T c, H          ELSE    tcell 1 ?DO FF T c, H LOOP 7F T c, H
         THEN          THEN
  ELSE   tcell 2 = IF $7fff ELSE $7fffffff THEN lit, THEN   ELSE   tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN
  ;Cond   ;Cond
   
 >CROSS  >CROSS
 \ Target compiling loop                                12dec92py  \ Target compiling loop                                12dec92py
 \ ">tib trick thrown out                               10may93jaw  \ ">tib trick thrown out                               10may93jaw
 \ number? defined at the top                           11may93jaw  \ number? defined at the top                           11may93jaw
   \ replaced >in by save-input
   
   : discard 0 ?DO drop LOOP ;
   
 \ compiled word might leave items on stack!  \ compiled word might leave items on stack!
 : tcom ( in name -- )  : tcom ( x1 .. xn n name -- )
   gfind  ?dup  IF    0> IF    nip >exec @ execute  \  dup count type space
                         ELSE  nip gexecute  THEN EXIT THEN    gfind  ?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
Line 1433 
Line 1915 
 : ] state on  : ] state on
     Compiling comp-state !      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 1512 
Line 1994 
 \ 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:-xt ghost )
   Make-Ghost    rot swap              ( do:-xt Create-xt ghost )
   rot swap >exec dup @ ['] NoExec <>    >exec ! , ;
   IF 2drop ELSE ! THEN  \  rot swap >exec dup @ ['] NoExec <>
   ,  \  IF 2drop ELSE ! THEN , ;
   r> r> >in !  
   also ghosts ' previous swap ! ;  
 \  DOES>  dup >exec @ execute ;  
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
   >end @ dup forward? 0=    >end @ dup undefined? 0=
   IF    IF
         dup >magic @ <do:> =          dup >magic @ <do:> =
         IF       doer,          IF       doer,
Line 1539 
Line 2018 
   
 : 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 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 @ >exec @ r> >exec dup @ ['] NoExec =
     IF ! ELSE 2drop THEN ;
   
 : 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
Line 1560 
Line 2040 
   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 ;
Line 1652 
Line 2136 
 \ 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
 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 1686 
Line 2174 
 by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 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 1714 
Line 2202 
 : cell% ( n -- size align )  : cell% ( n -- size align )
     T 1 cells H dup ;      T 1 cells H dup ;
   
 \ ' 2Constant Alias2 end-struct  
 \ 0 1 T Chars H 2Constant struct  
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS
Line 1726 
Line 2211 
   
 : branchoffset ( src dest -- ) - tchar / ; \ ?? jaw  : branchoffset ( src dest -- ) - tchar / ; \ ?? jaw
   
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  : >resolve    ( sys -- )
           X here ( dup ." >" hex. ) over branchoffset swap X ! ;
   
 : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;  : <resolve    ( sys -- )
           X here ( dup ." <" hex. ) branchoffset X , ;
   
 :noname compile branch T here branchoffset , H ;  :noname compile branch X here branchoffset X , ;
   IS branch, ( target-addr -- )    IS branch, ( target-addr -- )
 :noname compile ?branch T here branchoffset , H ;  :noname compile ?branch X here branchoffset X , ;
   IS ?branch, ( target-addr -- )    IS ?branch, ( target-addr -- )
 :noname compile branch T here 0 , H ;  :noname compile branch T here 0 , H ;
   IS branchmark, ( -- branchtoken )    IS branchmark, ( -- branchtoken )
Line 1740 
Line 2227 
   IS ?branchmark, ( -- branchtoken )    IS ?branchmark, ( -- branchtoken )
 :noname T here 0 , H ;  :noname T here 0 , H ;
   IS ?domark, ( -- branchtoken )    IS ?domark, ( -- branchtoken )
 :noname dup T @ H ?struc T here over branchoffset swap ! H ;  :noname dup X @ ?struc X here over branchoffset swap X ! ;
   IS branchtoresolve, ( branchtoken -- )    IS branchtoresolve, ( branchtoken -- )
 :noname branchto, T here H ;  :noname branchto, X here ;
   IS branchtomark, ( -- target-addr )    IS branchtomark, ( -- target-addr )
   
 >TARGET  >TARGET
Line 1752 
Line 2239 
 Cond: BUT       restrict? sys? swap ;Cond  Cond: BUT       restrict? sys? swap ;Cond
 Cond: YET       restrict? sys? dup ;Cond  Cond: YET       restrict? sys? dup ;Cond
   
 0 [IF]  
 >CROSS  
 Variable tleavings  
 >TARGET  
   
 Cond: DONE   ( addr -- )  restrict? tleavings @  
       BEGIN  2dup u> 0=  WHILE  dup T @ H swap >resolve REPEAT  
       tleavings ! drop ;Cond  
   
 >CROSS  >CROSS
 : (leave)  T here H tleavings @ T , H  tleavings ! ;  
 >TARGET  
   
 Cond: LEAVE     restrict? compile branch (leave) ;Cond  
 Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave)  ;Cond  
   
 [ELSE]  
     \ !! This is WIP  
     \ The problem is (?DO)!  
     \ perhaps we need a plug-in for (?DO)  
   
 >CROSS  
 Variable tleavings 0 tleavings !  Variable tleavings 0 tleavings !
   
 : (done) ( addr -- )  : (done) ( addr -- )
     tleavings @      tleavings @
     BEGIN  dup      BEGIN  dup
Line 1804 
Line 2272 
 Cond: LEAVE     restrict? branchmark, (leave) ;Cond  Cond: LEAVE     restrict? branchmark, (leave) ;Cond
 Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave)  ;Cond  Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave)  ;Cond
   
 [THEN]  
   
 >CROSS  >CROSS
 \ !!JW ToDo : Move to general tools section  \ !!JW ToDo : Move to general tools section
   
Line 1900 
Line 2366 
 \ 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 1929 
Line 2395 
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) addr, 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 definitions
   
 >MINIMAL  >MINIMAL also minimal
 also minimal  
 \ Usefull words                                        13feb93py  \ Usefull words                                        13feb93py
   
 : KB  400 * ;  : KB  400 * ;
Line 1953 
Line 2467 
 : [ELSE]  : [ELSE]
     1 BEGIN      1 BEGIN
         BEGIN bl word count dup WHILE          BEGIN bl word count dup WHILE
             comment? parsed place upcase parsed count              comment? 20 umin parsed place upcase parsed count
             2dup s" [IF]" compare 0= >r              2dup s" [IF]" compare 0= >r
             2dup s" [IFUNDEF]" compare 0= >r              2dup s" [IFUNDEF]" compare 0= >r
             2dup s" [IFDEF]" compare 0= r> or r> or              2dup s" [IFDEF]" compare 0= r> or r> or
Line 1986 
Line 2500 
   
 \ define new [IFDEF] and [IFUNDEF]                      20may93jaw  \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
   
 : defined? defined? ;  : defined? tdefined? ;
 : needed? needed? ;  : needed? needed? ;
 : doer? doer? ;  : doer? doer? ;
   
 \ we want to use IFDEF on compiler directives (e.g. E?) in the source, too  \ we want to use IFDEF on compiler directives (e.g. E?) in the source, too
   
 : directive?  : directive?
   bl word count [ ' target >wordlist ] aliteral search-wordlist    bl word count [ ' target >wordlist ] literal search-wordlist
   dup IF nip THEN ;    dup IF nip THEN ;
   
 : [IFDEF]  >in @ directive? swap >in !  : [IFDEF]  >in @ directive? swap >in !
            0= IF defined? ELSE name 2drop true THEN             0= IF tdefined? ELSE name 2drop true THEN
            postpone [IF] ;             postpone [IF] ;
   
 : [IFUNDEF] defined? 0= postpone [IF] ;  : [IFUNDEF] tdefined? 0= postpone [IF] ;
   
 Cond: [IFDEF]   postpone [IFDEF] ;Cond  Cond: [IFDEF]   postpone [IFDEF] ;Cond
   
Line 2008 
Line 2522 
   
 \ 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 2018 
Line 2532 
         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 2039 
Line 2553 
 \G defines ghost for words that we want to be compiled  \G defines ghost for words that we want to be compiled
   BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;    BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;
   
 previous  
   
 \ save-cross                                           17mar93py  
   
 >CROSS  
 Create magic  s" Gforth2x" here over allot swap move  
   
 bigendian 1+ \ strangely, in magic big=0, little=1  
 tcell 1 = 0 and or  
 tcell 2 = 2 and or  
 tcell 4 = 4 and or  
 tcell 8 = 6 and or  
 tchar 1 = $00 and or  
 tchar 2 = $28 and or  
 tchar 4 = $50 and or  
 tchar 8 = $78 and or  
 magic 7 + c!  
   
 : save-cross ( "image-name" "binary-name" -- )  
   bl parse ." Saving to " 2dup type cr  
   w/o bin create-file throw >r  
   TNIL IF  
       s" #! "   r@ write-file throw  
       bl parse  r@ write-file throw  
       s"  -i"   r@ write-file throw  
       #lf       r@ emit-file throw  
       r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )  
       ?do  
           bl over emit-file throw  
       loop  
       drop  
       magic 8       r@ write-file throw \ write magic  
   ELSE  
       bl parse 2drop  
   THEN  
   image @ there  
   r@ write-file throw \ write image  
   TNIL IF  
       bit$  @ there 1- tcell>bit rshift 1+  
                 r@ write-file throw \ write tags  
   THEN  
   r> close-file throw ;  
   
 : save-region ( addr len -- )  
   bl parse w/o bin create-file throw >r  
   swap >image swap r@ write-file throw  
   r> close-file throw ;  
   
 \ words that should be in minimal  \ words that should be in minimal
   
 create s-buffer 50 chars allot  create s-buffer 50 chars allot
   
 >MINIMAL  
 also minimal  
   
 bigendian Constant bigendian  bigendian Constant bigendian
   
 : here there ;  : here there ;
 : equ constant ;  : equ constant ;
 : mark there constant ;  : mark there constant ;
Line 2117 
Line 2581 
 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 2143 
Line 2606 
 : 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 2156 
Line 2620 
 : ." [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 2185 
Line 2649 
 : T minimal ; immediate  : T minimal ; immediate
 : G ghosts ; immediate  : G ghosts ; immediate
   
 : turnkey  0 set-order also Target definitions  : turnkey
      \GFORTH 0 set-order also ghosts
      \ANSI [ ' ghosts >wordlist ] Literal 1 set-order
      also target definitions
            also Minimal also ;             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

Generate output suitable for use with a patch program
Legend:
Removed from v.1.73  
changed lines
  Added in v.1.86
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help