Diff for /gforth/cross.fs between versions 1.169 and 1.181

version 1.169, 2010/04/05 22:17:56 version 1.181, 2012/03/09 21:16:22
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,2009 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 765  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 1726  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 2127  Create tag-tab 1 c,  09 c, Line 2128  Create tag-tab 1 c,  09 c,
         s" ,0" tag-file-id write-line throw          s" ,0" tag-file-id write-line throw
     THEN ;      THEN ;
   
 : cross-gnu-tag-entry  ( -- )  : put-cross-gnu-tag-entry  ( addr u -- )
     tlast @ 0<> \ not an anonymous (i.e. noname) header      tlast @ 0<> \ not an anonymous (i.e. noname) header
     IF      IF
         put-load-file-name          put-load-file-name
         source >in @ min tag-file-id write-file throw          source >in @ min tag-file-id write-file throw
         tag-beg count tag-file-id write-file throw          tag-beg count tag-file-id write-file throw
         Last-Header-Ghost @ >ghostname tag-file-id write-file throw          tag-file-id write-file throw
         tag-end count tag-file-id write-file throw          tag-end count tag-file-id write-file throw
         base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw          base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
 \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw  \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
         s" ,0" tag-file-id write-line throw          s" ,0" tag-file-id write-line throw
         base !          base !
     THEN ;      ELSE  2drop  THEN ;
   
 : cross-vi-tag-entry ( -- )  : cross-gnu-tag-entry  ( -- )
       Last-Header-Ghost @ >ghostname put-cross-gnu-tag-entry ;
   
   : put-cross-vi-tag-entry ( addr u -- )
     tlast @ 0<> \ not an anonymous (i.e. noname) header      tlast @ 0<> \ not an anonymous (i.e. noname) header
     IF      IF
         sourcefilename vi-tag-file-id write-file throw          sourcefilename vi-tag-file-id write-file throw
         tag-tab count vi-tag-file-id write-file throw          tag-tab count vi-tag-file-id write-file throw
         Last-Header-Ghost @ >ghostname vi-tag-file-id write-file throw          vi-tag-file-id write-file throw
         tag-tab count vi-tag-file-id write-file throw          tag-tab count vi-tag-file-id write-file throw
         s" /^" vi-tag-file-id write-file throw          s" /^" vi-tag-file-id write-file throw
         source vi-tag-file-id write-file throw          source vi-tag-file-id write-file throw
         s" $/" vi-tag-file-id write-line throw          s" $/" vi-tag-file-id write-line throw
     THEN ;      ELSE  2drop  THEN ;
   
   : cross-vi-tag-entry ( -- )
       Last-Header-Ghost @ >ghostname put-cross-vi-tag-entry ;
   
 : cross-tag-entry ( -- )  : cross-tag-entry ( -- )
     cross-gnu-tag-entry      cross-gnu-tag-entry
     cross-vi-tag-entry ;      cross-vi-tag-entry ;
   
   : put-cross-tag-entry ( addr u -- )
       2dup put-cross-gnu-tag-entry
       put-cross-vi-tag-entry ;
   
   : cross-record-name ( -- )
       >in @ parse-name put-cross-tag-entry >in ! ;
   
 \ Check for words  \ Check for words
   
 Defer skip? ' false IS skip?  Defer skip? ' false IS skip?
Line 2412  T 2 cells H Value xt>body Line 2426  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 2652  T has? primcentric H [IF] Line 2663  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 2954  Builder (ABI-CODE) Line 2965  Builder (ABI-CODE)
 Build: ;Build  Build: ;Build
 by: :doabicode noop ;DO  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 2964  Builder input-var Line 2979  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 3047  compile: does-resolved ;compile Line 3081  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 3232  Cond: ENDCASE   endcase, ;Cond Line 3266  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 3241  Cond: FOR for, ;Cond Line 3279  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 3264  Cond: ABORT"    if, ahead, there [char] Line 3303  Cond: ABORT"    if, ahead, there [char]
 [THEN]  [THEN]
   
 X has? rom [IF]  X has? rom [IF]
 Cond: IS        T ' >body @ H compile ALiteral compile ! ;Cond  Cond: IS        cross-record-name T ' >body @ H compile ALiteral compile ! ;Cond
 : IS            T >address ' >body @ ! H ;  : IS            cross-record-name T >address ' >body @ ! H ;
 Cond: TO        T ' >body @ H compile ALiteral compile ! ;Cond  Cond: TO        T ' >body @ H compile ALiteral compile ! ;Cond
 : TO            T ' >body @ ! H ;  : TO            T ' >body @ ! H ;
 Cond: CTO       T ' >body H compile ALiteral compile ! ;Cond  Cond: CTO       T ' >body H compile ALiteral compile ! ;Cond
 : CTO           T ' >body ! H ;  : CTO           T ' >body ! H ;
 [ELSE]  [ELSE]
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond  Cond: IS        cross-record-name T ' >body H compile ALiteral compile ! ;Cond
 : IS            T >address ' >body ! H ;  : IS            cross-record-name T >address ' >body ! H ;
 Cond: TO        T ' >body H compile ALiteral compile ! ;Cond  Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
 : TO            T ' >body ! H ;  : TO            T ' >body ! H ;
 [THEN]  [THEN]
Line 3315  Cond: postpone ( -- ) \ name Line 3354  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.169  
changed lines
  Added in v.1.181


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