Diff for /gforth/cross.fs between versions 1.75 and 1.80

version 1.75, 1999/05/10 13:57:37 version 1.80, 1999/07/24 13:07:18
Line 31  Clean up mark> and >resolve stuff jaw Line 31  Clean up mark> and >resolve stuff jaw
   
 [THEN]  [THEN]
   
   hex
   
   \ debugging for compiling
   
   \ print stack at each colon definition
   \ : : save-input cr bl word count type restore-input throw .s : ;
   
   \ print stack at each created word
   \ : create save-input cr bl word count type restore-input throw .s create ;
   
   
   \ \ -------------  Setup Vocabularies
   
   \ Remark: Vocabulary is not ANS, but it should work...
   
   Vocabulary Cross
   Vocabulary Target
   Vocabulary Ghosts
   Vocabulary Minimal
   only Forth also Target also also
   definitions Forth
   
   : T  previous Ghosts also Target ; immediate
   : G  Ghosts ; immediate
   : H  previous Forth also Cross ; immediate
   
   forth definitions
   
   : T  previous Ghosts also Target ; immediate
   : G  Ghosts ; immediate
   
   : >cross  also Cross definitions previous ;
   : >target also Target definitions previous ;
   : >minimal also Minimal definitions previous ;
   
   H
   
   >CROSS
   
   \ find out whether we are compiling with gforth
   
   : defined? bl word find nip ;
   defined? emit-file defined? toupper and \ drop 0
   [IF]
   \ use this in a gforth system
   : \GFORTH ; immediate
   : \ANSI postpone \ ; immediate
   [ELSE]
   : \GFORTH postpone \ ; immediate
   : \ANSI ; immediate
   [THEN]
   
   \ANSI : [IFUNDEF] defined? 0= postpone [IF] ; immediate
   \ANSI : [IFDEF] defined? postpone [IF] ; immediate
   0 \ANSI drop 1
   [IF]
   : \G postpone \ ; immediate
   : rdrop postpone r> postpone drop ; immediate
   : name bl word count ;
   : bounds over + swap ;
   : scan >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN rdrop ;
   : linked here over @ , swap ! ;
   : alias create , DOES> @ EXECUTE ;
   : defer ['] noop alias ;
   : is state @ 
     IF ' >body postpone literal postpone ! 
     ELSE ' >body ! THEN ; immediate
   : 0>= 0< 0= ;
   : d<> rot <> -rot <> or ;
   : toupper dup [char] a [char] z 1+ within IF [char] A [char] a - + THEN ;
   Variable ebuf
   : emit-file ( c fd -- ior ) swap ebuf c! ebuf 1 chars rot write-file ;
   0a Constant #lf
   0d Constant #cr
   
   [IFUNDEF] Warnings Variable Warnings [THEN]
   
   \ \ Number parsing                                      23feb93py
   
   \ number? number                                       23feb93py
   
   Variable dpl
   
   hex
   Create bases   10 ,   2 ,   A , 100 ,
   \              16     2    10   character
   
   \ !! protect BASE saving wrapper against exceptions
   : getbase ( addr u -- addr' u' )
       over c@ [char] $ - dup 4 u<
       IF
           cells bases + @ base ! 1 /string
       ELSE
           drop
       THEN ;
   
   : sign? ( addr u -- addr u flag )
       over c@ [char] - =  dup >r
       IF
           1 /string
       THEN
       r> ;
   
   : s>unumber? ( addr u -- ud flag )
       over [char] ' =
       IF  \ a ' alone is rather unusual :-)
           drop char+ c@ 0 true EXIT 
       THEN
       base @ >r  dpl on  getbase
       0. 2swap
       BEGIN ( d addr len )
           dup >r >number dup
       WHILE \ there are characters left
           dup r> -
       WHILE \ the last >number parsed something
           dup 1- dpl ! over c@ [char] . =
       WHILE \ the current char is '.'
           1 /string
       REPEAT  THEN \ there are unparseable characters left
           2drop false
       ELSE
           rdrop 2drop true
       THEN
       r> base ! ;
   
   \ ouch, this is complicated; there must be a simpler way - anton
   : s>number? ( addr len -- d f )
       \ converts string addr len into d, flag indicates success
       sign? >r
       s>unumber?
       0= IF
           rdrop false
       ELSE \ no characters left, all ok
           r>
           IF
               dnegate
           THEN
           true
       THEN ;
   
   : s>number ( addr len -- d )
       \ don't use this, there is no way to tell success
       s>number? drop ;
   
   : snumber? ( c-addr u -- 0 / n -1 / d 0> )
       s>number? 0=
       IF
           2drop false  EXIT
       THEN
       dpl @ dup 0< IF
           nip
       ELSE
           1+
       THEN ;
   
   : number? ( string -- string 0 / n -1 / d 0> )
       dup >r count snumber? dup if
           rdrop
       else
           r> swap
       then ;
   
   : number ( string -- d )
       number? ?dup 0= abort" ?"  0<
       IF
           s>d
       THEN ;
   
   [THEN]
   
 hex     \ the defualt base for the cross-compiler is hex !!  hex     \ the defualt base for the cross-compiler is hex !!
 Warnings off  \ Warnings off
   
 \ words that are generaly useful  \ words that are generaly useful
   
Line 48  Warnings off Line 217  Warnings off
     \ puts down string as cstring      \ puts down string as cstring
     dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;
   
   : ," [char] " parse string, ;
   
 : SetValue ( n -- <name> )  : SetValue ( n -- <name> )
 \G Same behaviour as "Value" if the <name> is not defined  \G Same behaviour as "Value" if the <name> is not defined
 \G Same behaviour as "to" if <name> is defined  \G Same behaviour as "to" if <name> is defined
Line 70  Warnings off Line 241  Warnings off
   
 hex  hex
   
 Vocabulary Cross  
 Vocabulary Target  
 Vocabulary Ghosts  
 VOCABULARY Minimal  
 only Forth also Target also also  
 definitions Forth  
   
 : T  previous Cross also Target ; immediate  
 : G  Ghosts ; immediate  
 : H  previous Forth also Cross ; immediate  
   
 forth definitions  
   
 : T  previous Cross also Target ; immediate  
 : G  Ghosts ; immediate  
   
 : >cross  also Cross definitions previous ;  
 : >target also Target definitions previous ;  
 : >minimal also Minimal definitions previous ;  
   
 H  
   
 >CROSS  
   
 \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are  \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are
                         \ for cross-compiling                          \ for cross-compiling
 \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!  \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!
Line 106  H Line 253  H
   
 \ Begin CROSS COMPILER:  \ Begin CROSS COMPILER:
   
   
   
 \ \ --------------------        Error Handling                  05aug97jaw  
   
 \ Flags  
   
 also forth definitions  \ these values may be predefined before  
                         \ the cross-compiler is loaded  
   
 false DefaultValue stack-warn            \ check on empty stack at any definition  
 false DefaultValue create-forward-warn   \ warn on forward declaration of created words  
   
   
   
     
   
 previous >CROSS  
   
 : .dec  
   base @ decimal swap . base ! ;  
   
 : .sourcepos  
   cr sourcefilename type ." :"  
   sourceline# .dec ;  
   
 : warnhead  
 \G display error-message head  
 \G perhaps with linenumber and filename  
   .sourcepos ." Warning: " ;  
   
 : empty? depth IF .sourcepos ." Stack not empty!"  THEN ;  
   
 stack-warn [IF]  
 : defempty? empty? ;  
 [ELSE]  
 : defempty? ; immediate  
 [THEN]  
   
 \ debugging  \ debugging
   
 0 [IF]  0 [IF]
Line 155  its value is true, the flag is switched Line 264  its value is true, the flag is switched
   
 [THEN]  [THEN]
   
   >CROSS
   
 Vocabulary debugflags   \ debug flags for cross  Vocabulary debugflags   \ debug flags for cross
 also debugflags get-order over  also debugflags get-order over
 Constant debugflags-wl  Constant debugflags-wl
Line 185  set-order previous Line 296  set-order previous
         \ POSTPONE false           \ POSTPONE false 
   THEN ; immediate    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 >r -1 >r
     BEGIN dup WHILE
           over c@ pathsep? 
           IF      r@ -1 =
                   IF      r> drop dup >r
                   ELSE    2dup 1 /string 
                           3 min s" ../" compare
                           0=
                           IF      r@ over - ( diff )
                                   2 pick swap - ( dest-adr )
                                   >r 3 /string r> swap 2dup >r >r
                                   move r> r>
                           ELSE    r> drop dup >r
                           THEN
                   THEN
           THEN
           1 /string
     REPEAT 
     r> drop 
     drop r> tuck - ;
   
   : reworkdir ( -- )
     remove~+
     ofile count compact..
     nip ofile c! ;
   
   : open-ofile ( -- fid ior )
       \G opens the file whose name is in ofile
       expandtopic reworkdir
       ofile count r/o open-file ;
   
   : check-path ( adr1 len1 adr2 len2 -- fd 0 | 0 <>0 )
     0 ofile ! >r >r ofile place need/
     r> r> ofile +place
     open-ofile ;
   
   : open-path-file ( addr1 u1 path-addr -- wfileid addr2 u2 0 | ior ) \ gforth
       \G Look in path @var{path-addr} for the file specified by @var{addr1 u1}.
       \G If found, the resulting path and an open file descriptor
       \G are returned. If the file is not found, @var{ior} is non-zero.
     >r
     2dup absolut-path?
     IF    rdrop
           ofile place open-ofile
           dup 0= IF >r ofile count r> THEN EXIT
     ELSE  r> path>counted
           BEGIN  next-path dup
           WHILE  5 pick 5 pick check-path
           0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN
     REPEAT
           2drop 2drop 2drop -38
     THEN ;
   
   : open-fpath-file ( addr1 u1 -- wfileid addr2 u2 0 | ior ) \ gforth
       \G Look in the Forth search path for the file specified by @var{addr1 u1}.
       \G If found, the resulting path and an open file descriptor
       \G are returned. If the file is not found, @var{ior} is non-zero.
       fpath open-path-file ;
   
   fpath= ~+
   
   [THEN]
   
   \ \ --------------------        include require                 13may99jaw
   
   >CROSS
   
   : add-included-file ( adr len -- adr )
     dup >fl-name char+ allocate throw >r
     file-list @ r@ ! r@ file-list !
     r@ >fl-name place r> ;
   
   : included? ( c-addr u -- f )
     file-list
     BEGIN @ dup
     WHILE >r 2dup r@ >fl-name count compare 0=
           IF rdrop 2drop true EXIT THEN
           r>
     REPEAT
     2drop drop false ;    
   
   false DebugFlag showincludedfiles
   
   : included1 ( fd adr u -- )
   \ include file adr u / fd
   \ we don't use fd with include-file, because the forth system
   \ doesn't know the name of the file to get a nice error report
     [d?] showincludedfiles
     IF    cr ." Including: " 2dup type ." ..." THEN
     rot close-file throw
     source-desc >r
     add-included-file to source-desc 
     sourcefilename
     ['] included catch
     r> to source-desc 
     throw ;
   
   : included ( adr len -- )
           cross-file-list to file-list
           open-fpath-file throw 
           included1 ;
   
   : required ( adr len -- )
           cross-file-list to file-list
           open-fpath-file throw \ 2dup cr ." R:" type
           2dup included?
           IF      2drop close-file throw
           ELSE    included1
           THEN ;
   
   : include bl word count included ;
   
   : require bl word count required ;
   
   0 [IF]
   
   also forth definitions previous
   
   : included ( adr len -- ) included ;
   
   : required ( adr len -- ) required ;
   
   : include include ;
   
   : require require ;
   
   [THEN]
   
   >CROSS
   hex
   
   \ \ --------------------        Error Handling                  05aug97jaw
   
   \ Flags
   
   also forth definitions  \ these values may be predefined before
                           \ the cross-compiler is loaded
   
   false DefaultValue stack-warn            \ check on empty stack at any definition
   false DefaultValue create-forward-warn   \ warn on forward declaration of created words
   
   previous >CROSS
   
   : .dec
     base @ decimal swap . base ! ;
   
   : .sourcepos
     cr sourcefilename type ." :"
     sourceline# .dec ;
   
   : warnhead
   \G display error-message head
   \G perhaps with linenumber and filename
     .sourcepos ." Warning: " ;
   
   : empty? depth IF .sourcepos ." Stack not empty!"  THEN ;
   
   stack-warn [IF]
   : defempty? empty? ;
   [ELSE]
   : defempty? ; immediate
   [THEN]
   
 \ \ GhostNames Ghosts                                  9may93jaw  \ \ GhostNames Ghosts                                  9may93jaw
   
 \ second name source to search trough list  \ second name source to search trough list
Line 193  VARIABLE GhostNames Line 646  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 218  hex Line 671  hex
   
 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 246  Variable last-header-ghost \ last ghost Line 699  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 263  VARIABLE Already Line 716  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 276  VARIABLE Already Line 729  VARIABLE Already
         s" ?!?!?!"          s" ?!?!?!"
   THEN ;    THEN ;
   
 ' >ghostname ALIAS @name  : .ghost ( ghost -- ) >ghostname type ;
   
   \ ' >ghostname ALIAS @name
   
 : forward? ( ghost -- flag )  : forward? ( ghost -- flag )
   >magic @ <fwd> = ;    >magic @ <fwd> = ;
Line 336  true  SetValue cross Line 791  true  SetValue cross
 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 387  check-address-unit-bits Line 846  check-address-unit-bits
 8 Constant bits/byte    \ we define: byte is address-unit  8 Constant bits/byte    \ we define: byte is address-unit
   
 1 bits/byte lshift Constant maxbyte   1 bits/byte lshift Constant maxbyte 
 \ this sets byte size for the target machine, an (probably right guess) jaw  \ this sets byte size for the target machine, (probably right guess) jaw
   
 T  T
 NIL                     Constant TNIL  NIL                     Constant TNIL
Line 468  Variable mirrored-link          \ linked Line 927  Variable mirrored-link          \ linked
   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 478  Variable mirrored-link          \ linked Line 937  Variable mirrored-link          \ linked
 \G prints a 16 or 32 Bit nice hex value  \G prints a 16 or 32 Bit nice hex value
   base @ >r hex    base @ >r hex
   tcell 2 u>    tcell 2 u>
   IF s>d <# # # # # '. hold # # # # #> type    IF s>d <# # # # # [char] . hold # # # # #> type
   ELSE s>d <# # # # # # #> type    ELSE s>d <# # # # # # #> type
   THEN r> base ! ;    THEN r> base ! ;
   
Line 770  T has? relocate H Line 1229  T has? relocate H
   
 : 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 793  T has? relocate H Line 1252  T has? relocate H
 >TARGET  >TARGET
 H also Forth definitions  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 881  DEFER comp[     \ ends compilation Line 1339  DEFER comp[     \ ends compilation
 : 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 ;        
   
 false DebugFlag showincludedfiles  
   
 : included   
         [d?] showincludedfiles  
         IF      cr ." Including: " 2dup type ." ..." THEN  
         FileMem >r  
         2dup add-included-file included   
         r> to FileMem ;  
   
 : include bl word count included ;  
   
 : require bl word count included ;  
   
 [THEN]  
   
 \ resolve structure  \ resolve structure
   
 : >next ;               \ link to next field  : >next ;               \ link to next field
Line 963  false DebugFlag showincludedfiles Line 1378  false DebugFlag showincludedfiles
 Defer resolve-warning  Defer resolve-warning
   
 : reswarn-test ( ghost res-struct -- ghost res-struct )  : reswarn-test ( ghost res-struct -- ghost res-struct )
   over cr ." Resolving " >ghostname type dup ."  in " >ghost @ >ghostname type ;    over cr ." Resolving " .ghost dup ."  in " >ghost @ .ghost ;
   
 : reswarn-forward ( ghost res-struct -- ghost res-struct )  : reswarn-forward ( ghost res-struct -- ghost res-struct )
   over warnhead >ghostname type dup ."  is referenced in "     over warnhead .ghost dup ."  is referenced in " 
   >ghost @ >ghostname type ;    >ghost @ .ghost ;
   
 \ ' reswarn-test IS resolve-warning  \ ' reswarn-test IS resolve-warning
     
Line 1060  variable ResolveFlag Line 1475  variable ResolveFlag
         >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 1074  variable ResolveFlag Line 1489  variable ResolveFlag
   ELSE  drop     ELSE  drop 
   THEN ;    THEN ;
   
 >MINIMAL  
 : .unresolved  ( -- )  : .unresolved  ( -- )
   ResolveFlag off cr ." Unresolved: "    ResolveFlag off cr ." Unresolved: "
   Ghostnames    Ghostnames
Line 1093  variable ResolveFlag Line 1507  variable ResolveFlag
   cr ." named Headers: " headers-named @ .     cr ." named Headers: " headers-named @ . 
   r> base ! ;    r> base ! ;
   
   >MINIMAL
   
   : .unresolved .unresolved ;
   
 >CROSS  >CROSS
 \ Header states                                        12dec92py  \ Header states                                        12dec92py
   
Line 1113  VARIABLE ^imm Line 1531  VARIABLE ^imm
                 <do:> last-header-ghost @ >magic ! ;                  <do:> last-header-ghost @ >magic ! ;
 >CROSS  >CROSS
   
 \ ALIAS2 ansforth conform alias                          9may93jaw  
   
 : ALIAS2 create here 0 , DOES> @ execute ;  
 \ usage:  
 \ ' <name> alias2 bla !  
   
 \ Target Header Creation                               01nov92py  \ Target Header Creation                               01nov92py
   
 >TARGET  >TARGET
Line 1144  Variable to-doc  to-doc on Line 1556  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 1166  Create tag-bof 1 c,  0C c, Line 1579  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 1181  Create tag-bof 1 c,  0C c, Line 1594  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 1194  Create tag-bof 1 c,  0C c, Line 1607  Create tag-bof 1 c,  0C c,
 Defer skip? ' false IS skip?  Defer skip? ' false IS skip?
   
 : skipdef ( <name> -- )  : skipdef ( <name> -- )
 \G skip definition of an undefined word in undef-words mode  \G skip definition of an undefined word in undef-words and
   \G all-words mode
     ghost dup forward?      ghost dup forward?
     IF  >magic <skip> swap !      IF  >magic <skip> swap !
     ELSE drop THEN ;      ELSE drop THEN ;
   
 : defined? ( -- flag ) \ name  : tdefined? ( -- flag ) \ name
     ghost undefined? 0= ;      ghost undefined? 0= ;
   
 : defined2? ( -- flag ) \ name  : defined2? ( -- flag ) \ name
Line 1207  Defer skip? ' false IS skip? Line 1621  Defer skip? ' false IS skip?
 \G that's what we want  \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
Line 1226  Defer skip? ' false IS skip? Line 1644  Defer skip? ' false IS skip?
   
 \ Target header creation  \ Target header creation
   
 Variable CreateFlag  
 CreateFlag off  
   
 Variable NoHeaderFlag  Variable NoHeaderFlag
 NoHeaderFlag off  NoHeaderFlag off
   
Line 1239  NoHeaderFlag off Line 1654  NoHeaderFlag off
 : .sym  : .sym
   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 1254  NoHeaderFlag off Line 1669  NoHeaderFlag off
     IF  NoHeaderFlag off      IF  NoHeaderFlag off
     ELSE      ELSE
         T align H view,          T align H view,
         tlast @ dup 0> IF  T 1 cells - H THEN T A, H  there tlast !          tlast @ dup 0> IF tcell - THEN T A, H  there tlast !
         1 headers-named +!      \ Statistic          1 headers-named +!      \ Statistic
         >in @ T name, H >in !          >in @ T name, H >in !
     THEN      THEN
     T cfalign here H tlastcfa !      T cfalign here H tlastcfa !
     \ Symbol table      \ Symbol table
 \    >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  
         >in @ alias2 swap >in !         \ create alias in target  
         >in @ ghost swap >in !  
         swap also ghosts ' previous swap !     \ tick ghost and store in alias  
         CreateFlag off  
     ELSE ghost  
     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 1367  Cond: [']  T ' H alit, ;Cond Line 1775  Cond: [']  T ' H alit, ;Cond
 \ 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 1423  Defer (end-code) Line 1831  Defer (end-code)
     ELSE true ABORT" CROSS: Stack empty" THEN      ELSE true ABORT" CROSS: Stack empty" THEN
     ;      ;
   
 ( Cond ) : chars tchar * ; ( Cond )  
   
 >CROSS  >CROSS
   
 \ tLiteral                                             12dec92py  \ tLiteral                                             12dec92py
Line 1447  Cond: MAXU Line 1853  Cond: MAXU
   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 1457  Cond: MINI Line 1863  Cond: MINI
         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 1467  Cond: MAXI Line 1873  Cond: MAXI
         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 1490  Cond: MAXI Line 1904  Cond: MAXI
 : ] 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 1569  Cond: DOES> restrict? Line 1983  Cond: DOES> restrict?
 \ 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
Line 1596  Cond: DOES> restrict? Line 2007  Cond: DOES> restrict?
   
 : 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 1617  Cond: DOES> restrict? Line 2029  Cond: DOES> restrict?
   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 1709  Builder AVariable Line 2125  Builder AVariable
 \ 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 1743  BuildSmart:  ( -- ) [T'] noop T A, H ; Line 2163  BuildSmart:  ( -- ) [T'] noop T A, H ;
 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 1771  Builder Field Line 2191  Builder Field
 : 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 1781  Builder Field Line 2198  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 -- ) - tchar / ; \ ?? jaw  : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
   
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  : >resolve    ( sys -- )        
           X here ( dup ." >" hex. ) over branchoffset swap X ! ;
   
 : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;  : <resolve    ( sys -- )
           X here ( dup ." <" hex. ) branchoffset X , ;
   
 :noname compile branch T here branchoffset , H ;  :noname compile branch X here branchoffset X , ;
   IS branch, ( target-addr -- )    IS branch, ( target-addr -- )
 :noname compile ?branch T here branchoffset , H ;  :noname compile ?branch X here branchoffset X , ;
   IS ?branch, ( target-addr -- )    IS ?branch, ( target-addr -- )
 :noname compile branch T here 0 , H ;  :noname compile branch T here 0 , H ;
   IS branchmark, ( -- branchtoken )    IS branchmark, ( -- branchtoken )
Line 1797  Builder Field Line 2216  Builder Field
   IS ?branchmark, ( -- branchtoken )    IS ?branchmark, ( -- branchtoken )
 :noname T here 0 , H ;  :noname T here 0 , H ;
   IS ?domark, ( -- branchtoken )    IS ?domark, ( -- branchtoken )
 :noname dup T @ H ?struc T here over branchoffset swap ! H ;  :noname dup X @ ?struc X here over branchoffset swap X ! ;
   IS branchtoresolve, ( branchtoken -- )    IS branchtoresolve, ( branchtoken -- )
 :noname branchto, T here H ;  :noname branchto, X here ;
   IS branchtomark, ( -- target-addr )    IS branchtomark, ( -- target-addr )
   
 >TARGET  >TARGET
Line 1809  Builder Field Line 2228  Builder Field
 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 1861  Cond: DONE   ( addr -- )  restrict? (don Line 2261  Cond: DONE   ( addr -- )  restrict? (don
 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 1957  Cond: defers T ' >body @ compile, H ;Con Line 2355  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 1986  Cond: postpone ( -- ) restrict? \ name Line 2384  Cond: postpone ( -- ) restrict? \ name
                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 2010  Create parsed 20 chars allot \ store wor Line 2456  Create parsed 20 chars allot \ store wor
 : [ELSE]  : [ELSE]
     1 BEGIN      1 BEGIN
         BEGIN bl word count dup WHILE          BEGIN bl word count dup WHILE
             comment? parsed place upcase parsed count              comment? 20 umin parsed place upcase parsed count
             2dup s" [IF]" compare 0= >r               2dup s" [IF]" compare 0= >r 
             2dup s" [IFUNDEF]" compare 0= >r              2dup s" [IFUNDEF]" compare 0= >r
             2dup s" [IFDEF]" compare 0= r> or r> or              2dup s" [IFDEF]" compare 0= r> or r> or
Line 2043  Cond: [ELSE]    postpone [ELSE] ;Cond Line 2489  Cond: [ELSE]    postpone [ELSE] ;Cond
   
 \ define new [IFDEF] and [IFUNDEF]                      20may93jaw  \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
   
 : defined? defined? ;  : defined? tdefined? ;
 : needed? needed? ;  : needed? needed? ;
 : doer? doer? ;  : doer? doer? ;
   
 \ we want to use IFDEF on compiler directives (e.g. E?) in the source, too  \ we want to use IFDEF on compiler directives (e.g. E?) in the source, too
   
 : directive?   : directive? 
   bl word count [ ' target >wordlist ] aliteral search-wordlist     bl word count [ ' target >wordlist ] literal search-wordlist 
   dup IF nip THEN ;    dup IF nip THEN ;
   
 : [IFDEF]  >in @ directive? swap >in !  : [IFDEF]  >in @ directive? swap >in !
            0= IF defined? ELSE name 2drop true THEN             0= IF tdefined? ELSE name 2drop true THEN
            postpone [IF] ;             postpone [IF] ;
   
 : [IFUNDEF] defined? 0= postpone [IF] ;  : [IFUNDEF] tdefined? 0= postpone [IF] ;
   
 Cond: [IFDEF]   postpone [IFDEF] ;Cond  Cond: [IFDEF]   postpone [IFDEF] ;Cond
   
Line 2065  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 2511  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
   
 \ C: \- \+ Conditional Compiling                         09jun93jaw  \ C: \- \+ Conditional Compiling                         09jun93jaw
   
 : C: >in @ defined? 0=  : C: >in @ tdefined? 0=
      IF    >in ! T : H       IF    >in ! X :
      ELSE drop       ELSE drop
         BEGIN bl word dup c@          BEGIN bl word dup c@
               IF   count comment? s" ;" compare 0= ?EXIT                IF   count comment? s" ;" compare 0= ?EXIT
Line 2075  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 2521  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
         AGAIN          AGAIN
      THEN ;       THEN ;
   
 also minimal  
   
 : d? d? ;  : d? d? ;
   
 \G doesn't skip line when debug switch is on  \G doesn't skip line when debug switch is on
 : \D D? 0= IF postpone \ THEN ;  : \D D? 0= IF postpone \ THEN ;
   
 \G interprets the line if word is not defined  \G interprets the line if word is not defined
 : \- defined? IF postpone \ THEN ;  : \- tdefined? IF postpone \ THEN ;
   
 \G interprets the line if word is defined  \G interprets the line if word is defined
 : \+ defined? 0= IF postpone \ THEN ;  : \+ tdefined? 0= IF postpone \ THEN ;
   
 Cond: \- \- ;Cond  Cond: \- \- ;Cond
 Cond: \+ \+ ;Cond  Cond: \+ \+ ;Cond
Line 2098  Cond: \D \D ;Cond Line 2542  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 ;
   
 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 2176  bigendian Constant bigendian Line 2570  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 2202  previous Line 2595  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  ['] defined2? IS skip? ;  : undef-words  ['] defined2? IS skip? ;
 : skipdef skipdef ;  : skipdef skipdef ;
Line 2216  previous Line 2609  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 2245  minimal Line 2638  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 previous 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.75  
changed lines
  Added in v.1.80


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