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

version 1.52, 1997/08/31 19:31:28 version 1.56, 1998/07/05 20:49:59
Line 41 Line 41
 \       mach file is only loaded into target  \       mach file is only loaded into target
 \       cell corrected  \       cell corrected
 \       romable extansions                      27apr97-5jun97jaw  \       romable extansions                      27apr97-5jun97jaw
   \       environmental query support             01sep97jaw
   \       added own [IF] ... [ELSE] ... [THEN]    14sep97jaw
   \       extra resolver for doers                20sep97jaw
   \       added killref for DOES>                 20sep97jaw
   
   
 hex     \ the defualt base for the cross-compiler is hex !!  hex     \ the defualt base for the cross-compiler is hex !!
Line 59  Warnings off Line 63  Warnings off
     dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;
   
 : SetValue ( n -- <name> )  : SetValue ( n -- <name> )
 \G Same behaviour as "Value" when the <name> is not defined  \G Same behaviour as "Value" if the <name> is not defined
 \G Same behaviour as "to" when <name> is defined  \G Same behaviour as "to" if <name> is defined
 \G SetValue searches in the current vocabulary  \G SetValue searches in the current vocabulary
  save-input bl word >r restore-input throw r> count   save-input bl word >r restore-input throw r> count
  get-current search-wordlist   get-current search-wordlist
  IF bl word drop >body ! ELSE Value THEN ;   IF ['] to execute ELSE Value THEN ;
   
 : DefaultValue ( n -- <name> )  : DefaultValue ( n -- <name> )
 \G Same behaviour as "Value" when the <name> is not defined  \G Same behaviour as "Value" if the <name> is not defined
 \G SetValue searches in the current vocabulary  \G DefaultValue searches in the current vocabulary
  save-input bl word >r restore-input throw r> count   save-input bl word >r restore-input throw r> count
  get-current search-wordlist   get-current search-wordlist
  IF bl word drop drop drop ELSE Value THEN ;   IF bl word drop 2drop ELSE Value THEN ;
   
 hex  hex
   
Line 128  false DefaultValue create-forward-warn Line 132  false DefaultValue create-forward-warn
   
 previous >CROSS  previous >CROSS
   
   : .dec
     base @ decimal swap . base ! ;
   
 : .sourcepos  : .sourcepos
   cr sourcefilename type ." :"    cr sourcefilename type ." :"
   base @ decimal sourceline# . base ! ;    sourceline# .dec ;
   
 : warnhead  : warnhead
 \G display error-message head  \G display error-message head
Line 146  stack-warn [IF] Line 153  stack-warn [IF]
 [THEN]  [THEN]
   
   
   
 \ \ GhostNames Ghosts                                  9may93jaw  \ \ GhostNames Ghosts                                  9may93jaw
   
 \ second name source to search trough list  \ second name source to search trough list
Line 231  VARIABLE Already Line 239  VARIABLE Already
   BEGIN @ dup    BEGIN @ dup
   WHILE 2dup cell+ @ =    WHILE 2dup cell+ @ =
   UNTIL nip 2 cells + count    UNTIL nip 2 cells + count
   ELSE  2drop true abort" CROSS: Ghostnames inconsistent"    ELSE  2drop 
           \ true abort" CROSS: Ghostnames inconsistent"
           s" ?!?!?!"
   THEN ;    THEN ;
   
 ' >ghostname ALIAS @name  ' >ghostname ALIAS @name
Line 253  ghost (does>)   ghost noop Line 263  ghost (does>)   ghost noop
 ghost (.")      ghost (S")      ghost (ABORT")  2drop drop  ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
 ghost '                                         drop  ghost '                                         drop
 ghost :docol    ghost :doesjump ghost :dodoes   2drop drop  ghost :docol    ghost :doesjump ghost :dodoes   2drop drop
   ghost :dovar                                    drop
 ghost over      ghost =         ghost drop      2drop drop  ghost over      ghost =         ghost drop      2drop drop
 ghost - drop  ghost - drop
   ghost 2drop drop
   ghost 2dup drop
   
 \ \ Parameter for target systems                         06oct92py  \ \ Parameter for target systems                         06oct92py
   
Line 274  VARIABLE env-current \ save information Line 287  VARIABLE env-current \ save information
   
 : e? name T environment? H 0= ABORT" environment variable not defined!" ;  : e? name T environment? H 0= ABORT" environment variable not defined!" ;
   
 : has? name T environment? H IF ELSE false THEN ;  : has?  name T environment? H 
           IF      \ environment variable is present, return its value
           ELSE    \ environment variable is not present, return false
                   \ !! JAW abort is just for testing
                   false true ABORT" arg" 
           THEN ;
   
 : $has? T environment? H IF ELSE false THEN ;  : $has? T environment? H IF ELSE false THEN ;
   
 >ENVIRON  >ENVIRON get-order get-current swap 1+ set-order
 true Value cross  true SetValue compiler
 >TARGET  true  SetValue cross
   true SetValue standard-threading
   >TARGET previous
   
 mach-file count included hex  mach-file count included hex
   
 >TARGET  >ENVIRON
   
 [IFUNDEF] has-interpreter true Value has-interpreter [THEN]  T has? ec H
 [IFUNDEF] itc true Value itc [THEN]  [IF]
 [IFUNDEF] has-rom false Value has-rom [THEN]  false DefaultValue relocate
   false DefaultValue file
   false DefaultValue OS
   false DefaultValue prims
   false DefaultValue floating
   false DefaultValue glocals
   false DefaultValue dcomps
   false DefaultValue hash
   false DefaultValue xconds
   false DefaultValue header
   [THEN]
   
   true DefaultValue interpreter
   true DefaultValue ITC
   false DefaultValue rom
   
   >TARGET
   s" relocate" T environment? H 
   [IF]    SetValue NIL
   [ELSE]  >ENVIRON T NIL H SetValue relocate
   [THEN]
   
 >CROSS  >CROSS
   
Line 343  Variable user-vars 0 user-vars ! Line 383  Variable user-vars 0 user-vars !
   
 >CROSS  >CROSS
   
 \ memregion.fs  \ \ memregion.fs
   
   
 Variable last-defined-region    \ pointer to last defined region  Variable last-defined-region    \ pointer to last defined region
Line 406  Variable mirrored-link          \ linked Line 446  Variable mirrored-link          \ linked
         ." End: " r@ 1 cells + @ + .addr space          ." End: " r@ 1 cells + @ + .addr space
         ." DP: " r> 2 cells + @ .addr           ." DP: " r> 2 cells + @ .addr 
   REPEAT drop    REPEAT drop
   s" rom" $has? 0= ?EXIT    s" rom" T $has? H 0= ?EXIT
   cr ." Mirrored:"    cr ." Mirrored:"
   mirrored-link @    mirrored-link @
   BEGIN dup    BEGIN dup
Line 422  Variable mirrored-link          \ linked Line 462  Variable mirrored-link          \ linked
 0 0 region dictionary  0 0 region dictionary
 \ rom area for the compiler  \ rom area for the compiler
   
 has? rom   T has? rom H
 [IF]  [IF]
 0 0 region ram-dictionary mirrored  0 0 region ram-dictionary mirrored
 \ ram area for the compiler  \ ram area for the compiler
Line 440  has? rom Line 480  has? rom
   
   
 : setup-target ( -- )   \G initialize targets memory space  : setup-target ( -- )   \G initialize targets memory space
   s" rom" $has?    s" rom" T $has? H
   IF  \ check for ram and rom...    IF  \ check for ram and rom...
       address-space area nip        address-space area nip
       ram-dictionary area nip        ram-dictionary area nip
Line 458  has? rom Line 498  has? rom
   ABORT" CROSS: define at least address-space or dictionary!!"    ABORT" CROSS: define at least address-space or dictionary!!"
   + makekernel drop ;    + makekernel drop ;
   
 \ switched tdp for rom support                          03jun97jaw  \ \ switched tdp for rom support                                03jun97jaw
   
 \ second value is here to store some maximal value for statistics  \ second value is here to store some maximal value for statistics
 \ tempdp is also embedded here but has nothing to do with rom support  \ tempdp is also embedded here but has nothing to do with rom support
Line 493  variable fixed  \ flag: true: no automat Line 533  variable fixed  \ flag: true: no automat
 variable constflag constflag off  variable constflag constflag off
   
 : (switchram)  : (switchram)
   fixed @ ?EXIT has-rom 0= ?EXIT    fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
   ram-dictionary >rdp to tdp ;    ram-dictionary >rdp to tdp ;
   
 : switchram  : switchram
Line 633  previous Line 673  previous
   
 \ \ --------------------        Compiler Plug Ins               01aug97jaw  \ \ --------------------        Compiler Plug Ins               01aug97jaw
   
   \  Compiler States
   
   Variable comp-state
   0 Constant interpreting
   1 Constant compiling
   2 Constant resolving
   3 Constant assembling
   
 Defer lit, ( n -- )  Defer lit, ( n -- )
 Defer alit, ( n -- )  Defer alit, ( n -- )
 Defer branch, ( target-addr -- )  
 Defer ?branch, ( target-addr -- )  Defer branch, ( target-addr -- )        \ compiles a branch
 Defer branchmark, ( -- branch-addr )  Defer ?branch, ( target-addr -- )       \ compiles a ?branch
 Defer ?branchmark, ( -- branch-addr )  Defer branchmark, ( -- branch-addr )    \ reserves room for a branch
 Defer branchto,  Defer ?branchmark, ( -- branch-addr )   \ reserves room for a ?branch
 Defer branchtoresolve, ( branch-addr -- )  Defer ?domark, ( -- branch-addr )       \ reserves room for a ?do branch
 Defer branchfrom, ( -- )  Defer branchto, ( -- )                  \ actual program position is target of a branch (do e.g. alignment)
 Defer branchtomark, ( -- target-addr )  Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
   Defer branchfrom, ( -- )                \ ?!
   Defer branchtomark, ( -- target-addr )  \ marks a branch destination
   
 Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position  Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position
   Defer colonmark, ( -- addr )            \ marks a colon call
 Defer colon-resolve ( tcfa addr -- )  Defer colon-resolve ( tcfa addr -- )
   
 Defer addr-resolve ( target-addr addr -- )  Defer addr-resolve ( target-addr addr -- )
   Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
   
   Defer do,       ( -- do-token )
   Defer ?do,      ( -- ?do-token )
   Defer for,      ( -- for-token )
   Defer loop,     ( do-token / ?do-token -- )
   Defer +loop,    ( do-token / ?do-token -- )
   Defer next,     ( for-token )
   
 [IFUNDEF] ca>native  [IFUNDEF] ca>native
 defer ca>native   defer ca>native 
Line 656  DEFER >body             \ we need the sy Line 717  DEFER >body             \ we need the sy
                         \ and the target >body                          \ and the target >body
 >CROSS  >CROSS
 T 2 cells H VALUE xt>body  T 2 cells H VALUE xt>body
 DEFER doprim,  DEFER doprim,   \ compiles start of a primitive
 DEFER docol,     \ compiles start of definition and doer  DEFER docol,    \ compiles start of a colon definition
 DEFER doer,               DEFER doer,             
 DEFER fini,      \ compiles end of definition ;s  DEFER fini,      \ compiles end of definition ;s
 DEFER doeshandler,  DEFER doeshandler,
Line 666  DEFER dodoes, Line 727  DEFER dodoes,
 DEFER ]comp     \ starts compilation  DEFER ]comp     \ starts compilation
 DEFER comp[     \ ends compilation  DEFER comp[     \ ends compilation
   
 : (cc) T a, H ;                 ' (cc) IS colon,  : (cc) T a, H ;                                 ' (cc) IS colon,
 : (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve  
 : (ar) T ! H ;                  ' (ar) IS addr-resolve  : (cr) >tempdp ]comp colon, comp[ tempdp> ;     ' (cr) IS colon-resolve
   : (ar) T ! H ;                                  ' (ar) IS addr-resolve
   : (dr)  ( ghost res-pnt target-addr addr )
           >tempdp drop over 
           dup >magic @ <do:> =
           IF      doer,
           ELSE    dodoes,
           THEN 
           tempdp> ;                               ' (dr) IS doer-resolve
   
   : (cm) ( -- addr )
       T here align H
       -1 colon, ;                                 ' (cm) IS colonmark,
   
 >TARGET  >TARGET
 : compile, colon, ;  : compile, colon, ;
 >CROSS  >CROSS
   
   \ file loading
   
   : >fl-id   1 cells + ;
   : >fl-name 2 cells + ;
   
   Variable filelist 0 filelist !
   0 Value  filemem
   : loadfile filemem >fl-name ;
   
   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
 : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address  : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address, 2: doer
 : >taddr cell+ cell+ ;  : >taddr cell+ cell+ ;  
 : >ghost 3 cells + ;  : >ghost 3 cells + ;
   : >file 4 cells + ;
   : >line 5 cells + ;
   
   : (refered) ( ghost addr tag -- )
   \G creates a reference to ghost at address taddr
       rot >r here r@ >link @ , r> >link ! 
       ( taddr tag ) ,
       ( taddr ) , 
       last-header-ghost @ , 
       loadfile , 
       sourceline# , 
     ;
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
   swap >r here r@ >link @ , r@ >link ! ( tag ) ,  \G creates a resolve structure
   T here aligned H , r> drop  last-header-ghost @ , ;      T here aligned H swap (refered)
     ;
   
   : killref ( addr ghost -- )
   \G kills a forward reference to ghost at position addr
   \G this is used to eleminate a :dovar refence after making a DOES>
       dup >magic @ <fwd> <> IF 2drop EXIT THEN
       swap >r >link
       BEGIN dup @ dup  ( addr last this )
       WHILE dup >taddr @ r@ =
            IF   @ over !
            ELSE nip THEN
       REPEAT rdrop 2drop 
     ;
   
 Defer resolve-warning  Defer resolve-warning
   
Line 700  Defer resolve-warning Line 835  Defer resolve-warning
     
 \ resolve                                              14oct92py  \ resolve                                              14oct92py
   
  : resolve-loop ( ghost tcfa -- ghost tcfa )   : resolve-loop ( ghost resolve-list tcfa -- )
   >r dup >link      >r
   BEGIN @ dup WHILE       BEGIN dup WHILE 
         resolve-warning   \         dup >tag @ 2 = IF reswarn-forward THEN
         r@ over >taddr @             resolve-warning 
         2 pick >tag @            r@ over >taddr @ 
         IF      addr-resolve            2 pick >tag @
         ELSE    colon-resolve            CASE  0 OF colon-resolve ENDOF
         THEN                  1 OF addr-resolve ENDOF
   REPEAT drop r> ;                  2 OF doer-resolve ENDOF
             ENDCASE
             @ \ next list element
       REPEAT 2drop rdrop 
     ;
   
 \ : resolve-loop ( ghost tcfa -- ghost tcfa )  \ : resolve-loop ( ghost tcfa -- ghost tcfa )
 \  >r dup >link @  \  >r dup >link @
Line 736  Exists-Warnings on Line 875  Exists-Warnings on
   THEN ;    THEN ;
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
 \ resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
   over forward? 0= IF  exists EXIT THEN      \ is ghost resolved?, second resolve means another definition with the
   resolve-loop  over >link ! <res> swap >magic !       \ same name
   ['] noop IS resolve-warning       over forward? 0= IF  exists EXIT THEN
       \ get linked-list
       swap >r r@ >link @ swap \ ( list tcfa R: ghost )
       \ mark ghost as resolved
       dup r@ >link ! <res> r@ >magic !
       \ loop through forward referencies
       r> -rot 
       comp-state @ >r Resolving comp-state !
       resolve-loop 
       r> comp-state !
   
       ['] noop IS resolve-warning 
   ;    ;
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
 : is-forward   ( ghost -- )  : is-forward   ( ghost -- )
 \  >link dup @ there rot !  T  A,  H ;    colonmark, 0 (refered) ; \ compile space for call
   0 refered  -1 colon, ;  
   
 : is-resolved   ( ghost -- )  : is-resolved   ( ghost -- )
   >link @ colon, ; \ compile-call    >link @ colon, ; \ compile-call
Line 768  variable ResolveFlag Line 917  variable ResolveFlag
 : ?touched ( ghost -- flag ) dup forward? swap >link @  : ?touched ( ghost -- flag ) dup forward? swap >link @
                                0 <> and ;                                 0 <> and ;
   
   : .forwarddefs ( ghost -- )
           ."  appeared in:"
           >link
           BEGIN   @ dup
           WHILE   cr 5 spaces
                   dup >ghost @ >ghostname type
                   ."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN
                   ."  line " dup >line @ .dec
           REPEAT 
           drop ;
   
 : ?resolved  ( ghostname -- )  : ?resolved  ( ghostname -- )
   dup cell+ @ ?touched    dup cell+ @ ?touched
   IF  cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;    IF    dup 
           cell+ cell+ count cr type ResolveFlag on 
           cell+ @ .forwarddefs
     ELSE  drop 
     THEN ;
   
 >MINIMAL  >MINIMAL
 : .unresolved  ( -- )  : .unresolved  ( -- )
Line 789  variable ResolveFlag Line 953  variable ResolveFlag
 : .stats  : .stats
   base @ >r decimal    base @ >r decimal
   cr ." named Headers: " headers-named @ .     cr ." named Headers: " headers-named @ . 
 \  cr ." MaxRam*" ramdp @ .   
 \  cr ." MaxRom*" romdp @ .   
   r> base ! ;    r> base ! ;
   
 >CROSS  >CROSS
Line 807  VARIABLE ^imm Line 969  VARIABLE ^imm
                 <imm> ^imm @ ! ;                  <imm> ^imm @ ! ;
 : restrict      20 flag! ;  : restrict      20 flag! ;
   
 : isdoer        <do:> last-header-ghost @ >magic ! ;  : isdoer        
   \G define a forth word as doer, this makes obviously only sence on
   \G forth processors such as the PSC1000
                   <do:> last-header-ghost @ >magic ! ;
 >CROSS  >CROSS
   
 \ ALIAS2 ansforth conform alias                          9may93jaw  \ ALIAS2 ansforth conform alias                          9may93jaw
Line 827  VARIABLE ^imm Line 992  VARIABLE ^imm
   
 \ Target Document Creation (goes to crossdoc.fd)       05jul95py  \ Target Document Creation (goes to crossdoc.fd)       05jul95py
   
 s" doc/crossdoc.fd" r/w create-file throw value doc-file-id  s" ./doc/crossdoc.fd" r/w create-file throw value doc-file-id
 \ contains the file-id of the documentation file  \ contains the file-id of the documentation file
   
 : T-\G ( -- )  : T-\G ( -- )
Line 912  Defer skip? ' false IS skip? Line 1077  Defer skip? ' false IS skip?
   
 \ Target header creation  \ Target header creation
   
   Variable CreateFlag
   CreateFlag off
   
 VARIABLE CreateFlag CreateFlag off  Variable NoHeaderFlag
   NoHeaderFlag off
   
 : 0.r ( n1 n2 -- ) 0 swap <# 0 ?DO # LOOP #> type ;  : 0.r ( n1 n2 -- ) 
       base @ >r hex 
       0 swap <# 0 ?DO # LOOP #> type 
       r> base ! ;
 : .sym  : .sym
   bounds     bounds 
   DO I c@ dup    DO I c@ dup
Line 923  VARIABLE CreateFlag CreateFlag off Line 1094  VARIABLE CreateFlag CreateFlag off
                 '\ OF drop ." \\" ENDOF                  '\ OF drop ." \\" ENDOF
                 dup OF emit ENDOF                  dup OF emit ENDOF
         ENDCASE          ENDCASE
   LOOP ;      LOOP ;
   
 : (Theader ( "name" -- ghost )  : (Theader ( "name" -- ghost )
 \  >in @ bl word count type 2 spaces >in !      \  >in @ bl word count type 2 spaces >in !
 \ wordheaders will always be compiled to rom      \ wordheaders will always be compiled to rom
   switchrom      switchrom
   T align H view,      \ build header in target
   tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !      NoHeaderFlag @
   1 headers-named +!    \ Statistic      IF  NoHeaderFlag off
   >in @ T name, H >in ! T here H tlastcfa !      ELSE
   \ Symbol table          T align H view,
   \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !          tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !
   CreateFlag @ IF          1 headers-named +!      \ Statistic
        >in @ alias2 swap >in !         \ create alias in target          >in @ T name, H >in !
        >in @ ghost swap >in !      THEN
        swap also ghosts ' previous swap !     \ tick ghost and store in alias      T cfalign here H tlastcfa !
        CreateFlag off      \ Symbol table
   ELSE ghost THEN  \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
   dup Last-Header-Ghost !      CreateFlag @
   dup >magic ^imm !     \ a pointer for immediate      IF
   Already @ IF  dup >end tdoes !          >in @ alias2 swap >in !         \ create alias in target
   ELSE 0 tdoes ! THEN          >in @ ghost swap >in !
   80 flag!          swap also ghosts ' previous swap !     \ tick ghost and store in alias
   cross-doc-entry cross-tag-entry ;          CreateFlag off
       ELSE ghost
       THEN
       dup Last-Header-Ghost !
       dup >magic ^imm !     \ a pointer for immediate
       Already @
       IF  dup >end tdoes !
       ELSE 0 tdoes !
       THEN
       80 flag!
       cross-doc-entry cross-tag-entry ;
   
 VARIABLE ;Resolve 1 cells allot  VARIABLE ;Resolve 1 cells allot
 \ this is the resolver information from ":"  \ this is the resolver information from ":"
Line 958  VARIABLE ;Resolve 1 cells allot Line 1139  VARIABLE ;Resolve 1 cells allot
 >TARGET  >TARGET
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
     >in @ skip? IF  2drop  EXIT  THEN  >in !      >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< has-prims 0= and      dup 0< s" prims" T $has? H 0= and
     IF      IF
         ." needs prim: " >in @ bl word count type >in ! cr          .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
     THEN      THEN
     (THeader over resolve T A, H 80 flag! ;      (THeader over resolve T A, H 80 flag! ;
 : Alias:   ( cfa -- ) \ name  : Alias:   ( cfa -- ) \ name
     >in @ skip? IF  2drop  EXIT  THEN  >in !      >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< has-prims 0= and      dup 0< s" prims" T $has? H 0= and
     IF      IF
         ." needs doer: " >in @ bl word count type >in ! cr          .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
     THEN      THEN
     ghost tuck swap resolve <do:> swap >magic ! ;      ghost tuck swap resolve <do:> swap >magic ! ;
 >CROSS  >CROSS
Line 1066  Defer (end-code) Line 1247  Defer (end-code)
 : Code  : Code
   defempty?    defempty?
   (THeader there resolve    (THeader there resolve
   [ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF]    [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
   doprim,     doprim, 
   [THEN]    [THEN]
   depth (code) ;    depth (code) ;
Line 1147  Cond: MAXI Line 1328  Cond: MAXI
 \ ]                                                     9may93py/jaw  \ ]                                                     9may93py/jaw
   
 : ] state on  : ] state on
       Compiling comp-state !
     BEGIN      BEGIN
         BEGIN >in @ bl word          BEGIN >in @ bl word
               dup c@ 0= WHILE 2drop refill 0=                dup c@ 0= WHILE 2drop refill 0=
Line 1191  Cond: ; ( -- ) restrict? Line 1373  Cond: ; ( -- ) restrict?
                state off                 state off
                ;Resolve @                 ;Resolve @
                IF ;Resolve @ ;Resolve cell+ @ resolve THEN                 IF ;Resolve @ ;Resolve cell+ @ resolve THEN
                   Interpreting comp-state !
                ;Cond                 ;Cond
 Cond: [  restrict? state off ;Cond  Cond: [  restrict? state off Interpreting comp-state ! ;Cond
   
 >CROSS  >CROSS
   
   Create GhostDummy ghostheader
   <res> GhostDummy >magic !
   
 : !does ( does-action -- )  : !does ( does-action -- )
 \ !! zusammenziehen und dodoes, machen!  \ !! zusammenziehen und dodoes, machen!
     tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;      tlastcfa @ [G'] :dovar killref
   \    tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
 \ !! geht so nicht, da dodoes, ghost will!  \ !! geht so nicht, da dodoes, ghost will!
 \     tlastcfa @ >tempdp dodoes, tempdp> ;      GhostDummy >link ! GhostDummy 
       tlastcfa @ >tempdp dodoes, tempdp> ;
   
 >TARGET  >TARGET
 Cond: DOES> restrict?  Cond: DOES> restrict?
Line 1221  Cond: DOES> restrict? Line 1410  Cond: DOES> restrict?
 \ 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    >in @ alias2 swap dup >in ! >r >r
   Make-Ghost rot swap >exec ! ,    Make-Ghost 
     rot swap >exec dup @ ['] NoExec <>
     IF 2drop ELSE ! THEN
     ,
   r> r> >in !    r> r> >in !
   also ghosts ' previous swap ! ;    also ghosts ' previous swap ! ;
 \  DOES>  dup >exec @ execute ;  \  DOES>  dup >exec @ execute ;
Line 1231  Cond: DOES> restrict? Line 1423  Cond: DOES> restrict?
   >end @ dup forward? 0=    >end @ dup forward? 0=
   IF    IF
         dup >magic @ <do:> =          dup >magic @ <do:> =
         IF  doer, EXIT THEN          IF       doer, 
           ELSE    dodoes,
           THEN
           EXIT
   THEN    THEN
 \  compile :dodoes gexecute  \  compile :dodoes gexecute
 \  T here H tcell - reloff   \  T here H tcell - reloff 
   dodoes,    2 refered 
 ;    0 fillcfa
     ;
   
 : TCreate ( <name> -- )  : TCreate ( <name> -- )
   executed-ghost @    executed-ghost @
Line 1268  Cond: DOES> restrict? Line 1464  Cond: DOES> restrict?
   
 : BuildSmart:  ( -- [xt] [colon-sys] )  : BuildSmart:  ( -- [xt] [colon-sys] )
   :noname    :noname
   [ has-rom [IF] ]    [ T has? rom H [IF] ]
   postpone RTCreate    postpone RTCreate
   [ [ELSE] ]    [ [ELSE] ]
   postpone TCreate     postpone TCreate 
Line 1320  BuildSmart: ; Line 1516  BuildSmart: ;
 by: :dovar ( ghost -- addr ) ;DO  by: :dovar ( ghost -- addr ) ;DO
 Builder Create  Builder Create
   
 has-rom [IF]  T has? rom H [IF]
 Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;  Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
 by (Constant)  by (Constant)
 Builder Variable  Builder Variable
 [ELSE]  [ELSE]
Line 1330  by Create Line 1526  by Create
 Builder Variable  Builder Variable
 [THEN]  [THEN]
   
 has-rom [IF]  T has? rom H [IF]
 Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;  Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;
   by (Constant)
   Builder 2Variable
   [ELSE]
   Build: T 0 , 0 , H ;
   by Create
   Builder 2Variable
   [THEN]
   
   T has? rom H [IF]
   Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
 by (Constant)  by (Constant)
 Builder AVariable  Builder AVariable
 [ELSE]  [ELSE]
Line 1408  Builder Field Line 1614  Builder Field
 \ ' 2Constant Alias2 end-struct  \ ' 2Constant Alias2 end-struct
 \ 0 1 T Chars H 2Constant struct  \ 0 1 T Chars H 2Constant struct
   
 0 [IF]  
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS
Line 1418  Builder Field Line 1622  Builder Field
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;
   
 : branchoffset ( src dest -- ) - ;  : branchoffset ( src dest -- ) - ;
   
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;
   
 : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;  : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;
   
   :noname compile branch T here branchoffset , H ;
     IS branch, ( target-addr -- )
   :noname compile ?branch T here branchoffset , H ;
     IS ?branch, ( target-addr -- )
   :noname compile branch T here 0 , H ;
     IS branchmark, ( -- branchtoken )
   :noname compile ?branch T here 0 , H ;
     IS ?branchmark, ( -- branchtoken )
   :noname T here 0 , H ;
     IS ?domark, ( -- branchtoken )
   :noname dup T @ H ?struc T here over branchoffset swap ! H ;
     IS branchtoresolve, ( branchtoken -- )
   :noname branchto, T here H ;
     IS branchtomark, ( -- target-addr )
   
 >TARGET  >TARGET
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
Line 1427  Builder Field Line 1649  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  >CROSS
 Variable tleavings  Variable tleavings
 >TARGET  >TARGET
Line 1436  Cond: DONE   ( addr -- )  restrict? tlea Line 1659  Cond: DONE   ( addr -- )  restrict? tlea
       tleavings ! drop ;Cond        tleavings ! drop ;Cond
   
 >CROSS  >CROSS
 : (leave  T here H tleavings @ T , H  tleavings ! ;  : (leave)  T here H tleavings @ T , H  tleavings ! ;
 >TARGET  >TARGET
   
 Cond: LEAVE     restrict? compile branch (leave ;Cond  Cond: LEAVE     restrict? compile branch (leave) ;Cond
 Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond  Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave)  ;Cond
   
 \ Structural Conditionals                              12dec92py  
   
 Cond: AHEAD     restrict? compile branch >mark ;Cond  
 Cond: IF        restrict? compile ?branch >mark ;Cond  
 Cond: THEN      restrict? sys? branchto, dup T @ H ?struc >resolve ;Cond  
 Cond: ELSE      restrict? sys? compile AHEAD swap compile THEN ;Cond  
   
 Cond: BEGIN     restrict? T branchto, here ( dup ." B" hex. ) H ;Cond  
 Cond: WHILE     restrict? sys? compile IF swap ;Cond  
 Cond: AGAIN     restrict? sys? compile branch <resolve ;Cond  
 Cond: UNTIL     restrict? sys? compile ?branch <resolve ;Cond  
 Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond  
   
 Cond: CASE      restrict? 0 ;Cond  
 Cond: OF        restrict? 1+ >r compile over compile =  
                 compile IF compile drop r> ;Cond  
 Cond: ENDOF     restrict? >r compile ELSE r> ;Cond  
 Cond: ENDCASE   restrict? compile drop 0 ?DO  compile THEN  LOOP ;Cond  
   
 \ Structural Conditionals                              12dec92py  
   
 Cond: DO        restrict? compile (do)   T here H ;Cond  
 Cond: ?DO       restrict? compile (?do)  T (leave here H ;Cond  
 Cond: FOR       restrict? compile (for)  T here H ;Cond  
   
   [ELSE]
       \ !! This is WIP
       \ The problem is (?DO)!
       \ perhaps we need a plug-in for (?DO)
       
 >CROSS  >CROSS
 : loop]   dup <resolve tcell - compile DONE compile unloop ;  Variable tleavings 0 tleavings !
   : (done) ( addr -- )
       tleavings @
       BEGIN  dup
       WHILE
           >r dup r@ cell+ @ \ address of branch
           u> 0=      \ lower than DO?     
       WHILE
           r@ 2 cells + @ \ branch token
           branchtoresolve,
           r@ @ r> free throw
       REPEAT  r>  THEN
       tleavings ! drop ;
   
 >TARGET  >TARGET
   
 Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond  Cond: DONE   ( addr -- )  restrict? (done) ;Cond
 Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond  
 Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond  >CROSS
   : (leave) ( branchtoken -- )
       3 cells allocate throw >r
       T here H r@ cell+ !
       r@ 2 cells + !
       tleavings @ r@ !
       r> tleavings ! ;
   >TARGET
   
 [ELSE]  Cond: LEAVE     restrict? branchmark, (leave) ;Cond
   Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave)  ;Cond
   
 \ structural conditionals                              17dec92py  [THEN]
   
 >CROSS  >CROSS
 : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;  \ !!JW ToDo : Move to general tools section
 : sys?        ( sys -- sys )    dup 0= ?struc ;  
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  
   
 : branchoffset ( src dest -- ) - ;  : to1 ( x1 x2 xn n -- addr )
   \G packs n stack elements in a allocated memory region
      dup dup 1+ cells allocate throw dup >r swap 1+
      0 DO tuck ! cell+ LOOP
      drop r> ;
   : 1to ( addr -- x1 x2 xn )
   \G unpacks the elements saved by to1
       dup @ swap over cells + swap
       0 DO  dup @ swap 1 cells -  LOOP
       free throw ;
   
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  : loop]     branchto, dup <resolve tcell - (done) ;
   
 : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;  : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
   
 :noname compile branch T here branchoffset , H ; IS branch,  
 :noname compile ?branch T here branchoffset , H ; IS ?branch,  
 :noname compile branch T here 0 , H ; IS branchmark,  
 :noname compile ?branch T here 0 , H ; IS  ?branchmark,  
 :noname dup T @ H ?struc T here over branchoffset swap ! H ; IS branchtoresolve,  
 :noname branchto, T here H ; IS branchtomark,  
   
 >TARGET  >TARGET
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 Cond: BUT       restrict? sys? swap ;Cond  
 Cond: YET       restrict? sys? dup ;Cond  
   
 >CROSS  
 Variable tleavings  
 >TARGET  >TARGET
   
 Cond: DONE   ( addr -- )  restrict? tleavings @  
       BEGIN  2dup u> 0=  WHILE  dup T @ H swap >resolve REPEAT  
       tleavings ! drop ;Cond  
   
 >CROSS  
 : (leave  T here H tleavings @ T , H  tleavings ! ;  
 >TARGET  
   
 Cond: LEAVE     restrict? compile branch (leave ;Cond  
 Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond  
   
 \ Structural Conditionals                              12dec92py  
   
 Cond: AHEAD     restrict? branchmark, ;Cond  Cond: AHEAD     restrict? branchmark, ;Cond
 Cond: IF        restrict? ?branchmark, ;Cond  Cond: IF        restrict? ?branchmark, ;Cond
 Cond: THEN      restrict? sys? branchto, branchtoresolve, ;Cond  Cond: THEN      restrict? sys? branchto, branchtoresolve, ;Cond
Line 1540  Cond: ENDCASE   restrict? compile drop 0 Line 1745  Cond: ENDCASE   restrict? compile drop 0
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 Cond: DO        restrict? compile (do)   T here H ;Cond  :noname
 Cond: ?DO       restrict? compile (?do)  T (leave here H ;Cond      0 compile (do)
 Cond: FOR       restrict? compile (for)  T here H ;Cond      branchtomark,  2 to1 ;
     IS do, ( -- target-addr )
 >CROSS  
 : loop]   dup <resolve tcell - compile DONE compile unloop ;  \ :noname
 >TARGET  \     compile 2dup compile = compile IF
   \     compile 2drop compile ELSE
 Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond  \     compile (do) branchtomark, 2 to1 ;
 Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond  \   IS ?do,
 Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond      
   :noname
 [THEN]      0 compile (?do)  ?domark, (leave)
       branchtomark,  2 to1 ;
     IS ?do, ( -- target-addr )
   :noname compile (for) branchtomark, ;
     IS for, ( -- target-addr )
   :noname 1to compile (loop)  loop] compile unloop skiploop] ;
     IS loop, ( target-addr -- )
   :noname 1to compile (+loop)  loop] compile unloop skiploop] ;
     IS +loop, ( target-addr -- )
   :noname compile (next)  loop] compile unloop ;
     IS next, ( target-addr -- )
   
   Cond: DO        restrict? do, ;Cond
   Cond: ?DO       restrict? ?do, ;Cond
   Cond: FOR       restrict? for, ;Cond
   
   Cond: LOOP      restrict? sys? loop, ;Cond
   Cond: +LOOP     restrict? sys? +loop, ;Cond
   Cond: NEXT      restrict? sys? next, ;Cond
   
 \ String words                                         23feb93py  \ String words                                         23feb93py
   
Line 1594  Cond: compile ( -- ) restrict? \ name Line 1817  Cond: compile ( -- ) restrict? \ name
       0> IF    gexecute        0> IF    gexecute
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) gexecute THEN THEN ;Cond                 ELSE compile (compile) addr, THEN THEN ;Cond
   
 Cond: postpone ( -- ) restrict? \ name  Cond: postpone ( -- ) restrict? \ name
       bl word gfind dup 0= ABORT" CROSS: Can't compile"        bl word gfind dup 0= ABORT" CROSS: Can't compile"
       0> IF    gexecute        0> IF    gexecute
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) gexecute THEN THEN ;Cond                 ELSE compile (compile) addr, THEN THEN ;Cond
              
   \ \ minimal definitions
              
 >MINIMAL  >MINIMAL
 also minimal  also minimal
 \ Usefull words                                        13feb93py  \ Usefull words                                        13feb93py
   
 : KB  400 * ;  : KB  400 * ;
   
   \ \ [IF] [ELSE] [THEN] ...                              14sep97jaw
   
   \ it is useful to define our own structures and not to rely
   \ on the words in the compiler
   \ The words in the compiler might be defined with vocabularies
   \ this doesn't work with our self-made compile-loop
   
   Create parsed 20 chars allot    \ store word we parsed
   
   : upcase
       parsed count bounds
       ?DO I c@ toupper I c! LOOP ;
   
   : [ELSE]
       1 BEGIN
           BEGIN bl word count dup WHILE
               comment? parsed place upcase parsed count
               2dup s" [IF]" compare 0= >r 
               2dup s" [IFUNDEF]" compare 0= >r
               2dup s" [IFDEF]" compare 0= r> or r> or
               IF   2drop 1+
               ELSE 2dup s" [ELSE]" compare 0=
                   IF   2drop 1- dup
                       IF 1+
                       THEN
                   ELSE
                       2dup s" [ENDIF]" compare 0= >r
                       s" [THEN]" compare 0= r> or
                       IF 1- THEN
                   THEN
               THEN
               ?dup 0= ?EXIT
           REPEAT
           2drop refill 0=
       UNTIL drop ; immediate
     
   : [THEN] ( -- ) ; immediate
   
   : [ENDIF] ( -- ) ; immediate
   
   : [IF] ( flag -- )
       0= IF postpone [ELSE] THEN ; immediate 
   
   Cond: [IF]      postpone [IF] ;Cond
   Cond: [THEN]    postpone [THEN] ;Cond
   Cond: [ELSE]    postpone [ELSE] ;Cond
   
 \ define new [IFDEF] and [IFUNDEF]                      20may93jaw  \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
   
 : defined? defined? ;  : defined? defined? ;
Line 1627  also minimal Line 1899  also minimal
   
 : [IFUNDEF] defined? 0= postpone [IF] ;  : [IFUNDEF] defined? 0= postpone [IF] ;
   
   Cond: [IFDEF]   postpone [IFDEF] ;Cond
   
   Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
   
 \ C: \- \+ Conditional Compiling                         09jun93jaw  \ C: \- \+ Conditional Compiling                         09jun93jaw
   
 : C: >in @ defined? 0=  : C: >in @ defined? 0=
Line 1660  Cond: \D \D ;Cond Line 1936  Cond: \D \D ;Cond
 \G defines ghost for words that we want to be compiled  \G defines ghost for words that we want to be compiled
   BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;    BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;
   
 : [IF]   postpone [IF] ;  
 : [THEN] postpone [THEN] ;  
 : [ELSE] postpone [ELSE] ;  
   
 Cond: [IF]      [IF] ;Cond  
 Cond: [IFDEF]   [IFDEF] ;Cond  
 Cond: [IFUNDEF] [IFUNDEF] ;Cond  
 Cond: [THEN]    [THEN] ;Cond  
 Cond: [ELSE]    [ELSE] ;Cond  
   
 previous  previous
   
 \ save-cross                                           17mar93py  \ save-cross                                           17mar93py
Line 1718  also minimal Line 1984  also minimal
   
 bigendian Constant bigendian  bigendian Constant bigendian
 : here there ;  : here there ;
   
   \ compiler directives
 : >ram >ram ;  : >ram >ram ;
 : >rom >rom ;  : >rom >rom ;
 : >auto >auto ;  : >auto >auto ;
Line 1725  bigendian Constant bigendian Line 1993  bigendian Constant bigendian
 : tempdp> tempdp> ;  : tempdp> tempdp> ;
 : const constflag on ;  : const constflag on ;
 : warnings name 3 = 0= twarnings ! drop ;  : warnings name 3 = 0= twarnings ! drop ;
   : | NoHeaderFlag on ;
   
 : save-cross save-cross ;  : save-cross save-cross ;
 : save-region save-region ;  : save-region save-region ;

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


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