--- gforth/cross.fs 2001/09/04 13:07:44 1.104 +++ gforth/cross.fs 2001/09/05 13:11:36 1.109 @@ -23,11 +23,11 @@ [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 +- MAXU etc. can be done with dlit, [THEN] @@ -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 ; @@ -251,6 +252,12 @@ hex ELSE 2dup s" \" compare 0= IF postpone \ THEN THEN ; +: X 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 @@ -628,14 +635,160 @@ stack-warn [IF] : defempty? ; immediate [THEN] +\ \ -------------------- Compiler Plug Ins 01aug97jaw + +>CROSS + +\ Compiler States + +Variable comp-state +0 Constant interpreting +1 Constant compiling +2 Constant resolving +3 Constant assembling + +: 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, ( -- ) + +[IFUNDEF] ca>native +Plugin ca>native +[THEN] + +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[ + +Plugin t>body \ we need the system >body + \ and the target >body + +>TARGET +: >body t>body ; + + \ Ghost Builder 06oct92py +>CROSS hex +\ Values for ghost magic 4711 Constant 4712 Constant 4713 Constant 4714 Constant 4715 Constant +\ Bitmask for ghost flags 1 Constant +2 Constant + +\ FXIME: move this to general stuff? +: set-flag ( addr flag -- ) + over @ or swap ! ; + +: reset-flag ( addr flag -- ) + invert over @ and swap ! ; + +: get-flag ( addr flag -- f ) + swap @ and 0<> ; + Struct @@ -649,11 +802,25 @@ Struct \ points to the where we have to resolve (linked-list) cell% field >link - \ execution symantics (while target compiling) of ghost + \ 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 @@ -711,6 +878,7 @@ Variable cross-space-dp-orig 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 ; @@ -722,8 +890,11 @@ Variable cross-space-dp-orig ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word" THEN ; +Defer is-forward + : (ghostheader) ( -- ) - ghost-list linked , 0 , ['] NoExec , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ; + ghost-list linked , 0 , ['] NoExec , ['] is-forward , + 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ; : ghostheader ( -- ) (ghostheader) 0 , ; @@ -783,6 +954,9 @@ Defer search-ghosts REPEAT drop r> false ; +: xt>ghost ( xt -- ghost ) + gdiscover 0= ABORT" CROSS: ghost not found for this xt" ; + : Ghost ( "name" -- ghost ) >in @ bl word gfind IF nip EXIT THEN drop >in ! Make-Ghost ; @@ -841,9 +1015,15 @@ Variable reuse-ghosts reuse-ghosts off \ bl word gfind 0= ABORT" CROSS: Ghost don't exists" ghost state @ IF postpone literal THEN ; immediate -: ghost>cfa ( ghost -- cfa ) +: 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