--- gforth/cross.fs	2010/05/13 09:39:07	1.174
+++ gforth/cross.fs	2012/12/31 15:25:18	1.184
@@ -1,7 +1,7 @@
 \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ 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,2012 Free Software Foundation, Inc.
 
 \ This file is part of Gforth.
 
@@ -765,6 +765,7 @@ Plugin ?do,	( -- ?do-token )
 Plugin for,	( -- for-token )
 Plugin loop,	( do-token / ?do-token -- )
 Plugin +loop,	( do-token / ?do-token -- )
+Plugin -loop,	( do-token / ?do-token -- )
 Plugin next,	( for-token )
 Plugin leave,	( -- )
 Plugin ?leave, 	( -- )
@@ -1726,7 +1727,7 @@ T has? relocate H
 
 Ghost (do)      Ghost (?do)                     2drop
 Ghost (for)                                     drop
-Ghost (loop)    Ghost (+loop)                   2drop
+Ghost (loop)    Ghost (+loop)   Ghost (-loop)   2drop drop
 Ghost (next)                                    drop
 Ghost !does                                     drop
 Ghost compile,                                  drop
@@ -2056,6 +2057,7 @@ $20 constant restrict-mask
                 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                 <imm> ^imm @ ! ;
 : restrict      restrict-mask flag! ;
+: compile-only  restrict-mask flag! ;
 
 : isdoer	
 \G define a forth word as doer, this makes obviously only sence on
@@ -2127,36 +2129,49 @@ Create tag-tab 1 c,  09 c,
 	s" ,0" tag-file-id write-line throw
     THEN ;
 
-: cross-gnu-tag-entry  ( -- )
+: put-cross-gnu-tag-entry  ( addr u -- )
     tlast @ 0<>	\ not an anonymous (i.e. noname) header
     IF
 	put-load-file-name
 	source >in @ min 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
 	base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
 \	>in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
 	s" ,0" tag-file-id write-line throw
 	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
     IF
 	sourcefilename 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
 	s" /^" vi-tag-file-id write-file throw
 	source vi-tag-file-id write-file 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-gnu-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
 
 Defer skip? ' false IS skip?
@@ -2635,6 +2650,7 @@ Defer instant-interpret-does>-hook  ' no
 
 T has? primcentric H [IF]
 : does-resolved ( ghost -- )
+\    g>xt dup T >body H alit, compile call T cell+ @ a, H ;
     compile does-exec g>xt T a, H ;
 [ELSE]
 : does-resolved ( ghost -- )
@@ -2965,6 +2981,25 @@ Builder input-var
 Build: ( m v size -- m v' )  over T , H + ;Build
 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
 
 \ this section defines different compilation
@@ -3048,7 +3083,7 @@ compile: does-resolved ;compile
 \ : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;
 \ : 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]
     : branchoffset ( src dest -- )  drop ;
@@ -3233,6 +3268,10 @@ Cond: ENDCASE   endcase, ;Cond
   1to compile (+loop)  loop] 
   compile unloop skiploop] ;			' (+loop,) plugin-of +loop,
 
+: (-loop,) ( target-addr -- )
+  1to compile (-loop)  loop] 
+  compile unloop skiploop] ;			' (-loop,) plugin-of -loop,
+
 : (next,) 
   compile (next)  loop] compile unloop ;	' (next,) plugin-of next,
 
@@ -3242,6 +3281,7 @@ Cond: FOR	for, ;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
 
 \ String words                                         23feb93py
@@ -3265,15 +3305,15 @@ Cond: ABORT"    if, ahead, there [char]
 [THEN]
 
 X has? rom [IF]
-Cond: IS        T ' >body @ H compile ALiteral compile ! ;Cond
-: IS            T >address ' >body @ ! H ;
+Cond: IS        cross-record-name T ' >body @ H compile ALiteral compile ! ;Cond
+: IS            cross-record-name T >address ' >body @ ! H ;
 Cond: TO        T ' >body @ H compile ALiteral compile ! ;Cond
 : TO            T ' >body @ ! H ;
 Cond: CTO       T ' >body H compile ALiteral compile ! ;Cond
 : CTO           T ' >body ! H ;
 [ELSE]
-Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
-: IS            T >address ' >body ! H ;
+Cond: IS        cross-record-name T ' >body H compile ALiteral compile ! ;Cond
+: IS            cross-record-name T >address ' >body ! H ;
 Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
 : TO            T ' >body ! H ;
 [THEN]