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

Diff for /gforth/cross.fs between versions 1.89 and 1.102

version 1.89, 2001/01/28 16:54:55 version 1.102, 2001/09/04 11:09:59
Line 802  false DefaultValue dcomps Line 802  false DefaultValue dcomps
 false DefaultValue hash  false DefaultValue hash
 false DefaultValue xconds  false DefaultValue xconds
 false DefaultValue header  false DefaultValue header
 false DefaultValue new-input  
 [THEN]  [THEN]
   
 true DefaultValue interpreter  true DefaultValue interpreter
Line 1516  variable ResolveFlag Line 1515  variable ResolveFlag
 >CROSS  >CROSS
 \ Header states                                        12dec92py  \ Header states                                        12dec92py
   
 : flag! ( w -- )   tlast @ dup >r T @ xor r> ! H ;  \ : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;
   bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+
   : flag! ( w -- )   tlast @ flag+ + dup >r T c@ xor r> c! H ;
   
 VARIABLE ^imm  VARIABLE ^imm
   
 \ !! should be target wordsize specific  
 $80000000 constant alias-mask  
 $40000000 constant immediate-mask  
 $20000000 constant restrict-mask  
   
 >TARGET  >TARGET
 : immediate     immediate-mask flag!  : immediate     40 flag!
                 ^imm @ @ dup <imm> = IF  drop  EXIT  THEN                  ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
                 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"                  <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                 <imm> ^imm @ ! ;                  <imm> ^imm @ ! ;
 : restrict      restrict-mask flag! ;  : restrict      20 flag! ;
   
 : isdoer          : isdoer        
 \G define a forth word as doer, this makes obviously only sence on  \G define a forth word as doer, this makes obviously only sence on
Line 1542  $20000000 constant restrict-mask Line 1538  $20000000 constant restrict-mask
   
 >TARGET  >TARGET
 : string,  ( addr count -- )  : string,  ( addr count -- )
     dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;    dup T c, H bounds  ?DO  I c@ T c, H  LOOP ; 
   
 : lstring, ( addr count -- )  : lstring, ( addr count -- )
     dup T , H bounds  ?DO  I c@ T c, H  LOOP ;    dup T , H bounds  ?DO  I c@ T c, H  LOOP ;
   
 : name,  ( "name" -- )  bl word count T lstring, cfalign H ;  : name,  ( "name" -- )  bl word count T lstring, cfalign H ;
 : view,   ( -- ) ( dummy ) ;  : view,   ( -- ) ( dummy ) ;
 >CROSS  >CROSS
Line 1700  NoHeaderFlag off Line 1698  NoHeaderFlag off
     IF  dup >end tdoes !      IF  dup >end tdoes !
     ELSE 0 tdoes !      ELSE 0 tdoes !
     THEN      THEN
     alias-mask flag!      80 flag!
     cross-doc-entry cross-tag-entry ;      cross-doc-entry cross-tag-entry ;
   
 VARIABLE ;Resolve 1 cells allot  VARIABLE ;Resolve 1 cells allot
Line 1717  VARIABLE ;Resolve 1 cells allot Line 1715  VARIABLE ;Resolve 1 cells allot
     IF      IF
         .sourcepos ." 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 alias-mask 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< s" prims" T $has? H 0= and      dup 0< s" prims" T $has? H 0= and
Line 2041  Cond: DOES> restrict? Line 2039  Cond: DOES> restrict?
   create-forward-warn    create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   \ make Alias    \ make Alias
   (THeader there 0 T a, H alias-mask flag! ( S executed-ghost new-ghost )    (THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost )
   \ store  poiter to code-field    \ store  poiter to code-field
   switchram T cfalign H    switchram T cfalign H
   there swap T ! H    there swap T ! H
Line 2210  Builder Field Line 2208  Builder Field
 : cell% ( n -- size align )  : cell% ( n -- size align )
     T 1 cells H dup ;      T 1 cells H dup ;
   
 Build: ( m v -- m' v )  dup T , H cell+ ;  
   Build: ( m v -- m' v )  dup T , cell+ H ;
 DO:  abort" Not in cross mode" ;DO  DO:  abort" Not in cross mode" ;DO
 Builder input-method  Builder input-method
   
Line 2218  Build: ( m v size -- m v' )  over T , H Line 2217  Build: ( m v size -- m v' )  over T , H
 DO:  abort" Not in cross mode" ;DO  DO:  abort" Not in cross mode" ;DO
 Builder input-var  Builder input-var
   
   
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS
Line 2410  Cond: postpone ( -- ) restrict? \ name Line 2411  Cond: postpone ( -- ) restrict? \ name
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) addr, THEN THEN ;Cond                 ELSE compile (compile) addr, THEN THEN ;Cond
   
   Cond: [compile] ( -- ) restrict? \ name
         bl word gfind dup 0= ABORT" CROSS: Can't compile"
         0> IF    gexecute
            ELSE  dup >magic @ <imm> =
                  IF   gexecute
                  ELSE compile (compile) addr, THEN THEN ;Cond
                         
 \ save-cross                                           17mar93py  \ save-cross                                           17mar93py
   
Line 2587  bigendian Constant bigendian Line 2595  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 ;
   : redefinitions-start twarnings off ;
   : redefinitions-end twarnings on ;
   : group 0 word drop ;
   
 : | ;  : | ;
 \ : | NoHeaderFlag on ; \ This is broken (damages the last word)  \ : | NoHeaderFlag on ; \ This is broken (damages the last word)
   
Removed from v.1.89  
changed lines
  Added in v.1.102

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