Diff for /gforth/cross.fs between versions 1.7 and 1.12

version 1.7, 1994/07/08 15:00:30 version 1.12, 1994/09/09 16:27:17
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
   
 : comment? ( c-addr u -- c-addr u )  : comment? ( c-addr u -- c-addr u )
         2dup s" (" compare 0=          2dup s" (" compare 0=
Line 31  include other.fs       \ ansforth extent Line 31  include other.fs       \ ansforth extent
   
 decimal  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 ! ;  
   
   
   
 \ Begin CROSS COMPILER:  \ Begin CROSS COMPILER:
   
 \ GhostNames                                            9may93jaw  \ GhostNames                                            9may93jaw
Line 125  Variable tdp Line 84  Variable tdp
   
 \ Parameter for target systems                         06oct92py  \ Parameter for target systems                         06oct92py
   
 include machine.fs  include-file
   
 >TARGET  >TARGET
   
Line 145  include machine.fs Line 104  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 :dodoes
   -8 Constant :doesjump
   
 >CROSS  >CROSS
   
 endian  0 pad ! -1 pad c! pad @ 0<  bigendian  0 pad ! -1 pad c! pad @ 0<
 = [IF]   : bswap ; immediate   = [IF]   : bswap ; immediate 
 [ELSE]   : bswap ( big / little -- little / big )  0  [ELSE]   : bswap ( big / little -- little / big )  0
            cell 1- FOR  bits/byte lshift over             cell 1- FOR  bits/byte lshift over
Line 260  Variable atonce atonce off Line 220  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 336  variable ResolveFlag Line 297  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 350  VARIABLE ^imm Line 317  VARIABLE ^imm
                 ^imm @ @ dup <imm> = ?EXIT                  ^imm @ @ dup <imm> = ?EXIT
                 <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
Line 384  VARIABLE CreateFlag CreateFlag off Line 351  VARIABLE CreateFlag CreateFlag off
   
 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
Line 424  ghost unloop    ghost ;S Line 392  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
   
Line 520  Cond: DOES> restrict? Line 489  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 614  Builder Value Line 582  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
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
Line 682  Cond: ABORT"    restrict? compile (ABORT Line 651  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 762  Cond: [ELSE]    [ELSE] ;Cond Line 733  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
Line 775  endian Constant endian Line 746  endian Constant endian
   
 : + + ;         : 1- 1- ;  : + + ;         : 1- 1- ;
 : - - ;         : 2* 2* ;  : - - ;         : 2* 2* ;
   : * * ;         : / / ;
 : dup dup ;     : over over ;  : dup dup ;     : over over ;
 : swap swap ;   : rot rot ;  : swap swap ;   : rot rot ;
   

Removed from v.1.7  
changed lines
  Added in v.1.12


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