Diff for /gforth/cross.fs between versions 1.166 and 1.180

version 1.166, 2007/12/31 18:40:23 version 1.180, 2012/02/13 22:58:13
Line 1 Line 1
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
   
 \ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005,2006,2007 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005,2006,2007,2009,2010,2011 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 191  Create bases   10 ,   2 ,   A , 100 , Line 191  Create bases   10 ,   2 ,   A , 100 ,
         1+          1+
     THEN ;      THEN ;
   
 : number? ( string -- string 0 / n -1 / d 0> )  : (number?) ( string -- string 0 / n -1 / d 0> )
     dup >r count snumber? dup if      dup >r count snumber? dup if
         rdrop          rdrop
     else      else
Line 199  Create bases   10 ,   2 ,   A , 100 , Line 199  Create bases   10 ,   2 ,   A , 100 ,
     then ;      then ;
   
 : number ( string -- d )  : number ( string -- d )
     number? ?dup 0= abort" ?"  0<      (number?) ?dup 0= abort" ?"  0<
     IF      IF
         s>d          s>d
     THEN ;      THEN ;
   
 [THEN]  [THEN]
   
   [IFUNDEF] (number?) : (number?) number? ; [THEN]
   
 \ this provides assert( and struct stuff  \ this provides assert( and struct stuff
 \GFORTH [IFUNDEF] assert1(  \GFORTH [IFUNDEF] assert1(
 \GFORTH also forth definitions require assert.fs previous  \GFORTH also forth definitions require assert.fs previous
Line 763  Plugin ?do, ( -- ?do-token ) Line 765  Plugin ?do, ( -- ?do-token )
 Plugin for,     ( -- for-token )  Plugin for,     ( -- for-token )
 Plugin loop,    ( do-token / ?do-token -- )  Plugin loop,    ( do-token / ?do-token -- )
 Plugin +loop,   ( do-token / ?do-token -- )  Plugin +loop,   ( do-token / ?do-token -- )
   Plugin -loop,   ( do-token / ?do-token -- )
 Plugin next,    ( for-token )  Plugin next,    ( for-token )
 Plugin leave,   ( -- )  Plugin leave,   ( -- )
 Plugin ?leave,  ( -- )  Plugin ?leave,  ( -- )
Line 1724  T has? relocate H Line 1727  T has? relocate H
   
 Ghost (do)      Ghost (?do)                     2drop  Ghost (do)      Ghost (?do)                     2drop
 Ghost (for)                                     drop  Ghost (for)                                     drop
 Ghost (loop)    Ghost (+loop)                   2drop  Ghost (loop)    Ghost (+loop)   Ghost (-loop)   2drop drop
 Ghost (next)                                    drop  Ghost (next)                                    drop
 Ghost (does>)   Ghost (does>1)  Ghost (does>2)  2drop drop  Ghost !does                                     drop
 Ghost compile,                                  drop  Ghost compile,                                  drop
 Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop  Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
 Ghost (C")      Ghost c(abort") Ghost type      2drop drop  Ghost (C")      Ghost c(abort") Ghost type      2drop drop
Line 2410  T 2 cells H Value xt>body Line 2413  T 2 cells H Value xt>body
   there xt>body + ca>native T a, H 1 fillcfa ;          ' (doprim,) plugin-of doprim,    there xt>body + ca>native T a, H 1 fillcfa ;          ' (doprim,) plugin-of doprim,
   
 : (doeshandler,) ( -- )   : (doeshandler,) ( -- ) 
   T cfalign H [G'] :doesjump addr, T 0 , H ;            ' (doeshandler,) plugin-of doeshandler,      T H ;                                       ' (doeshandler,) plugin-of doeshandler,
   
 : (dodoes,) ( does-action-ghost -- )  : (dodoes,) ( does-action-ghost -- )
   ]comp [G'] :dodoes addr, comp[    ]comp [G'] :dodoes addr, comp[
   addr,    addr,
   \ the relocator in the c engine, does not like the  
   \ does-address to marked for relocation  
   [ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ]  
   2 fillcfa ;                                           ' (dodoes,) plugin-of dodoes,    2 fillcfa ;                                           ' (dodoes,) plugin-of dodoes,
   
 : (dlit,) ( n -- ) compile lit td, ;                    ' (dlit,) plugin-of dlit,  : (dlit,) ( n -- ) compile lit td, ;                    ' (dlit,) plugin-of dlit,
Line 2535  Cond: MAXI Line 2535  Cond: MAXI
         IF   nip execute-exec-compile ELSE gexecute  THEN           IF   nip execute-exec-compile ELSE gexecute  THEN 
         EXIT           EXIT 
   THEN    THEN
   number? dup      (number?) dup  
   IF    0> IF swap lit,  THEN  lit, discard    IF    0> IF swap lit,  THEN  lit, discard
   ELSE  2drop restore-input throw Ghost gexecute THEN  ;    ELSE  2drop restore-input throw Ghost gexecute THEN  ;
   
Line 2650  T has? primcentric H [IF] Line 2650  T has? primcentric H [IF]
 >TARGET  >TARGET
 Cond: DOES>  Cond: DOES>
         T here H [ T has? primcentric H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells          T here H [ T has? primcentric H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells
         H + alit, compile (does>2) compile ;s          H + alit, compile !does compile ;s
         doeshandler, resolve-does>-part          doeshandler, resolve-does>-part
         ;Cond          ;Cond
   
Line 2947  by (Field) Line 2947  by (Field)
     T 1 cells H dup ;      T 1 cells H dup ;
 >CROSS  >CROSS
   
   \ ABI-CODE support
   Builder (ABI-CODE)
   Build: ;Build
   by: :doabicode noop ;DO
   
   BUILDER (;abi-code)
   Build: ;Build
   by: :do;abicode noop ;DO
   
 \ Input-Methods                                            01py  \ Input-Methods                                            01py
   
 Builder input-method  Builder input-method
Line 2957  Builder input-var Line 2966  Builder input-var
 Build: ( m v size -- m v' )  over T , H + ;Build  Build: ( m v size -- m v' )  over T , H + ;Build
 DO:  abort" Not in cross mode" ;DO  DO:  abort" Not in cross mode" ;DO
   
   \ Mini-OOF
   
   Builder method
   Build: ( m v -- m' v )  over T , swap cell+ swap H ;Build
   DO:  abort" Not in cross mode" ;DO
   
   Builder var
   Build: ( m v size -- m v+size )  over T , H + ;Build
   DO: ( o -- addr ) T @ H + ;DO
   
   Builder end-class
   Build: ( addr m v -- )
      T here >r , dup , 2 cells H ?DO T ['] noop , 1 cells H +LOOP
      T cell+ dup cell+ r> rot @ 2 cells /string move H ;Build
   by Create
   
   : class ( class -- class methods vars ) dup T 2@ H ;
   : defines ( xt class -- )  T ' >body @ + ! H ;
   
 \ Peephole optimization                                 05sep01jaw  \ Peephole optimization                                 05sep01jaw
   
 \ this section defines different compilation  \ this section defines different compilation
Line 3040  compile: does-resolved ;compile Line 3068  compile: does-resolved ;compile
 \ : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;  \ : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;
 \ : sys?        ( sys -- sys )    dup 0= ?struc ;  \ : sys?        ( sys -- sys )    dup 0= ?struc ;
   
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  : >mark       ( -- sys )        T here  0 , H ;
   
 X has? abranch [IF]  X has? abranch [IF]
     : branchoffset ( src dest -- )  drop ;      : branchoffset ( src dest -- )  drop ;
Line 3225  Cond: ENDCASE   endcase, ;Cond Line 3253  Cond: ENDCASE   endcase, ;Cond
   1to compile (+loop)  loop]     1to compile (+loop)  loop] 
   compile unloop skiploop] ;                    ' (+loop,) plugin-of +loop,    compile unloop skiploop] ;                    ' (+loop,) plugin-of +loop,
   
   : (-loop,) ( target-addr -- )
     1to compile (-loop)  loop] 
     compile unloop skiploop] ;                    ' (-loop,) plugin-of -loop,
   
 : (next,)   : (next,) 
   compile (next)  loop] compile unloop ;        ' (next,) plugin-of next,    compile (next)  loop] compile unloop ;        ' (next,) plugin-of next,
   
Line 3234  Cond: FOR for, ;Cond Line 3266  Cond: FOR for, ;Cond
   
 Cond: LOOP      1 ncontrols? loop, ;Cond  Cond: LOOP      1 ncontrols? loop, ;Cond
 Cond: +LOOP     1 ncontrols? +loop, ;Cond  Cond: +LOOP     1 ncontrols? +loop, ;Cond
   Cond: -LOOP     1 ncontrols? -loop, ;Cond
 Cond: NEXT      1 ncontrols? next, ;Cond  Cond: NEXT      1 ncontrols? next, ;Cond
   
 \ String words                                         23feb93py  \ String words                                         23feb93py
Line 3308  Cond: postpone ( -- ) \ name Line 3341  Cond: postpone ( -- ) \ name
 hex  hex
   
 >CROSS  >CROSS
 Create magic  s" Gforth3x" here over allot swap move  Create magic  s" Gforth4x" here over allot swap move
   
 bigendian 1+ \ strangely, in magic big=0, little=1  bigendian 1+ \ strangely, in magic big=0, little=1
 tcell 1 = 0 and or  tcell 1 = 0 and or

Removed from v.1.166  
changed lines
  Added in v.1.180


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