[BACK]Return to cross.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/cross.fs between versions 1.73 and 1.76

version 1.73, 1999/05/05 12:07:55 version 1.76, 1999/05/17 13:12:25
Line 58  Warnings off Line 58  Warnings off
         \ we have to set current to be topmost context wordlist          \ we have to set current to be topmost context wordlist
         get-order get-order get-current swap 1+ set-order          get-order get-order get-current swap 1+ set-order
         r> ['] to execute          r> ['] to execute
         set-order order          set-order
   ELSE Value THEN ;    ELSE Value THEN ;
   
 : DefaultValue ( n -- <name> )  : DefaultValue ( n -- <name> )
Line 118  also forth definitions  \ these values m Line 118  also forth definitions  \ these values m
 false DefaultValue stack-warn            \ check on empty stack at any definition  false DefaultValue stack-warn            \ check on empty stack at any definition
 false DefaultValue create-forward-warn   \ warn on forward declaration of created words  false DefaultValue create-forward-warn   \ warn on forward declaration of created words
   
 [IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN]  
 [IFUNDEF] DebugMaskCross  Variable DebugMaskCross  0 DebugMaskCross  ! [THEN]  
   
 previous >CROSS  previous >CROSS
   
 : .dec  : .dec
Line 143  stack-warn [IF] Line 140  stack-warn [IF]
 : defempty? ; immediate  : defempty? ; immediate
 [THEN]  [THEN]
   
   \ debugging
   
   0 [IF]
   
   This implements debugflags for the cross compiler and the compiled
   images. It works identical to the has-flags in the environment.
   The debugflags are defined in a vocabluary. If the word exists and
   its value is true, the flag is switched on.
   
   [THEN]
   
   Vocabulary debugflags   \ debug flags for cross
   also debugflags get-order over
   Constant debugflags-wl
   set-order previous
   
   : DebugFlag
     get-current >r debugflags-wl set-current
     SetValue
     r> set-current ;
   
   : Debug? ( adr u -- flag )
   \G return true if debug flag is defined or switched on
     debugflags-wl search-wordlist
     IF EXECUTE
     ELSE false THEN ;
   
   : D? ( <name> -- flag )
   \G return true if debug flag is defined or switched on
   \G while compiling we do not return the current value but
     bl word count debug? ;
   
   : [d?]
   \G compile the value-xt so the debug flag can be switched
   \G the flag must exist!
     bl word count debugflags-wl search-wordlist
     IF    compile,
     ELSE  -1 ABORT" unknown debug flag"
           \ POSTPONE false 
     THEN ; immediate
   
 \ \ GhostNames Ghosts                                  9may93jaw  \ \ GhostNames Ghosts                                  9may93jaw
   
Line 171  VARIABLE VocTemp Line 207  VARIABLE VocTemp
 hex  hex
 4711 Constant <fwd>             4712 Constant <res>  4711 Constant <fwd>             4712 Constant <res>
 4713 Constant <imm>             4714 Constant <do:>  4713 Constant <imm>             4714 Constant <do:>
   4715 Constant <skip>
   
 \ iForth makes only immediate directly after create  \ iForth makes only immediate directly after create
 \ make atonce trick! ?  \ make atonce trick! ?
   
 Variable atonce atonce off  Variable atonce atonce off
   
 : NoExec true ABORT" CROSS: Don't execute ghost" ;  : NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;
   
 : GhostHeader <fwd> , 0 , ['] NoExec , ;  : GhostHeader <fwd> , 0 , ['] NoExec , ;
   
Line 222  VARIABLE Already Line 259  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 240  VARIABLE Already Line 277  VARIABLE Already
 : forward? ( ghost -- flag )  : forward? ( ghost -- flag )
   >magic @ <fwd> = ;    >magic @ <fwd> = ;
   
   : undefined? ( ghost -- flag )
     >magic @ dup <fwd> = swap <skip> = or ;
   
 \ Predefined ghosts                                    12dec92py  \ Predefined ghosts                                    12dec92py
   
 ghost 0=                                        drop  ghost 0=                                        drop
Line 281  VARIABLE env-current \ save information Line 321  VARIABLE env-current \ save information
 : has?  bl word count T environment? H   : has?  bl word count T environment? H 
         IF      \ environment variable is present, return its value          IF      \ environment variable is present, return its value
         ELSE    \ environment variable is not present, return false          ELSE    \ environment variable is not present, return false
                 \ !! JAW abort is just for testing                  false \ debug true ABORT" arg" 
                 false true ABORT" arg"   
         THEN ;          THEN ;
   
 : $has? T environment? H IF ELSE false THEN ;  : $has? T environment? H IF ELSE false THEN ;
Line 748  T has? relocate H Line 787  T has? relocate H
 \ \ Load Assembler  \ \ Load Assembler
   
 >TARGET  >TARGET
 H also Forth definitions \ ." asm: " order  H also Forth definitions
   
 : X     also target bl word find  : X     also target bl word find
         IF      state @ IF compile,          IF      state @ IF compile,
Line 866  Create NoFile ," #load-file#" Line 905  Create NoFile ," #load-file#"
         REPEAT          REPEAT
         2drop drop false ;                2drop drop false ;      
   
   false DebugFlag showincludedfiles
   
 : included   : included 
 \       cr ." Including: " 2dup type ." ..."          [d?] showincludedfiles
           IF      cr ." Including: " 2dup type ." ..." THEN
         FileMem >r          FileMem >r
         2dup add-included-file included           2dup add-included-file included 
         r> to FileMem ;          r> to FileMem ;
Line 970  Exists-Warnings on Line 1012  Exists-Warnings on
 \G resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
     \ is ghost resolved?, second resolve means another definition with the      \ is ghost resolved?, second resolve means another definition with the
     \ same name      \ same name
     over forward? 0= IF  exists EXIT THEN      over undefined? 0= IF  exists EXIT THEN
     \ get linked-list      \ get linked-list
     swap >r r@ >link @ swap \ ( list tcfa R: ghost )      swap >r r@ >link @ swap \ ( list tcfa R: ghost )
     \ mark ghost as resolved      \ mark ghost as resolved
Line 1147  Create tag-bof 1 c,  0C c, Line 1189  Create tag-bof 1 c,  0C c,
   
 Defer skip? ' false IS skip?  Defer skip? ' false IS skip?
   
   : skipdef ( <name> -- )
   \G skip definition of an undefined word in undef-words mode
       ghost dup forward?
       IF  >magic <skip> swap !
       ELSE drop THEN ;
   
 : defined? ( -- flag ) \ name  : defined? ( -- flag ) \ name
       ghost undefined? 0= ;
   
   : defined2? ( -- flag ) \ name
   \G return true for anything else than forward, even for <skip>
   \G that's what we want
     ghost forward? 0= ;      ghost forward? 0= ;
   
 : needed? ( -- flag ) \ name  : needed? ( -- flag ) \ name
Line 1156  Defer skip? ' false IS skip? Line 1209  Defer skip? ' false IS skip?
 \G a forward reference exists  \G a forward reference exists
 \G so the definition is not skipped!  \G so the definition is not skipped!
     bl word gfind      bl word gfind
     IF dup forward?      IF dup undefined?
         nip          nip
         0=          0=
     ELSE  drop true  THEN ;      ELSE  drop true  THEN ;
Line 1205  NoHeaderFlag off Line 1258  NoHeaderFlag off
     \ 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 @      CreateFlag @
     IF      IF  \ for a created word we need also a definition in target
           \ to execute the created word while compile time
           \ dont mind if a alias is defined twice
           Warnings @ >r Warnings off
         >in @ alias2 swap >in !         \ create alias in target          >in @ alias2 swap >in !         \ create alias in target
           r> Warnings !
         >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
Line 1289  Comment (       Comment \ Line 1346  Comment (       Comment \
   THEN ; immediate    THEN ; immediate
   
 : ghost>cfa  : ghost>cfa
   dup forward? ABORT" CROSS: forward " >link @ ;    dup undefined? ABORT" CROSS: forward " >link @ ;
                                 
 >TARGET  >TARGET
   
Line 1523  Cond: DOES> restrict? Line 1580  Cond: DOES> restrict?
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
   >end @ dup forward? 0=    >end @ dup undefined? 0=
   IF    IF
         dup >magic @ <do:> =          dup >magic @ <do:> =
         IF       doer,           IF       doer, 
Line 2020  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 2077  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
   
 also minimal  also minimal
   
 \G doesn't skip line when bit is set in debugmask  : d? d? ;
 : \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ;  
   \G doesn't skip line when debug switch is on
   : \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 ;  : \- defined? IF postpone \ THEN ;
Line 2145  previous Line 2204  previous
   
 : all-words    ['] false    IS skip? ;  : all-words    ['] false    IS skip? ;
 : needed-words ['] needed?  IS skip? ;  : needed-words ['] needed?  IS skip? ;
 : undef-words  ['] defined? IS skip? ;  : undef-words  ['] defined2? IS skip? ;
   : skipdef skipdef ;
   
 : \  postpone \ ;  immediate  : \  postpone \ ;  immediate
 : \G T-\G ; immediate  : \G T-\G ; immediate
Line 2191  minimal Line 2251  minimal
 \ these ones are pefered:  \ these ones are pefered:
   
 : lock   turnkey ;  : lock   turnkey ;
 : unlock forth also cross ;  : unlock previous forth also cross ;
   
 : [[ also unlock ;  : [[ also unlock ;
 : ]] previous previous ;  : ]] previous previous ;
Removed from v.1.73  
changed lines
  Added in v.1.76

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