Diff for /gforth/cross.fs between versions 1.42 and 1.43

version 1.42, 1997/02/06 21:22:58 version 1.43, 1997/02/08 22:58:09
Line 91  H Line 91  H
   
 >CROSS  >CROSS
   
   \ Parameter for target systems                         06oct92py
   
   mach-file count included
   
   also Forth definitions
   
   [IFDEF] asm-include asm-include [THEN]
   
   previous
   
   >CROSS
   
 \ Variables                                            06oct92py  \ Variables                                            06oct92py
   
 -1 Constant NIL  
 Variable image  Variable image
 Variable tlast    NIL tlast !  \ Last name field  Variable tlast    NIL tlast !  \ Last name field
 Variable tlastcfa \ Last code field  Variable tlastcfa \ Last code field
Line 102  Variable bit$ Line 113  Variable bit$
 Variable tdp  Variable tdp
 : there  tdp @ ;  : there  tdp @ ;
   
 \ Parameter for target systems                         06oct92py  
   
 mach-file count included  
   
 \ Create additional parameters                         19jan95py  \ Create additional parameters                         19jan95py
   
 T  T
Line 187  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 194  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
     cell tuck 1- and - [ cell 1- ] Literal and ;      cell tuck 1- and - [ cell 1- ] Literal and ;
 : cfalign+  ( taddr -- rest )  : cfalign+  ( taddr -- rest )
     \ see kernel.fs:cfaligned      \ see kernel.fs:cfaligned
     float tuck 1- and - [ float 1- ] Literal and ;      /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ;
   
 >TARGET  >TARGET
 : aligned ( taddr -- ta-addr )  dup align+ + ;  : aligned ( taddr -- ta-addr )  dup align+ + ;
Line 250  Variable atonce atonce off Line 257  Variable atonce atonce off
   
 : GhostHeader <fwd> , 0 , ['] NoExec , ;  : GhostHeader <fwd> , 0 , ['] NoExec , ;
   
 : >magic ; : >link cell+ ; : >exec cell+ cell+ ;  : >magic ;
   : >link cell+ ;
   : >exec cell+ cell+ ;
 : >end 3 cells + ;  : >end 3 cells + ;
   
 Variable last-ghost  Variable last-ghost
Line 424  Create tag-bof 1 c,  0C c, Line 433  Create tag-bof 1 c,  0C c,
         base !          base !
     THEN ;      THEN ;
   
   \ Check for words
   
   Defer skip? ' false IS skip?
   
   : defined? ( -- flag ) \ name
       ghost >magic @ <fwd> <> ;
   
   : needed? ( -- flag ) \ name
       ghost dup >magic @ <fwd> =
       IF  >link @ 0<>  ELSE  drop false  THEN ;
   
   : skip-defs ( -- )
       BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;
   
 \ Target header creation  \ Target header creation
   
 VARIABLE CreateFlag CreateFlag off  VARIABLE CreateFlag CreateFlag off
   
 : (Theader ( "name" -- ghost ) T align H view,  : (Theader ( "name" -- ghost )
   \  >in @ bl word count type 2 spaces >in !
     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 !
   >in @ name, >in ! T here H tlastcfa !    >in @ name, >in ! T here H tlastcfa !
   CreateFlag @ IF    CreateFlag @ IF
Line 450  VARIABLE ;Resolve 1 cells allot Line 475  VARIABLE ;Resolve 1 cells allot
   
 >TARGET  >TARGET
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
   (THeader over resolve T A, H 80 flag! ;      >in @ skip? IF  2drop  EXIT  THEN  >in !
       dup 0< has-prims 0= and
       IF
           ." needs prim: " >in @ bl word count type >in ! cr
       THEN
       (THeader over resolve T A, H 80 flag! ;
 : Alias:   ( cfa -- ) \ name  : Alias:   ( cfa -- ) \ name
   ghost tuck swap resolve <do:> swap >magic ! ;      >in @ skip? IF  2drop  EXIT  THEN  >in !
       dup 0< has-prims 0= and
       IF
           ." needs doer: " >in @ bl word count type >in ! cr
       THEN
       ghost tuck swap resolve <do:> swap >magic ! ;
 >CROSS  >CROSS
   
 \ Conditionals and Comments                            11may93jaw  \ Conditionals and Comments                            11may93jaw
Line 506  ghost :docol    ghost :doesjump ghost :d Line 541  ghost :docol    ghost :doesjump ghost :d
   
 : dodoes, ( -- ) compile :doesjump T 0 , H ;  : dodoes, ( -- ) compile :doesjump T 0 , H ;
   
   [IFUNDEF] (code) 
   Defer (code)
   Defer (end-code)
   [THEN]
   
 >TARGET  >TARGET
   : Code
       (THeader there resolve
       there 2 T cells H + T a, 0 , H
       depth (code) ;
   
   : Code:
       ghost dup there resolve  <do:> swap >magic !
       depth (code) ;
   
   : end-code
       depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
       ELSE true ABORT" CROSS: Stack empty" THEN
       (end-code) ;
                  
 : '  ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "  : '  ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "
   dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;    dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;
   
Line 529  Cond: ALiteral ( n -- )   restrict? alit Line 583  Cond: ALiteral ( n -- )   restrict? alit
 : Char ( "<char>" -- )  bl word char+ c@ ;  : Char ( "<char>" -- )  bl word char+ c@ ;
 Cond: [Char]   ( "<char>" -- )  restrict? Char  lit, ;Cond  Cond: [Char]   ( "<char>" -- )  restrict? Char  lit, ;Cond
   
   \ some special literals                                 27jan97jaw
   
   Cond: MAXU
    restrict? compile lit 
    tcell 0 ?DO FF T c, H LOOP ;Cond
   
   Cond: MINI
    restrict? compile lit
    bigendian IF
    80 T c, H tcell 1 ?DO 0 T c, H LOOP 
    ELSE
    tcell 1 ?DO 0 T c, H LOOP 80 T c, H
    THEN
    ;Cond
    
   Cond: MAXI
    restrict? compile lit
    bigendian IF
    7F T c, H tcell 1 ?DO FF T c, H LOOP 
    ELSE
    tcell 1 ?DO FF T c, H LOOP 7F T c, H
    THEN
    ;Cond
   
 >CROSS  >CROSS
 \ Target compiling loop                                12dec92py  \ Target compiling loop                                12dec92py
 \ ">tib trick thrown out                               10may93jaw  \ ">tib trick thrown out                               10may93jaw
Line 561  Cond: [Char]   ( "<char>" -- )  restrict Line 639  Cond: [Char]   ( "<char>" -- )  restrict
 \             is not allowed if a system should be ans conform  \             is not allowed if a system should be ans conform
   
 : : ( -- colon-sys ) \ Name  : : ( -- colon-sys ) \ Name
     >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !
   (THeader ;Resolve ! there ;Resolve cell+ !    (THeader ;Resolve ! there ;Resolve cell+ !
   docol, depth T ] H ;    docol, depth T ] H ;
   
Line 840  also minimal Line 919  also minimal
   
 \ define new [IFDEF] and [IFUNDEF]                      20may93jaw  \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
   
 : there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ;  : defined? defined? ;
   
 : [IFDEF] there? postpone [IF] ;  : [IFDEF] defined? postpone [IF] ;
 : [IFUNDEF] there? 0= postpone [IF] ;  : [IFUNDEF] defined? 0= postpone [IF] ;
   
 \ C: \- \+ Conditional Compiling                         09jun93jaw  \ C: \- \+ Conditional Compiling                         09jun93jaw
   
 : C: >in @ there? 0=  : C: >in @ defined? 0=
      IF    >in ! T : H       IF    >in ! T : H
      ELSE drop       ELSE drop
         BEGIN bl word dup c@          BEGIN bl word dup c@
Line 859  also minimal Line 938  also minimal
   
 also minimal  also minimal
   
 : \- there? IF postpone \ THEN ;  : \- defined? IF postpone \ THEN ;
 : \+ there? 0= IF postpone \ THEN ;  : \+ defined? 0= IF postpone \ THEN ;
   
 : [IF]   postpone [IF] ;  : [IF]   postpone [IF] ;
 : [THEN] postpone [THEN] ;  : [THEN] postpone [THEN] ;
Line 889  char 1 bigendian + cell + magic 7 + c! Line 968  char 1 bigendian + cell + magic 7 + c!
 : save-cross ( "image-name" "binary-name" -- )  : save-cross ( "image-name" "binary-name" -- )
   bl parse ." Saving to " 2dup type cr    bl parse ." Saving to " 2dup type cr
   w/o bin create-file throw >r    w/o bin create-file throw >r
   s" #! "  r@ write-file throw    NIL IF
   bl parse r@ write-file throw        s" #! "   r@ write-file throw
   s"  -i"  r@ write-file throw        bl parse  r@ write-file throw
   #lf      r@ emit-file throw        s"  -i"   r@ write-file throw
   r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )        #lf       r@ emit-file throw
   ?do        r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )
       bl over emit-file throw        ?do
   loop            bl over emit-file throw
   drop        loop
   magic 8       r@ write-file throw \ write magic        drop
         magic 8       r@ write-file throw \ write magic
     ELSE
         bl parse 2drop
     THEN
   image @ there r@ write-file throw \ write image    image @ there r@ write-file throw \ write image
   bit$  @ there 1- cell>bit rshift 1+    NIL IF
         bit$  @ there 1- cell>bit rshift 1+
                 r@ write-file throw \ write tags                  r@ write-file throw \ write tags
     THEN
   r> close-file throw ;    r> close-file throw ;
   
 \ words that should be in minimal  \ words that should be in minimal
   
 : + + ;         : 1- 1- ;  : here there ;
 : - - ;         : 2* 2* ;  also forth [IFDEF] Label : Label Label ; [THEN] previous
 : * * ;         : / / ;  : + + ;
 : dup dup ;     : over over ;  : or or ;
 : swap swap ;   : rot rot ;  : 1- 1- ;
 : drop drop ;   : =   = ;  : - - ;
 : lshift lshift ; : 2/ 2/ ;  : 2* 2* ;
   : * * ;
   : / / ;
   : dup dup ;
   : over over ;
   : swap swap ;
   : rot rot ;
   : drop drop ;
   : =   = ;
   : 0=   0= ;
   : lshift lshift ;
   : 2/ 2/ ;
 : . . ;  : . . ;
 \ cell constant cell  
   
 mach-file count included  mach-file count included
   
 \ include bug5.fs  : all-words    ['] false    IS skip? ;
 \ only forth also minimal definitions  : needed-words ['] needed?  IS skip? ;
   : undef-words  ['] defined? IS skip? ;
   
 : \  postpone \ ;  immediate  : \  postpone \ ;  immediate
 : (  postpone ( ;  immediate  : (  postpone ( ;  immediate

Removed from v.1.42  
changed lines
  Added in v.1.43


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