[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.53 and 1.54

version 1.53, Sat Sep 13 12:04:55 1997 UTC version 1.54, Sat May 2 21:28:41 1998 UTC
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 
Line 63 
     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 bl word drop >body ! 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 drop drop ELSE Value THEN ;
Line 149 
Line 153 
 [THEN]  [THEN]
   
   
   
 \ \ GhostNames Ghosts                                  9may93jaw  \ \ GhostNames Ghosts                                  9may93jaw
   
 \ second name source to search trough list  \ second name source to search trough list
Line 234 
Line 239 
   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 256 
Line 263 
 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 286 
Line 296 
   
 : $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
 false SetValue ionly  true SetValue compiler
 true  SetValue cross  true  SetValue cross
 >TARGET  true SetValue standard-threading
   >TARGET previous
   
 mach-file count included hex  mach-file count included hex
   
 >ENVIRON  >ENVIRON
   
 s" interpreter" T environment? H 0= ?dup nip [IF] true Value interpreter [THEN]  T has? ec H
 s" ITC" T environment? H 0= ?dup nip [IF] true SetValue ITC [THEN]  [IF]
 s" rom" T environment? H 0= ?dup nip [IF] false Value 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  >TARGET
 s" relocate" T environment? H  s" relocate" T environment? H
Line 358 
Line 383 
   
 >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 473 
Line 498 
   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 648 
Line 673 
   
 \ \ --------------------        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 671 
Line 717 
                         \ 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 682 
Line 728 
 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  : (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve
 : (ar) T ! H ;                  ' (ar) IS addr-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, ;
Line 691 
Line 749 
   
 \ file loading  \ file loading
   
   : >fl-id   1 cells + ;
   : >fl-name 2 cells + ;
   
 Variable filelist 0 filelist !  Variable filelist 0 filelist !
 0 Value  loadfile  0 Value  filemem
   : loadfile filemem >fl-name ;
   
 0 [IF] \ !! JAW WIP  1 [IF] \ !! JAW WIP
   
 : add-included-file ( adr len -- )  : add-included-file ( adr len -- )
         dup 2 cells + allocate throw >r          dup char+ >fl-name allocate throw >r
         r@ 1 cells + dup TO loadfile place          r@ >fl-name place
         filelist @ r@ !          filelist @ r@ !
         r> filelist ! ;          r> dup filelist ! to FileMem
           ;
   
 : included? ( c-addr u -- f )  : included? ( c-addr u -- f )
         filelist          filelist
Line 712 
Line 775 
         2drop drop false ;          2drop drop false ;
   
 : included  : included
         cr ." Including: " 2dup type ." ..."  \       cr ." Including: " 2dup type ." ..."
         2dup add-included-file included ;          FileMem >r
           2dup add-included-file included
           r> to FileMem ;
   
 : include bl word count included ;  : include bl word count included ;
   
Line 724 
Line 789 
 \ 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 + ;  : >file 4 cells + ;
 : >line 5 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 -- )
 \G creates a resolve structure  \G creates a resolve structure
   swap >r here r@ >link @ , r@ >link ! ( tag ) ,      T here aligned H swap (refered)
   T here aligned H , r> drop  last-header-ghost @ ,    ;
   loadfile , sourceline# ,  
   : 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 750 
Line 835 
   
 \ 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
   \         dup >tag @ 2 = IF reswarn-forward THEN
         resolve-warning          resolve-warning
         r@ over >taddr @          r@ over >taddr @
         2 pick >tag @          2 pick >tag @
         IF      addr-resolve            CASE  0 OF colon-resolve ENDOF
         ELSE    colon-resolve                  1 OF addr-resolve ENDOF
         THEN                  2 OF doer-resolve ENDOF
   REPEAT drop r> ;            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 786 
Line 875 
   THEN ;    THEN ;
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
 \ resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
       \ is ghost resolved?, second resolve means another definition with the
       \ same name
   over forward? 0= IF  exists EXIT THEN    over forward? 0= IF  exists EXIT THEN
   resolve-loop  over >link ! <res> swap >magic !      \ 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    ['] 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 870 
Line 969 
                 <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 975 
Line 1077 
   
 \ 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 992 
Line 1100 
 \  >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
       \ build header in target
       NoHeaderFlag @
       IF  NoHeaderFlag off
       ELSE
   T align H view,    T align H view,
   tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !    tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !
   1 headers-named +!    \ Statistic    1 headers-named +!    \ Statistic
   >in @ T name, H >in ! T here H tlastcfa !          >in @ T name, H >in !
       THEN
       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 @ IF      CreateFlag @
       IF
        >in @ alias2 swap >in !         \ create alias in target         >in @ alias2 swap >in !         \ create alias in target
        >in @ ghost swap >in !         >in @ ghost swap >in !
        swap also ghosts ' previous swap !     \ tick ghost and store in alias         swap also ghosts ' previous swap !     \ tick ghost and store in alias
        CreateFlag off         CreateFlag off
   ELSE ghost THEN      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 @ IF  dup >end tdoes !      Already @
   ELSE 0 tdoes ! THEN      IF  dup >end tdoes !
       ELSE 0 tdoes !
       THEN
   80 flag!    80 flag!
   cross-doc-entry cross-tag-entry ;    cross-doc-entry cross-tag-entry ;
   
Line 1210 
Line 1328 
 \ ]                                                     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 1254 
Line 1373 
                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 1284 
Line 1410 
 \ 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 1294 
Line 1423 
   >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> -- )
Line 1384 
Line 1517 
 Builder Create  Builder Create
   
 T has? rom H [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 1394 
Line 1527 
 [THEN]  [THEN]
   
 T has? rom H [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 1471 
Line 1614 
 \ ' 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  
   
 >CROSS  
 : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;  
 : sys?        ( sys -- sys )    dup 0= ?struc ;  
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  
   
 : branchoffset ( src dest -- ) - ;  
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  
 : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;  
 >TARGET  
   
 \ Structural Conditionals                              12dec92py  
   
 Cond: BUT       restrict? sys? swap ;Cond  
 Cond: YET       restrict? sys? dup ;Cond  
   
 >CROSS  
 Variable tleavings  
 >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? 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  
   
 >CROSS  
 : loop]   dup <resolve tcell - compile DONE compile unloop ;  
 >TARGET  
   
 Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond  
 Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond  
 Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond  
   
 [ELSE]  
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS
Line 1553 
Line 1627 
   
 : <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,  :noname compile branch T here branchoffset , H ;
 :noname compile ?branch T here branchoffset , H ; IS ?branch,    IS branch, ( target-addr -- )
 :noname compile branch T here 0 , H ; IS branchmark,  :noname compile ?branch T here branchoffset , H ;
 :noname compile ?branch T here 0 , H ; IS  ?branchmark,    IS ?branch, ( target-addr -- )
 :noname dup T @ H ?struc T here over branchoffset swap ! H ; IS branchtoresolve,  :noname compile branch T here 0 , H ;
 :noname branchto, T here H ; IS branchtomark,    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
   
Line 1567 
Line 1649 
 Cond: BUT       restrict? sys? swap ;Cond  Cond: BUT       restrict? sys? swap ;Cond
 Cond: YET       restrict? sys? dup ;Cond  Cond: YET       restrict? sys? dup ;Cond
   
 1 [IF]  0 [IF]
 >CROSS  >CROSS
 Variable tleavings  Variable tleavings
 >TARGET  >TARGET
Line 1577 
Line 1659 
       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
   
 [ELSE]  [ELSE]
     \ !! This is WIP      \ !! This is WIP
Line 1590 
Line 1672 
   
 >CROSS  >CROSS
 Variable tleavings 0 tleavings !  Variable tleavings 0 tleavings !
 >TARGET  : (done) ( addr -- )
       tleavings @
 Cond: DONE   ( addr -- )  
       restrict? tleavings @  
       BEGIN  dup        BEGIN  dup
       WHILE  >r dup r@ cell+ @ \ address of branch      WHILE
           >r dup r@ cell+ @ \ address of branch
              u> 0=         \ lower than DO?               u> 0=         \ lower than DO?
       WHILE  r@ 2 cells + @ \ branch token      WHILE
           r@ 2 cells + @ \ branch token
              branchtoresolve,               branchtoresolve,
              r@ @ r> free throw               r@ @ r> free throw
       REPEAT drop r>      REPEAT  r>  THEN
       THEN      tleavings ! drop ;
       tleavings ! drop ;Cond  
   >TARGET
   
   Cond: DONE   ( addr -- )  restrict? (done) ;Cond
   
 >CROSS  >CROSS
 : (leave ( branchtoken -- )  : (leave) ( branchtoken -- )
     3 cells allocate throw >r      3 cells allocate throw >r
     T here H r@ cell+ !      T here H r@ cell+ !
     r@ 2 cells + !      r@ 2 cells + !
Line 1613 
Line 1698 
     r> tleavings ! ;      r> tleavings ! ;
 >TARGET  >TARGET
   
 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]  [THEN]
   
   >CROSS
   \ !!JW ToDo : Move to general tools section
   
   : 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 ;
   
   : loop]     branchto, dup <resolve tcell - (done) ;
   
   : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
   
   >TARGET
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 >TARGET  >TARGET
Line 1640 
Line 1745 
   
 \ 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]   branchto, 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  
   
 [THEN]  :noname
       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 1694 
Line 1817 
       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
Line 1709 
Line 1834 
   
 : 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 1727 
Line 1899 
   
 : [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 1760 
Line 1936 
 \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 1818 
Line 1984 
   
 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 1825 
Line 1993 
 : 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 ;

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help