--- gforth/cross.fs 2001/03/18 22:20:26 1.96 +++ gforth/cross.fs 2007/12/31 18:40:23 1.166 @@ -1,13 +1,13 @@ \ CROSS.FS The Cross-Compiler 06oct92py \ Idea and implementation: Bernd Paysan (py) -\ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005,2006,2007 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License -\ as published by the Free Software Foundation; either version 2 +\ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, @@ -16,21 +16,21 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. 0 [IF] ToDo: -Crossdoc destination ./doc/crossdoc.fd makes no sense when -cross.fs is uses seperately. jaw -Do we need this char translation with >address and in branchoffset? -(>body also affected) jaw -Clean up mark> and >resolve stuff jaw +- Crossdoc destination ./doc/crossdoc.fd makes no sense when + cross.fs is used seperately. jaw +- Do we need this char translation with >address and in branchoffset? + (>body also affected) jaw [THEN] +s" compat/strcomp.fs" included + hex \ debugging for compiling @@ -62,6 +62,7 @@ forth definitions : T previous Ghosts also Target ; immediate : G Ghosts ; immediate + : >cross also Cross definitions previous ; : >target also Target definitions previous ; : >minimal also Minimal definitions previous ; @@ -70,6 +71,10 @@ H >CROSS +\ Test against this definitions to find out whether we are cross-compiling +\ may be usefull for assemblers +0 Constant gforth-cross-indicator + \ find out whether we are compiling with gforth : defined? bl word find nip ; @@ -201,6 +206,13 @@ Create bases 10 , 2 , A , 100 , [THEN] +\ this provides assert( and struct stuff +\GFORTH [IFUNDEF] assert1( +\GFORTH also forth definitions require assert.fs previous +\GFORTH [THEN] + +>CROSS + hex \ the defualt base for the cross-compiler is hex !! \ Warnings off @@ -241,16 +253,27 @@ hex \ the defualt base for the cross hex +\ FIXME delete` \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are \ for cross-compiling \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!! +\ FIXME move down : comment? ( c-addr u -- c-addr u ) - 2dup s" (" compare 0= + 2dup s" (" str= IF postpone ( - ELSE 2dup s" \" compare 0= IF postpone \ THEN + ELSE 2dup s" \" str= IF postpone \ THEN THEN ; +: X ( -- ) +\G The next word in the input is a target word. +\G Equivalent to T but without permanent +\G switch to target dictionary. Used as prefix e.g. for @, !, here etc. + bl word count [ ' target >wordlist ] Literal search-wordlist + IF state @ IF compile, ELSE execute THEN + ELSE -1 ABORT" Cross: access method not supported!" + THEN ; immediate + \ Begin CROSS COMPILER: \ debugging @@ -296,6 +319,18 @@ set-order previous \ POSTPONE false THEN ; immediate +: symentry ( adr len taddr -- ) +\G Produce a symbol table (an optional symbol address +\G map) if wanted + [ [IFDEF] fd-symbol-table ] + base @ swap hex s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base ! + s" :" fd-symbol-table write-file throw + fd-symbol-table write-line throw + [ [ELSE] ] + 2drop drop + [ [THEN] ] ; + + \ \ -------------------- source file decimal @@ -411,7 +446,7 @@ sourcepath value fpath \G Make a complete new Forth search path; the path separator is |. fpath path= ; -: path>counted cell+ dup cell+ swap @ ; +: path>string cell+ dup cell+ swap @ ; : next-path ( adr len -- adr2 len2 ) 2dup 0 scan @@ -420,12 +455,12 @@ sourcepath value fpath r> - ; : previous-path ( path^ -- ) - dup path>counted + dup path>string BEGIN tuck dup WHILE repeat ; : .path ( path-addr -- ) \ gforth \G Display the contents of the search path @var{path-addr}. - path>counted + path>string BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ; : .fpath ( -- ) \ gforth @@ -440,8 +475,8 @@ sourcepath value fpath 2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/.... over c@ [char] / = >r over c@ [char] ~ = >r - \ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic - 2 min S" ./" compare 0= + \ 2dup S" ../" string-prefix? r> or >r \ not catered for in expandtopic + S" ./" string-prefix? r> r> r> or or or ; Create ofile 0 c, 255 chars allot @@ -457,14 +492,14 @@ Create tfile 0 c, 255 chars allot REPEAT ; : remove~+ ( -- ) - ofile count 3 min s" ~+/" compare 0= + ofile count s" ~+/" string-prefix? IF ofile count 3 /string ofile place THEN ; : expandtopic ( -- ) \ stack effect correct? - anton \ expands "./" into an absolute name - ofile count 2 min s" ./" compare 0= + ofile count s" ./" string-prefix? IF ofile count 1 /string tfile place 0 ofile c! sourcefilename extractpath ofile place @@ -477,7 +512,7 @@ Create tfile 0 c, 255 chars allot \ deletes phrases like "xy/.." out of our directory name 2dec97jaw over swap BEGIN dup WHILE - dup >r '/ scan 2dup 4 min s" /../" compare 0= + dup >r '/ scan 2dup s" /../" string-prefix? IF dup r> - >r 4 /string over r> + 4 - swap 2dup + >r move dup r> over - @@ -510,7 +545,7 @@ Create tfile 0 c, 255 chars allot IF rdrop ofile place open-ofile dup 0= IF >r ofile count r> THEN EXIT - ELSE r> path>counted + ELSE r> path>string BEGIN next-path dup WHILE 5 pick 5 pick check-path 0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN @@ -540,7 +575,7 @@ fpath= ~+ : included? ( c-addr u -- f ) file-list BEGIN @ dup - WHILE >r 2dup r@ >fl-name count compare 0= + WHILE >r 2dup r@ >fl-name count str= IF rdrop 2drop true EXIT THEN r> REPEAT @@ -626,170 +661,342 @@ stack-warn [IF] : defempty? empty? ; [ELSE] : defempty? ; immediate +\ : defempty? .sourcepos ; [THEN] -\ \ GhostNames Ghosts 9may93jaw +\ \ -------------------- Compiler Plug Ins 01aug97jaw -\ second name source to search trough list +>CROSS -VARIABLE GhostNames -0 GhostNames ! +\ Compiler States -: GhostName ( -- addr ) - align here GhostNames @ , GhostNames ! here 0 , - bl word count - \ 2dup type space - string, \ !! cfalign ? - align ; +Variable comp-state +0 Constant interpreting +1 Constant compiling +2 Constant resolving +3 Constant assembling -\ Ghost Builder 06oct92py +: compiling? comp-state @ compiling = ; + +: pi-undefined -1 ABORT" Plugin undefined" ; + +: Plugin ( -- : pluginname ) + Create + \ for normal cross-compiling only one action + \ exists, this fields are identical. For the instant + \ simulation environment we need, two actions for each plugin + \ the target one and the one that generates the simulation code + ['] pi-undefined , \ action + ['] pi-undefined , \ target plugin action + 8765 , \ plugin magic + DOES> perform ; + +Plugin DummyPlugin + +: 'PI ( -- addr : pluginname ) + ' >body dup 2 cells + @ 8765 <> ABORT" not a plugin" ; + +: plugin-of ( xt -- : pluginname ) + dup 'PI 2! ; + +: action-of ( xt -- : plunginname ) + 'PI cell+ ! ; + +: TPA ( -- : plugin ) +\ target plugin action +\ executes current target action of plugin + 'PI cell+ POSTPONE literal POSTPONE perform ; immediate + +Variable ppi-temp 0 ppi-temp ! + +: pa: +\g define plugin action + ppi-temp @ ABORT" pa: definition not closed" + 'PI ppi-temp ! :noname ; + +: ;pa +\g end a definition for plugin action + POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate + + +Plugin dlit, ( d -- ) \ compile numerical value the target +Plugin lit, ( n -- ) +Plugin alit, ( n -- ) + +Plugin branch, ( target-addr -- ) \ compiles a branch +Plugin ?branch, ( target-addr -- ) \ compiles a ?branch +Plugin branchmark, ( -- branch-addr ) \ reserves room for a branch +Plugin ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch +Plugin ?domark, ( -- branch-addr ) \ reserves room for a ?do branch +Plugin branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment) +' NOOP plugin-of branchto, +Plugin branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark +Plugin branchtomark, ( -- target-addr ) \ marks a branch destination + +Plugin colon, ( tcfa -- ) \ compiles call to tcfa at current position +Plugin prim, ( tcfa -- ) \ compiles primitive invocation +Plugin colonmark, ( -- addr ) \ marks a colon call +Plugin colon-resolve ( tcfa addr -- ) + +Plugin addr-resolve ( target-addr addr -- ) +Plugin doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt ) + +Plugin ncontrols? ( [ xn ... x1 ] n -- ) \ checks wheter n control structures are open +Plugin if, ( -- if-token ) +Plugin else, ( if-token -- if-token ) +Plugin then, ( if-token -- ) +Plugin ahead, +Plugin begin, +Plugin while, +Plugin until, +Plugin again, +Plugin repeat, +Plugin cs-swap ( x1 x2 -- x2 x1 ) + +Plugin case, ( -- n ) +Plugin of, ( n -- x1 n ) +Plugin endof, ( x1 n -- x2 n ) +Plugin endcase, ( x1 .. xn n -- ) + +Plugin do, ( -- do-token ) +Plugin ?do, ( -- ?do-token ) +Plugin for, ( -- for-token ) +Plugin loop, ( do-token / ?do-token -- ) +Plugin +loop, ( do-token / ?do-token -- ) +Plugin next, ( for-token ) +Plugin leave, ( -- ) +Plugin ?leave, ( -- ) + +Plugin ca>native \ Convert a code address to the processors + \ native address. This is used in doprim, and + \ code/code: primitive definitions word to + \ convert the addresses. + \ The only target where we need this is the misc + \ which is a 16 Bit processor with word addresses + \ but the forth system we build has a normal byte + \ addressed memory model + +Plugin doprim, \ compiles start of a primitive +Plugin docol, \ compiles start of a colon definition +Plugin doer, +Plugin fini, \ compiles end of definition ;s +Plugin doeshandler, +Plugin dodoes, + +Plugin colon-start +' noop plugin-of colon-start +Plugin colon-end +' noop plugin-of colon-end + +Plugin ]comp \ starts compilation +' noop plugin-of ]comp +Plugin comp[ \ ends compilation +' noop plugin-of comp[ -\ new version with temp variable 10may93jaw +Plugin t>body \ we need the system >body + \ and the target >body + +>TARGET +: >body t>body ; -VARIABLE VocTemp -: previous VocTemp @ set-current ; +\ Ghost Builder 06oct92py +>CROSS hex +\ Values for ghost magic 4711 Constant 4712 Constant 4713 Constant 4714 Constant 4715 Constant -\ Compiler States +\ Bitmask for ghost flags +1 Constant +2 Constant + +\ FXIME: move this to general stuff? +: set-flag ( addr flag -- ) + over @ or swap ! ; -Variable comp-state -0 Constant interpreting -1 Constant compiling -2 Constant resolving -3 Constant assembling +: reset-flag ( addr flag -- ) + invert over @ and swap ! ; -Defer lit, ( n -- ) -Defer alit, ( n -- ) +: get-flag ( addr flag -- f ) + swap @ and 0<> ; + -Defer branch, ( target-addr -- ) \ compiles a branch -Defer ?branch, ( target-addr -- ) \ compiles a ?branch -Defer branchmark, ( -- branch-addr ) \ reserves room for a branch -Defer ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch -Defer ?domark, ( -- branch-addr ) \ reserves room for a ?do branch -Defer branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment) -Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark -Defer branchfrom, ( -- ) \ ?! -Defer branchtomark, ( -- target-addr ) \ marks a branch destination - -Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position -Defer prim, ( tcfa -- ) \ compiles a primitive invocation - \ at current position -Defer colonmark, ( -- addr ) \ marks a colon call -Defer colon-resolve ( tcfa addr -- ) - -Defer addr-resolve ( target-addr addr -- ) -Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt ) - -Defer do, ( -- do-token ) -Defer ?do, ( -- ?do-token ) -Defer for, ( -- for-token ) -Defer loop, ( do-token / ?do-token -- ) -Defer +loop, ( do-token / ?do-token -- ) -Defer next, ( for-token ) - -[IFUNDEF] ca>native -defer ca>native -[THEN] - -\ ghost structure - -: >magic ; \ type of ghost -: >link cell+ ; \ pointer where ghost is in target, or if unresolved - \ points to the where we have to resolve (linked-list) -: >exec cell+ cell+ ; \ execution symantics (while target compiling) of ghost -: >comp 3 cells + ; \ compilation semantics -: >end 4 cells + ; \ room for additional tags - \ for builder (create, variable...) words the - \ execution symantics of words built are placed here +Struct -\ resolve structure + \ link to next ghost (always the first element) + cell% field >next-ghost -: >next ; \ link to next field -: >tag cell+ ; \ indecates type of reference: 0: call, 1: address, 2: doer -: >taddr cell+ cell+ ; -: >ghost 3 cells + ; -: >file 4 cells + ; -: >line 5 cells + ; + \ type of ghost + cell% field >magic + + \ pointer where ghost is in target, or if unresolved + \ points to the where we have to resolve (linked-list) + cell% field >link + + \ execution semantics (while target compiling) of ghost + cell% field >exec + + \ compilation action of this ghost; this is what is + \ done to compile a call (or whatever) to this definition. + \ E.g. >comp contains the semantic of postpone s" + \ whereas >exec-compile contains the semantic of s" + cell% field >comp + + \ Compilation sematics (while parsing) of this ghost. E.g. + \ "\" will skip the rest of line. + \ These semantics are defined by Cond: and + \ if a word is made immediate in instant, then the >exec2 field + \ gets copied to here + cell% field >exec-compile + + \ Additional execution semantics of this ghost. This is used + \ for code generated by instant and for the doer-xt of created + \ words + cell% field >exec2 + + cell% field >created + + \ the xt of the created ghost word itself + cell% field >ghost-xt + + \ pointer to the counted string of the assiciated + \ assembler label + cell% field >asm-name + + \ mapped primitives have a special address, so + \ we are able to detect them + cell% field >asm-dummyaddr + + \ for builder (create, variable...) words + \ the execution symantics of words built are placed here + \ this is a doer ghost or a dummy ghost + cell% field >do:ghost + + cell% field >ghost-flags -\ refer variables + cell% field >ghost-name + +End-Struct ghost-struct + +Variable ghost-list +0 ghost-list ! Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes> -Variable last-ghost \ last ghost that is created +\ Variable last-ghost \ last ghost that is created Variable last-header-ghost \ last ghost definitions with header -: (refered) ( ghost addr tag -- ) -\G creates a reference to ghost at address taddr - rot >r here r@ >link @ , r> >link ! - ( taddr tag ) , - ( taddr ) , - last-header-ghost @ , - loadfile , - sourceline# , - ; +\ space for ghosts resolve structure +\ we create ghosts in a sepearte space +\ and not to the current host dp, because this +\ gives trouble with instant while compiling and creating +\ a ghost for a forward reference +\ BTW: we cannot allocate another memory region +\ because allot will check the overflow!! +Variable cross-space-dp +Create cross-space 250000 allot here 100 allot align +Constant cross-space-end +cross-space cross-space-dp ! +Variable cross-space-dp-orig + +: cross-space-used cross-space-dp @ cross-space - ; + +: >space ( -- ) + dp @ cross-space-dp-orig ! + cross-space-dp @ dp ! ; + +: space> ( -- ) + dp @ dup cross-space-dp ! + cross-space-end u> ABORT" CROSS: cross-space overflow" + cross-space-dp-orig @ dp ! ; + +\ this is just for debugging, to see this in the backtrace +: execute-exec execute ; +: execute-exec2 execute ; +: execute-exec-compile execute ; + +: NoExec + executed-ghost @ >exec2 @ + ?dup + IF execute-exec2 + ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word" + THEN ; -\ iForth makes only immediate directly after create -\ make atonce trick! ? +Defer is-forward -Variable atonce atonce off +: (ghostheader) ( -- ) + ghost-list linked , 0 , ['] NoExec , ['] is-forward , + 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ; -: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ; +: ghostheader ( -- ) (ghostheader) 0 , ; -: is-forward ( ghost -- ) - colonmark, 0 (refered) ; \ compile space for call +' Ghosts >wordlist Constant ghosts-wordlist -: GhostHeader , 0 , ['] NoExec , ['] is-forward , ; +\ the current wordlist for ghost definitions in the host +ghosts-wordlist Value current-ghosts : Make-Ghost ( "name" -- ghost ) - >in @ GhostName swap >in ! - - dup last-ghost ! - DOES> dup executed-ghost ! >exec @ execute ; + >space + \ save current and create in ghost vocabulary + get-current >r current-ghosts set-current + >in @ Create >in ! + \ some forth systems like iForth need the immediate directly + \ after the word is created + \ restore current + r> set-current + here (ghostheader) + bl word count string, align + space> + \ set ghost-xt field by doing a search + dup >ghost-name count + current-ghosts search-wordlist + 0= ABORT" CROSS: Just created, must be there!" + over >ghost-xt ! + DOES> + dup executed-ghost ! + >exec @ execute-exec ; \ ghost words 14oct92py \ changed: 10may93py/jaw -: gfind ( string -- ghost true/1 / string false ) +Defer search-ghosts + +: (search-ghosts) ( adr len -- cfa true | 0 ) + current-ghosts search-wordlist ; + + ' (search-ghosts) IS search-ghosts + +: gsearch ( addr len -- ghost true | 0 ) + search-ghosts + dup IF swap >body swap THEN ; + +: gfind ( string -- ghost true / string false ) \ searches for string in word-list ghosts - dup count [ ' ghosts >wordlist ] Literal search-wordlist - dup IF >r >body nip r> THEN ; + \ dup count type space + dup >r count gsearch + dup IF rdrop ELSE r> swap THEN ; : gdiscover ( xt -- ghost true | xt false ) - GhostNames + >r ghost-list BEGIN @ dup - WHILE 2dup - cell+ @ dup >magic @ <> - >r >link @ = r> and - IF cell+ @ nip true EXIT THEN + WHILE dup >magic @ <> + IF dup >link @ r@ = + IF rdrop true EXIT THEN + THEN REPEAT - drop false ; + drop r> false ; -VARIABLE Already +: xt>ghost ( xt -- ghost ) + gdiscover 0= ABORT" CROSS: ghost not found for this xt" ; -: ghost ( "name" -- ghost ) - Already off - >in @ bl word gfind IF atonce off Already on nip EXIT THEN +: Ghost ( "name" -- ghost ) + >in @ bl word gfind IF nip EXIT THEN drop >in ! Make-Ghost ; : >ghostname ( ghost -- adr len ) - GhostNames - BEGIN @ dup - WHILE 2dup cell+ @ = - UNTIL nip 2 cells + count - ELSE 2drop - \ true abort" CROSS: Ghostnames inconsistent" - s" ?!?!?!" - THEN ; - -: .ghost ( ghost -- ) >ghostname type ; - -\ ' >ghostname ALIAS @name + >ghost-name count ; : forward? ( ghost -- flag ) >magic @ = ; @@ -797,52 +1004,145 @@ VARIABLE Already : undefined? ( ghost -- flag ) >magic @ dup = swap = or ; +: immediate? ( ghost -- flag ) + >magic @ = ; + +Variable TWarnings +TWarnings on +Variable Exists-Warnings +Exists-Warnings on + +: exists-warning ( ghost -- ghost ) + TWarnings @ Exists-Warnings @ and + IF dup >ghostname warnhead type ." exists " THEN ; + +\ : HeaderGhost Ghost ; + +Variable reuse-ghosts reuse-ghosts off + +: HeaderGhost ( "name" -- ghost ) + >in @ + bl word count +\ 2dup type space + current-ghosts search-wordlist + IF >body dup undefined? reuse-ghosts @ or + IF nip EXIT + ELSE exists-warning + THEN + drop >in ! + ELSE >in ! + THEN + \ we keep the execution semantics of the prviously + \ defined words, this is a workaround + \ for the redefined \ until vocs work + Make-Ghost ; + +: .ghost ( ghost -- ) >ghostname type ; + +\ ' >ghostname ALIAS @name + +: findghost ( "ghostname" -- ghost ) + bl word gfind 0= ABORT" CROSS: Ghost don't exists" ; + +: [G'] ( -- ghost : name ) +\G ticks a ghost and returns its address + findghost + state @ IF postpone literal THEN ; immediate + +: g>xt ( ghost -- xt ) +\G Returns the xt (cfa) of a ghost. Issues a warning if undefined. + dup undefined? ABORT" CROSS: forward " >link @ ; + +: g>body ( ghost -- body ) +\G Returns the body-address (pfa) of a ghost. +\G Issues a warning if undefined (a forward-reference). + g>xt X >body ; + +1 Constant