--- gforth/cross.fs 2010/04/18 06:18:36 1.170 +++ gforth/cross.fs 2012/08/27 13:33:48 1.183 @@ -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 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 <> ABORT" CROSS: Cannot immediate a unresolved word" ^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? @@ -2412,14 +2427,11 @@ T 2 cells H Value xt>body there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) plugin-of doprim, : (doeshandler,) ( -- ) - T cfalign H ; ' (doeshandler,) plugin-of doeshandler, + T H ; ' (doeshandler,) plugin-of doeshandler, : (dodoes,) ( does-action-ghost -- ) ]comp [G'] :dodoes addr, comp[ 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, : (dlit,) ( n -- ) compile lit td, ; ' (dlit,) plugin-of dlit, @@ -2638,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 -- ) @@ -2954,6 +2967,10 @@ Builder (ABI-CODE) Build: ;Build by: :doabicode noop ;DO +BUILDER (;abi-code) +Build: ;Build +by: :do;abicode noop ;DO + \ Input-Methods 01py Builder input-method @@ -2964,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 @@ -3047,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 ; @@ -3232,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, @@ -3241,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 @@ -3264,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] @@ -3315,7 +3356,7 @@ Cond: postpone ( -- ) \ name hex >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 tcell 1 = 0 and or