Diff for /gforth/cross.fs between versions 1.20 and 1.24

version 1.20, 1995/01/24 17:31:17 version 1.24, 1995/02/23 20:17:16
Line 23 Line 23
   
 \ include other.fs       \ ansforth extentions for cross  \ include other.fs       \ ansforth extentions for cross
   
   : string, ( c-addr u -- )
       \ puts down string as cstring
       dup c, here swap chars dup allot move ;
   ' falign Alias cfalign
 : comment? ( c-addr u -- c-addr u )  : comment? ( c-addr u -- c-addr u )
         2dup s" (" compare 0=          2dup s" (" compare 0=
         IF    postpone (          IF    postpone (
Line 39  decimal Line 43  decimal
 VARIABLE GhostNames  VARIABLE GhostNames
 0 GhostNames !  0 GhostNames !
 : GhostName ( -- addr )  : GhostName ( -- addr )
         here GhostNames @ , GhostNames ! here 0 ,      here GhostNames @ , GhostNames ! here 0 ,
         bl word count      bl word count
 \        2dup type space      \ 2dup type space
         dup c, here over chars allot swap move align ;      string, cfalign ;
   
 hex  hex
   
Line 116  H Line 120  H
 -4 Constant :dovar  -4 Constant :dovar
 -5 Constant :douser  -5 Constant :douser
 -6 Constant :dodefer  -6 Constant :dodefer
 -7 Constant :dodoes  -7 Constant :dostruc
 -8 Constant :doesjump  -8 Constant :dodoes
   -9 Constant :doesjump
   
 >CROSS  >CROSS
   
Line 172  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 177  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
   
 : align+  ( taddr -- rest )  : align+  ( taddr -- rest )
     cell tuck 1- and - [ cell 1- ] Literal and ;      cell tuck 1- and - [ cell 1- ] Literal and ;
   : cfalign+  ( taddr -- rest )
       \ see kernal.fs:cfaligned
       float tuck 1- and - [ float 1- ] Literal and ;
   
 >TARGET  >TARGET
 : aligned ( taddr -- ta-addr )  dup align+ + ;  : aligned ( taddr -- ta-addr )  dup align+ + ;
 \ assumes cell alignment granularity (as GNU C)  \ assumes cell alignment granularity (as GNU C)
   
   : cfaligned ( taddr1 -- taddr2 )
       \ see kernal.fs
       dup cfalign+ + ;
   
 >CROSS  >CROSS
 : >image ( taddr -- absaddr )  image @ + ;  : >image ( taddr -- absaddr )  image @ + ;
 >TARGET  >TARGET
Line 195  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 207  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : ,     ( w -- )        T here H cell T allot  ! H ;  : ,     ( w -- )        T here H cell T allot  ! H ;
 : c,    ( char -- )     T here    1 allot c! H ;  : c,    ( char -- )     T here    1 allot c! H ;
 : align ( -- )          T here H align+ 0 ?DO  bl T c, H LOOP ;  : align ( -- )          T here H align+ 0 ?DO  bl T c, H LOOP ;
   : cfalign ( -- )
       T here H cfalign+ 0 ?DO  bl T c, H LOOP ;
   
 : A!                    dup relon T ! H ;  : A!                    dup relon T ! H ;
 : A,    ( w -- )        T here H relon T , H ;  : A,    ( w -- )        T here H relon T , H ;
Line 274  VARIABLE Already Line 288  VARIABLE Already
   UNTIL    UNTIL
         2 cells + count cr ." CROSS: Exists: " type 4 spaces drop          2 cells + count cr ." CROSS: Exists: " type 4 spaces drop
         swap cell+ !          swap cell+ !
   ELSE true ABORT" CROSS: Ghostnames inconsistent"    ELSE  true abort" CROSS: Ghostnames inconsistent "
   THEN ;    THEN ;
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
Line 344  VARIABLE ^imm Line 358  VARIABLE ^imm
   
 : 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 ; 
 : name,  ( "name" -- )  bl word count string, T align H ;  : name,  ( "name" -- )  bl word count string, T cfalign H ;
 : view,   ( -- ) ( dummy ) ;  : view,   ( -- ) ( dummy ) ;
   
 VARIABLE CreateFlag CreateFlag off  VARIABLE CreateFlag CreateFlag off
Line 591  Build:  ( n -- ) T A, H ; Line 605  Build:  ( n -- ) T A, H ;
 by Constant  by Constant
 Builder AConstant  Builder AConstant
   
   Build:  ( d -- ) T , , H ;
   DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
   Builder 2Constant
   
 Build: T 0 , H ;  Build: T 0 , H ;
 by Constant  by Constant
 Builder Value  Builder Value
Line 600  DO: ( ghost -- ) ABORT" CROSS: Don't exe Line 618  DO: ( ghost -- ) ABORT" CROSS: Don't exe
 Builder Defer  Builder Defer
 by Defer :dodefer resolve  by Defer :dodefer resolve
   
   \ Sturctures                                           23feb95py
   
   >CROSS
   : nalign ( addr1 n -- addr2 )
   \ addr2 is the aligned version of addr1 wrt the alignment size n
    1- tuck +  swap invert and ;
   >TARGET
   
   Build:  >r rot r@ nalign  dup T , H  ( align1 size offset )
           + swap r> nalign ;
   DO: T @ H + ;DO
   Builder Field
   by Field :dostruc resolve
   
   : struct  T 0 1 chars H ;
   : end-struct  T 2Constant H ;
   
   : cells: ( n -- size align )
       T cells 1 cells H ;
   
   \ ' 2Constant Alias2 end-struct
   \ 0 1 T Chars H 2Constant struct
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS

Removed from v.1.20  
changed lines
  Added in v.1.24


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