Diff for /gforth/cross.fs between versions 1.4 and 1.25

version 1.4, 1994/05/18 17:29:50 version 1.25, 1995/07/06 15:57:25
Line 1 Line 1
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ $Id$  \ $Id$
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992 by the ANSI figForth Development Group  \ Copyright 1992-94 by the GNU Forth Development Group
   
 \ Log:  \ Log:
 \       changed in ; [ to state off           12may93jaw  \       changed in ; [ to state off           12may93jaw
Line 21 Line 21
 \             targets                         09jun93jaw  \             targets                         09jun93jaw
 \       added: 2user and value                11jun93jaw  \       added: 2user and value                11jun93jaw
   
 include other.fs       \ ansforth extentions for cross  \ include other.fs       \ ansforth extentions for cross
   
 decimal  
   
 \ number?                                               11may93jaw  
   
 \ checks for +, -, $, & ...  
 : leading? ( c-addr u -- c-addr u doubleflag negflag base )  
         2dup 1- chars + c@ [char] . =   \ process double  
         IF dup 1 chars = IF over 1 swap c! false ELSE 1 chars - true THEN  
         \ only if more than only . ( may be number output! )  
         \ if only . => store garbage  
         ELSE false THEN >r      \ numbers  
         false -rot base @ -rot  
         BEGIN over c@  
                 dup [char] - =  
                         IF drop >r >r >r  
                            drop true r> r> r> 0 THEN  
                 dup [char] + =  
                         IF drop 0 THEN  
                 dup [char] $ =  
                         IF drop >r >r drop 16 r> r> 0 THEN  
                 dup [char] & =  
                         IF drop >r >r drop 10 r> r> 0 THEN  
               0= IF 1 chars - swap char+ swap false ELSE true THEN  
               over 0= or  
         UNTIL  
               rot >r rot r> r> -rot ;  
   
 : number? ( c-addr -- n/d flag )  
 \ return -1 if cell 1 if double 0 if garbage  
                 0 swap 0 swap           \ create double number  
                 count leading?  
                 base @ >r base !  
                 >r >r  
                 >number IF 2drop false r> r> 2drop  
                            r> base ! EXIT THEN  
                 drop r> r>  
                 IF IF dnegate 1  
                    ELSE drop negate -1 THEN  
                 ELSE IF 1 ELSE drop -1 THEN  
                 THEN r> base ! ;  
   
   : 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 )
           2dup s" (" compare 0=
           IF    postpone (
           ELSE  2dup s" \" compare 0= IF postpone \ THEN
           THEN ;
   
   decimal
   
 \ Begin CROSS COMPILER:  \ Begin CROSS COMPILER:
   
Line 74  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 ,
         name count      bl word count
 \        2dup type space      \ 2dup type space
         dup c, here over chars allot swap move align ;      string, cfalign ;
   
 hex  hex
   
Line 119  Variable tdp Line 88  Variable tdp
   
 \ Parameter for target systems                         06oct92py  \ Parameter for target systems                         06oct92py
   
 include machine.fs  included
   
   \ Create additional parameters                         19jan95py
   
   T
   cell               Constant tcell
   cell<<             Constant tcell<<
   cell>bit           Constant tcell>bit
   bits/byte          Constant tbits/byte
   float              Constant tfloat
   1 bits/byte lshift Constant maxbyte
   H
   
 >TARGET  >TARGET
   
 \ Byte ordering and cell size                          06oct92py  \ Byte ordering and cell size                          06oct92py
   
 : cell+         cell + ;  : cell+         tcell + ;
 : cells         cell<< lshift ;  : cells         tcell<< lshift ;
 : chars         ;  : chars         ;
   : floats        tfloat * ;
       
 >CROSS  >CROSS
 : cell/         cell<< rshift ;  : cell/         tcell<< rshift ;
 >TARGET  >TARGET
 20 CONSTANT bl  20 CONSTANT bl
 -1 Constant NIL  -1 Constant NIL
Line 138  include machine.fs Line 119  include machine.fs
 -3 Constant :docon  -3 Constant :docon
 -4 Constant :dovar  -4 Constant :dovar
 -5 Constant :douser  -5 Constant :douser
 -6 Constant :dodoes  -6 Constant :dodefer
 -7 Constant :doesjump  -7 Constant :dostruc
   -8 Constant :dodoes
   -9 Constant :doesjump
   
 >CROSS  >CROSS
   
 endian  0 pad ! -1 pad c! pad @ 0<  bigendian
 = [IF]   : bswap ; immediate   [IF]
 [ELSE]   : bswap ( big / little -- little / big )  0     : T!  ( n addr -- )  >r s>d r> tcell bounds swap 1-
            cell 1- FOR  bits/byte lshift over       DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
                         [ 1 bits/byte lshift 1- ] Literal and or     : T@  ( addr -- n )  >r 0 0 r> tcell bounds
                         swap bits/byte rshift swap  NEXT  nip ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
   [ELSE]
      : T!  ( n addr -- )  >r s>d r> tcell bounds
        DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
      : T@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
        DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
 [THEN]  [THEN]
   
 \ Memory initialisation                                05dec92py  \ Memory initialisation                                05dec92py
 \ Fixed bug in else part                               11may93jaw  \ Fixed bug in else part                               11may93jaw
   
 [IFDEF] Memory \ Memory is a bigFORTH feature  [IFDEF] Memory \ Memory is a bigFORTH feature
    Memory     also Memory
    : initmem ( var len -- )     : initmem ( var len -- )
      2dup swap handle! >r @ r> erase ;       2dup swap handle! >r @ r> erase ;
    Target     toss
 [ELSE]  [ELSE]
    : initmem ( var len -- )     : initmem ( var len -- )
      tuck allocate abort" CROSS: No memory for target"       tuck allocate abort" CROSS: No memory for target"
Line 189  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
 : @  ( taddr -- w )     >image @ bswap ;  : @  ( taddr -- w )     >image t@ ;
 : !  ( w taddr -- )     >r bswap r> >image ! ;  : !  ( w taddr -- )     >image t! ;
 : c@ ( taddr -- char )  >image c@ ;  : c@ ( taddr -- char )  >image c@ ;
 : c! ( char taddr -- )  >image c! ;  : c! ( char taddr -- )  >image c! ;
   : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
   : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
   
 \ Target compilation primitives                        06oct92py  \ Target compilation primitives                        06oct92py
 \ included A!                                          16may93jaw  \ included A!                                          16may93jaw
Line 210  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 251  Variable atonce atonce off Line 250  Variable atonce atonce off
 : >magic ; : >link cell+ ; : >exec cell+ cell+ ;  : >magic ; : >link cell+ ; : >exec cell+ cell+ ;
 : >end 3 cells + ;  : >end 3 cells + ;
   
   Variable last-ghost
 : Make-Ghost ( "name" -- ghost )  : Make-Ghost ( "name" -- ghost )
   >in @ GhostName swap >in !    >in @ GhostName swap >in !
   <T Create atonce @ IF immediate atonce off THEN    <T Create atonce @ IF immediate atonce off THEN
   here tuck swap ! ghostheader T>    here tuck swap ! ghostheader T>
   DOES>  >exec @ execute ;    DOES> dup last-ghost ! >exec @ execute ;
   
 \ ghost words                                          14oct92py  \ ghost words                                          14oct92py
 \                                          changed:    10may93py/jaw  \                                          changed:    10may93py/jaw
Line 263  Variable atonce atonce off Line 263  Variable atonce atonce off
 : gfind   ( string -- ghost true/1 / string false )  : gfind   ( string -- ghost true/1 / string false )
 \ searches for string in word-list ghosts  \ searches for string in word-list ghosts
 \ !! wouldn't it be simpler to just use search-wordlist ? ae  \ !! wouldn't it be simpler to just use search-wordlist ? ae
   >r get-order  0 set-order also ghosts  r> find >r >r    dup count [ ' ghosts >body ] ALiteral search-wordlist
   set-order  r> r@  IF  >body  THEN  r> ;    dup IF  >r >body nip r>  THEN ;
   
 VARIABLE Already  VARIABLE Already
   
 : ghost   ( "name" -- ghost )  : ghost   ( "name" -- ghost )
   Already off    Already off
   >in @  name gfind   IF  Already on nip EXIT  THEN    >in @  bl word gfind   IF  Already on nip EXIT  THEN
   drop  >in !  Make-Ghost ;    drop  >in !  Make-Ghost ;
   
 \ resolve                                              14oct92py  \ resolve                                              14oct92py
Line 286  VARIABLE Already Line 286  VARIABLE Already
   BEGIN @ dup    BEGIN @ dup
   WHILE 2dup cell+ @ =    WHILE 2dup cell+ @ =
   UNTIL    UNTIL
         nip 2 cells + count cr ." CROSS: Exists: " type 4 spaces          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 325  variable ResolveFlag Line 325  variable ResolveFlag
   Ghostnames    Ghostnames
   BEGIN @ dup    BEGIN @ dup
   WHILE dup ?resolved    WHILE dup ?resolved
   REPEAT drop ResolveFlag @ 0= IF ." Nothing!" THEN cr ;    REPEAT drop ResolveFlag @
     IF
         abort" Unresolved words!"
     ELSE
         ." Nothing!"
     THEN
     cr ;
   
 >CROSS  >CROSS
 \ Header states                                        12dec92py  \ Header states                                        12dec92py
Line 336  VARIABLE ^imm Line 342  VARIABLE ^imm
   
 >TARGET  >TARGET
 : immediate     20 flag!  : immediate     20 flag!
                 ^imm @ @ dup <imm> = ?EXIT                  ^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      40 flag! ;
 >CROSS  >CROSS
   
 \ ALIAS2 ansforth conform alias                          9may93jaw  \ ALIAS2 ansforth conform alias                          9may93jaw
   
 : ALIAS2 create here 0 , DOES> @ execute ;  : ALIAS2 create here 0 , DOES> @ execute ;
 \ usage:  \ usage:
 \ ' alias2 bla !  \ ' <name> alias2 bla !
   
 \ Target Header Creation                               01nov92py  \ Target Header Creation                               01nov92py
   
 : 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" -- )  name count string, T align H ;  : name,  ( "name" -- )  bl word count string, T cfalign H ;
 : view,   ( -- ) ( dummy ) ;  : view,   ( -- ) ( dummy ) ;
   
   \ Target Document Creation (goes to crossdoc.fd)       05jul95py
   
   s" crossdoc.fd" r/w create-file throw value doc-file-id
   \ contains the file-id of the documentation file
   
   : \G ( -- )
       source >in @ /string doc-file-id write-line throw
       source >in ! drop ; immediate
   
   Variable to-doc
   
   : cross-doc-entry  ( -- )
       to-doc @ tlast @ 0<> and    \ not an anonymous (i.e. noname) header
       IF
           s" " doc-file-id write-line throw
           s" make-doc " doc-file-id write-file throw
           tlast @ >image count $1F and doc-file-id write-file throw
           >in @
           [char] ( parse 2drop
           [char] ) parse doc-file-id write-file throw
           s"  )" doc-file-id write-file throw
           [char] \ parse 2drop                                    
           POSTPONE \g
           >in !
       THEN  to-doc on ;
   
 VARIABLE CreateFlag CreateFlag off  VARIABLE CreateFlag CreateFlag off
   
 : (Theader ( "name" -- ghost ) T align H view,  : (Theader ( "name" -- ghost ) 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
   >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 >magic ^imm !     \ a pointer for immediate    dup >magic ^imm !     \ a pointer for immediate
   Already @ IF  dup >end tdoes !    Already @ IF  dup >end tdoes !
   ELSE 0 tdoes ! THEN    ELSE 0 tdoes ! THEN
   80 flag! ;    80 flag!
     cross-doc-entry ;
   
 VARIABLE ;Resolve 1 cells allot  VARIABLE ;Resolve 1 cells allot
   
 : Theader  ( "name" -- )     (THeader there resolve 0 ;Resolve ! ;  : Theader  ( "name" -- ghost )
     (THeader dup there resolve 0 ;Resolve ! ;
   
 >TARGET  >TARGET
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
     dup 0< IF  to-doc off  THEN
   (THeader over resolve T A, H 80 flag! ;    (THeader over resolve T A, H 80 flag! ;
 >CROSS  >CROSS
   
Line 413  ghost unloop    ghost ;S Line 448  ghost unloop    ghost ;S
 ghost lit       ghost (compile) ghost !         2drop drop  ghost lit       ghost (compile) ghost !         2drop drop
 ghost (;code)   ghost noop                      2drop  ghost (;code)   ghost noop                      2drop
 ghost (.")      ghost (S")      ghost (ABORT")  2drop drop  ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
   ghost '
   
 \ compile                                              10may93jaw  \ compile                                              10may93jaw
   
 : compile  ( -- ) \ name  : compile  ( -- ) \ name
   restrict?    restrict?
   name gfind dup 0= ABORT" CROSS: Can't compile "    bl word gfind dup 0= ABORT" CROSS: Can't compile "
   0> ( immediate? )    0> ( immediate? )
   IF    >exec @ compile,    IF    >exec @ compile,
   ELSE  postpone literal postpone gexecute  THEN ;    ELSE  postpone literal postpone gexecute  THEN ;
                                         immediate                                          immediate
   
 >TARGET  >TARGET
 : '  ( -- cfa ) name 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 @ ;
   
 Cond: [']  compile lit ghost gexecute ;Cond  Cond: [']  compile lit ghost gexecute ;Cond
   
   Cond: chars ;Cond
   
 >CROSS  >CROSS
 \ tLiteral                                             12dec92py  \ tLiteral                                             12dec92py
   
Line 462  Cond: [Char]   ( "<char>" -- )  restrict Line 500  Cond: [Char]   ( "<char>" -- )  restrict
   
 : ] state on  : ] state on
     BEGIN      BEGIN
         BEGIN >in @ name          BEGIN >in @ bl word
               dup c@ 0= WHILE 2drop refill 0=                dup c@ 0= WHILE 2drop refill 0=
               ABORT" CROSS: End of file while target compiling"                ABORT" CROSS: End of file while target compiling"
         REPEAT          REPEAT
Line 480  Cond: [Char]   ( "<char>" -- )  restrict Line 518  Cond: [Char]   ( "<char>" -- )  restrict
   
 Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond  Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond
   
   Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
   
 Cond: ; ( -- ) restrict?  Cond: ; ( -- ) restrict?
                depth ?dup IF   1- <> ABORT" CROSS: Stack changed"                 depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
                           ELSE true ABORT" CROSS: Stack empty" THEN                            ELSE true ABORT" CROSS: Stack empty" THEN
Line 507  Cond: DOES> restrict? Line 547  Cond: DOES> restrict?
   >in @ alias2 swap dup >in ! >r >r    >in @ alias2 swap dup >in ! >r >r
   Make-Ghost rot swap >exec ! ,    Make-Ghost rot swap >exec ! ,
   r> r> >in !    r> r> >in !
   also ghosts ' previous swap !    also ghosts ' previous swap ! ;
   DOES> dup >exec @ execute ;  \  DOES>  dup >exec @ execute ;
   
 : gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>  : gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>
   IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN    IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN
   :dodoes T A, H gexecute T here H cell - reloff ;    :dodoes T A, H gexecute T here H cell - reloff ;
   
 : TCreate ( ghost -- )  : TCreate ( -- )
     last-ghost @
   CreateFlag on    CreateFlag on
   Theader dup gdoes,    Theader >r dup gdoes,
   >end @ >exec @ execute ;    >end @ >exec @ r> >exec ! ;
   
 : Build:  ( -- [xt] [colon-sys] )  : Build:  ( -- [xt] [colon-sys] )
   :noname  postpone TCreate ;    :noname  postpone TCreate ;
   
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
     last-ghost @
   state @ IF  gexecute true EXIT  THEN    state @ IF  gexecute true EXIT  THEN
   cell+ @ T >body H false ;    cell+ @ T >body H false ;
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  \ changed to ?EXIT                                      10may93jaw
   
 : (does>)        postpone does> ; immediate \ second level does>  
   
 : DO:     ( -- addr [xt] [colon-sys] )  : DO:     ( -- addr [xt] [colon-sys] )
   here ghostheader    here ghostheader
   :noname    :noname postpone gdoes> postpone ?EXIT ;
   postpone (does>) postpone gdoes> postpone ?EXIT ;  
   
 : ;DO ( addr [xt] [colon-sys] -- )  : ;DO ( addr [xt] [colon-sys] -- )
   postpone ;    ( S addr xt )    postpone ;    ( S addr xt )
Line 566  Variable tup  0 tup ! Line 605  Variable tup  0 tup !
 Variable tudp 0 tudp !  Variable tudp 0 tudp !
 : u,  ( n -- udp )  : u,  ( n -- udp )
   tup @ tudp @ + T  ! H    tup @ tudp @ + T  ! H
   tudp @ dup cell+ tudp ! ;    tudp @ dup T cell+ H tudp ! ;
 : au, ( n -- udp )  : au, ( n -- udp )
   tup @ tudp @ + T A! H    tup @ tudp @ + T A! H
   tudp @ dup cell+ tudp ! ;    tudp @ dup T cell+ H tudp ! ;
 >TARGET  >TARGET
   
 Build: T 0 u, , H ;  Build: T 0 u, , H ;
Line 594  Build:  ( n -- ) T A, H ; Line 633  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 601  Builder Value Line 644  Builder Value
 Build:  ( -- ) compile noop ;  Build:  ( -- ) compile noop ;
 DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 Builder Defer  Builder Defer
   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
   
Line 669  Cond: ABORT"    restrict? compile (ABORT Line 736  Cond: ABORT"    restrict? compile (ABORT
   
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond  Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 : IS            T ' >body ! H ;  : IS            T ' >body ! H ;
   Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
   : TO            T ' >body ! H ;
   
 \ LINKED ERR" ENV" 2ENV"                                18may93jaw  \ LINKED ERR" ENV" 2ENV"                                18may93jaw
   
Line 688  Cond: IS        T ' >body H compile ALit Line 757  Cond: IS        T ' >body H compile ALit
 \ compile must be last                                 22feb93py  \ compile must be last                                 22feb93py
   
 Cond: compile ( -- ) restrict? \ name  Cond: compile ( -- ) restrict? \ name
       name 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) gexecute THEN THEN ;Cond
   
 Cond: postpone ( -- ) restrict? \ name  Cond: postpone ( -- ) restrict? \ name
       name 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
Line 709  also minimal Line 778  also minimal
   
 \ define new [IFDEF] and [IFUNDEF]                      20may93jaw  \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
   
 : there? name gfind IF >magic @ <fwd> <> ELSE drop false THEN ;  : there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ;
   
 : [IFDEF] there? postpone [IF] ;  : [IFDEF] there? postpone [IF] ;
 : [IFUNDEF] there? 0= postpone [IF] ;  : [IFUNDEF] there? 0= postpone [IF] ;
Line 749  Cond: [ELSE]    [ELSE] ;Cond Line 818  Cond: [ELSE]    [ELSE] ;Cond
 \ [THEN]  \ [THEN]
 \ included throw after create-file                     11may93jaw  \ included throw after create-file                     11may93jaw
   
 endian Constant endian  bigendian Constant bigendian
   
 : save-cross ( "name" -- )  : save-cross ( "name" -- )
   bl parse ." Saving to " 2dup type    bl parse ." Saving to " 2dup type
   w/o bin create-file throw >r    w/o bin create-file throw >r
   image @ there r@ write-file throw    s" gforth00"  r@ write-file throw \ write magic
   bit$  @ there 1- cell>bit rshift 1+ r@ write-file throw    image @ there r@ write-file throw \ write image
     bit$  @ there 1- cell>bit rshift 1+
                   r@ write-file throw \ write tags
   r> close-file throw ;    r> close-file throw ;
   
 \ words that should be in minimal  \ words that should be in minimal
   
 : + + ;         : 1- 1- ;  : + + ;         : 1- 1- ;
 : - - ;         : 2* 2* ;  : - - ;         : 2* 2* ;
   : * * ;         : / / ;
 : dup dup ;     : over over ;  : dup dup ;     : over over ;
 : swap swap ;   : rot rot ;  : swap swap ;   : rot rot ;
   : drop drop ;   : =   = ;
   : lshift lshift ; : 2/ 2/ ;
   : . . ;
   cell constant cell
   
 \ include bug5.fs  \ include bug5.fs
 \ only forth also minimal definitions  \ only forth also minimal definitions
   
 : \ postpone \ ;  : \  postpone \ ;
 : ( postpone ( ;  : \G postpone \G ;
   : (  postpone ( ;
 : include bl word count included ;  : include bl word count included ;
 : .( [char] ) parse type ;  : .( [char] ) parse type ;
 : cr cr ;  : cr cr ;

Removed from v.1.4  
changed lines
  Added in v.1.25


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