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

version 1.1, 1994/02/11 16:30:45 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
   
 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 ! ;  
   
   : 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 117  Variable bit$ Line 82  Variable bit$
 Variable tdp  Variable tdp
 : there  tdp @ ;  : there  tdp @ ;
   
 \ Constants                                            06apr93py  
   
 -2 Constant :docol  
 -3 Constant :docon  
 -4 Constant :dovar  
 -5 Constant :dodoes  
   
 \ Parameter for target systems                         06oct92py  \ Parameter for target systems                         06oct92py
   
 include machine.fs  include-file
   
 >TARGET  >TARGET
   
Line 135  include machine.fs Line 93  include machine.fs
 : cell+         cell + ;  : cell+         cell + ;
 : cells         cell<< lshift ;  : cells         cell<< lshift ;
 : chars         ;  : chars         ;
   : floats        float * ;
       
 >CROSS  >CROSS
 : cell/         cell<< rshift ;  : cell/         cell<< rshift ;
 >TARGET  >TARGET
Line 144  include machine.fs Line 103  include machine.fs
 -2 Constant :docol  -2 Constant :docol
 -3 Constant :docon  -3 Constant :docon
 -4 Constant :dovar  -4 Constant :dovar
 -5 Constant :dodoes  -5 Constant :douser
   -6 Constant :dodefer
   -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 160  endian  0 pad ! -1 pad c! pad @ 0< Line 122  endian  0 pad ! -1 pad c! pad @ 0<
 \ 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 186  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 148  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
   
 : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;  : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
 : +bit ( addr n -- )  >bit over c@ or swap c! ;  : +bit ( addr n -- )  >bit over c@ or swap c! ;
   : -bit ( addr n -- )  >bit invert over c@ and swap c! ;
 : relon ( taddr -- )  bit$ @ swap cell/ +bit ;  : relon ( taddr -- )  bit$ @ swap cell/ +bit ;
   : reloff ( taddr -- )  bit$ @ swap cell/ -bit ;
   
 \ Target memory access                                 06oct92py  \ Target memory access                                 06oct92py
   
Line 204  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 168  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : !  ( w taddr -- )     >r bswap r> >image ! ;  : !  ( w taddr -- )     >r bswap r> >image ! ;
 : 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 228  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 194  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : >body   ( cfa -- pfa ) T cell+ cell+ H ;  : >body   ( cfa -- pfa ) T cell+ cell+ H ;
 >CROSS  >CROSS
   
 : dodoes, ( -- ) T 0 , 0 , H ;  : dodoes, ( -- ) T :doesjump A, 0 , H ;
   
 \ Ghost Builder                                        06oct92py  \ Ghost Builder                                        06oct92py
   
Line 254  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 266  Variable atonce atonce off Line 233  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> ;  \ >r get-order  0 set-order also ghosts  r> find >r >r
     >r r@ IF  >body nip  THEN  r> ;
   \ set-order  r> r@  IF  >body  THEN  r> ;
   
 VARIABLE Already  VARIABLE Already
   
Line 328  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 342  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 376  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 412  ghost (do)      ghost (?do) Line 388  ghost (do)      ghost (?do)
 ghost (for)                                     drop  ghost (for)                                     drop
 ghost (loop)    ghost (+loop)                   2drop  ghost (loop)    ghost (+loop)                   2drop
 ghost (next)                                    drop  ghost (next)                                    drop
 ghost unloop    ghost EXIT                      2drop  ghost unloop    ghost ;S                        2drop
 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 481  Cond: [Char]   ( "<char>" -- )  restrict Line 458  Cond: [Char]   ( "<char>" -- )  restrict
   (THeader ;Resolve ! there ;Resolve cell+ !    (THeader ;Resolve ! there ;Resolve cell+ !
   docol, depth T ] H ;    docol, depth T ] H ;
   
   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
                compile EXIT state off                 compile ;S state off
                ;Resolve @                 ;Resolve @
                IF ;Resolve @ ;Resolve cell+ @ resolve THEN                 IF ;Resolve @ ;Resolve cell+ @ resolve THEN
                ;Cond                 ;Cond
Line 508  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 ;    :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 560  Build: T 0 A, H ; Line 540  Build: T 0 A, H ;
 by Create  by Create
 Builder AVariable  Builder AVariable
   
 Build: T 0 , H ;  \ User variables                                       04may94py
 by Create  
   >CROSS
   Variable tup  0 tup !
   Variable tudp 0 tudp !
   : u,  ( n -- udp )
     tup @ tudp @ + T  ! H
     tudp @ dup cell+ tudp ! ;
   : au, ( n -- udp )
     tup @ tudp @ + T A! H
     tudp @ dup cell+ tudp ! ;
   >TARGET
   
   Build: T 0 u, , H ;
   DO: ( ghost -- up-addr )  T @ H tup @ + ;DO
 Builder User  Builder User
   by User :douser resolve
   
 Build: T 0 , 0 , H ;  Build: T 0 u, , 0 u, drop H ;
 by Create  by User
 Builder 2User  Builder 2User
   
 Build: T 0 A, H ;  Build: T 0 au, , H ;
 by Create  by User
 Builder AUser  Builder AUser
   
 Build:  ( n -- ) T , H ;  Build:  ( n -- ) T , H ;
Line 588  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 656  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 736  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 749  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 ;
   
Line 769  only forth also minimal definitions Line 767  only forth also minimal definitions
 : decimal       decimal ;  : decimal       decimal ;
 : hex           hex ;  : hex           hex ;
   
   : tudp          T tudp H ;
   : tup           T tup H ;  minimal
   
 \ for debugging...  \ for debugging...
 : order         order ;  : order         order ;

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


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