--- gforth/cross.fs 2001/03/11 21:47:27 1.93 +++ gforth/cross.fs 2001/07/10 20:47:09 1.100 @@ -678,6 +678,8 @@ 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 -- ) @@ -942,7 +944,7 @@ Variable user-vars 0 user-vars ! : target>bitmask-size ( u1 -- u2 ) 1- tcell>bit rshift 1+ ; -: allocatetarget ( size --- adr ) +: allocatetarget ( size -- adr ) dup allocate ABORT" CROSS: No memory for target" swap over swap erase ; @@ -1048,7 +1050,7 @@ T has? rom H ' dictionary ALIAS rom-dictionary -: setup-target ( -- ) \G initialize targets memory space +: setup-target ( -- ) \G initialize target's memory space s" rom" T $has? H IF \ check for ram and rom... \ address-space area nip 0<> @@ -1085,7 +1087,7 @@ T has? rom H ELSE r> drop THEN REPEAT drop ; -\ MakeKernal 22feb99jaw +\ MakeKernel 22feb99jaw : makekernel ( targetsize -- targetsize ) dup dictionary >rlen ! setup-target ; @@ -1350,9 +1352,9 @@ DEFER dodoes, DEFER ]comp \ starts compilation DEFER comp[ \ ends compilation -: (cc) T a, H ; ' (cc) IS colon, +: (prim) T a, H ; ' (prim) IS prim, -: (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve +: (cr) >tempdp ]comp prim, comp[ tempdp> ; ' (cr) IS colon-resolve : (ar) T ! H ; ' (ar) IS addr-resolve : (dr) ( ghost res-pnt target-addr addr ) >tempdp drop over @@ -1364,10 +1366,10 @@ DEFER comp[ \ ends compilation : (cm) ( -- addr ) T here align H - -1 colon, ; ' (cm) IS colonmark, + -1 prim, ; ' (cm) IS colonmark, >TARGET -: compile, colon, ; +: compile, prim, ; >CROSS : refered ( ghost tag -- ) @@ -1439,8 +1441,10 @@ Exists-Warnings on ELSE true abort" CROSS: Ghostnames inconsistent " THEN ; -: is-resolved ( ghost -- ) - >link @ colon, ; \ compile-call +: colon-resolved ( ghost -- ) + >link @ colon, ; \ compile-call +: prim-resolved ( ghost -- ) + >link @ prim, ; : resolve ( ghost tcfa -- ) \G resolve referencies to ghost with tcfa @@ -1451,7 +1455,8 @@ Exists-Warnings on swap >r r@ >link @ swap \ ( list tcfa R: ghost ) \ mark ghost as resolved dup r@ >link ! r@ >magic ! - r@ >comp @ ['] is-forward = IF ['] is-resolved r@ >comp ! THEN + r@ >comp @ ['] is-forward = IF + ['] prim-resolved r@ >comp ! THEN \ loop through forward referencies r> -rot comp-state @ >r Resolving comp-state ! @@ -1574,8 +1579,7 @@ Variable to-doc to-doc on IF s" " doc-file-id write-line throw s" make-doc " doc-file-id write-file throw - - tlast @ >image count 1F and doc-file-id write-file throw + Last-Header-Ghost @ >ghostname doc-file-id write-file throw >in @ [char] ( parse 2drop [char] ) parse doc-file-id write-file throw @@ -1772,6 +1776,12 @@ Comment ( Comment \ ELSE postpone literal postpone gexecute THEN ; immediate +T has? peephole H [IF] +: (cc) compile call T >body a, H ; ' (cc) IS colon, +[ELSE] + ' (prim) IS colon, +[THEN] + : [G'] \G ticks a ghost and returns its address bl word gfind 0= ABORT" CROSS: Ghost don't exists" @@ -1805,7 +1815,7 @@ Cond: ['] T ' H alit, ;Cond : (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H -: (doer,) ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ; ' (doer,) IS doer, +: (doer,) ( ghost -- ) ]comp addr, comp[ 1 fillcfa ; ' (doer,) IS doer, : (docol,) ( -- ) [G'] :docol doer, ; ' (docol,) IS docol, @@ -1968,7 +1978,8 @@ Cond: ; ( -- ) restrict? comp[ state off ;Resolve @ - IF ;Resolve @ ;Resolve cell+ @ resolve THEN + IF ;Resolve @ ;Resolve cell+ @ resolve + ['] colon-resolved ;Resolve @ >comp ! THEN Interpreting comp-state ! ;Cond Cond: [ restrict? state off Interpreting comp-state ! ;Cond @@ -1986,11 +1997,17 @@ Create GhostDummy ghostheader GhostDummy >link ! GhostDummy tlastcfa @ >tempdp dodoes, tempdp> ; +: g>body ( ghost -- body ) + >link @ T >body H ; +: does-resolved ( ghost -- ) + dup g>body alit, >end @ g>body colon, ; + >TARGET Cond: DOES> restrict? compile (does>) doeshandler, \ resolve words made by builders - tdoes @ ?dup IF @ T here H resolve THEN + tdoes @ ?dup IF @ dup T here H resolve + ['] prim-resolved swap >comp ! THEN ;Cond : DOES> switchrom doeshandler, T here H !does depth T ] H ; @@ -1999,14 +2016,14 @@ Cond: DOES> restrict? \ Builder 11may93jaw -: Builder ( Create-xt do:-xt "name" -- ) +: Builder ( Create-xt do-ghost "name" -- ) \ builds up a builder in current vocabulary \ create-xt is executed when word is interpreted \ do:-xt is executet when the created word from builder is executed \ for do:-xt an additional entry after the normal ghost-enrys is used - Make-Ghost ( Create-xt do:-xt ghost ) - rot swap ( do:-xt Create-xt ghost ) + Make-Ghost ( Create-xt do-ghost ghost ) + rot swap ( do-ghost Create-xt ghost ) >exec ! , ; : gdoes, ( ghost -- ) @@ -2029,7 +2046,7 @@ Cond: DOES> restrict? executed-ghost @ create-forward-warn IF ['] reswarn-forward IS resolve-warning THEN - Theader >r dup gdoes, + Theader >r dup , dup gdoes, \ stores execution semantic in the built word \ if the word already has a semantic (concerns S", IS, .", DOES>) \ then keep it @@ -2067,8 +2084,6 @@ Cond: DOES> restrict? postpone TCreate [ [THEN] ] ; -: g>body ( ghost -- body ) - >link @ T >body H ; : gdoes> ( ghost -- addr flag ) executed-ghost @ state @ IF gexecute true EXIT THEN @@ -2089,10 +2104,16 @@ Cond: DOES> restrict? postpone ; ( S addr xt ) over >exec ! ; immediate +T has? peephole H [IF] : compile: ( ghost -- ghost [xt] [colon-sys] ) :noname postpone g>body ; : ;compile ( ghost [xt] [colon-sys] -- ghost ) - postpone ; over >comp ! ; + postpone ; over >comp ! ; immediate +[ELSE] +: compile: ( ghost -- ghost xt colon-sys ) :noname ; +: ;compile ( ghost xt colon-sys -- ghost ) + postpone ; drop ['] prim-resolved over >comp ! ; immediate +[THEN] : by ( -- ghost ) \ Name ghost >end @ ; @@ -2102,7 +2123,7 @@ Cond: DOES> restrict? Build: ( n -- ) ; by: :docon ( ghost -- n ) T @ H ;DO -\ compile: alit, compile @ ;compile +compile: alit, compile @ ;compile Builder (Constant) Build: ( n -- ) T , H ; @@ -2129,6 +2150,7 @@ Builder Variable [ELSE] Build: T 0 , H ; by Create +\ compile: alit, ;compile Builder Variable [THEN] @@ -2139,6 +2161,7 @@ Builder 2Variable [ELSE] Build: T 0 , 0 , H ; by Create +\ compile: alit, ;compile Builder 2Variable [THEN] @@ -2149,6 +2172,7 @@ Builder AVariable [ELSE] Build: T 0 A, H ; by Create +\ compile: alit, ;compile Builder AVariable [THEN] @@ -2171,7 +2195,7 @@ Variable tudp 0 tudp ! Build: 0 u, X , ; by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO -\ compile: compile useraddr @ , ;compile +compile: compile useraddr T @ , H ;compile Builder User Build: 0 u, X , 0 u, drop ; @@ -2192,7 +2216,7 @@ Builder AValue BuildSmart: ( -- ) [T'] noop T A, H ; by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO -\ compile: alit, compile @ compile execute ;compile +compile: alit, compile @ compile execute ;compile Builder Defer Build: ( inter comp -- ) swap T immediate A, A, H ; @@ -2209,7 +2233,7 @@ Builder interpret/compile: Build: ; by: :dofield T @ H + ;DO -\ compile: T @ H lit, compile + ;compile +compile: T @ H lit, compile + ;compile Builder (Field) Build: ( align1 offset1 align size "name" -- align2 offset2 ) @@ -2674,6 +2698,10 @@ previous : .s .s ; : bye bye ; +\ dummy + +: group source >in ! drop ; + \ turnkey direction : H forth ; immediate : T minimal ; immediate