--- gforth/cross.fs 1999/05/17 15:05:17 1.77 +++ gforth/cross.fs 2001/06/16 22:53:36 1.99 @@ -1,7 +1,7 @@ \ CROSS.FS The Cross-Compiler 06oct92py \ Idea and implementation: Bernd Paysan (py) -\ Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -17,7 +17,7 @@ \ 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., 675 Mass Ave, Cambridge, MA 02139, USA. +\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. 0 [IF] @@ -53,13 +53,13 @@ Vocabulary Minimal only Forth also Target also also definitions Forth -: T previous Cross also Target ; immediate +: T previous Ghosts also Target ; immediate : G Ghosts ; immediate : H previous Forth also Cross ; immediate forth definitions -: T previous Cross also Target ; immediate +: T previous Ghosts also Target ; immediate : G Ghosts ; immediate : >cross also Cross definitions previous ; @@ -135,6 +135,10 @@ Create bases 10 , 2 , A , 100 , r> ; : s>unumber? ( addr u -- ud flag ) + over [char] ' = + IF \ a ' alone is rather unusual :-) + drop char+ c@ 0 true EXIT + THEN base @ >r dpl on getbase 0. 2swap BEGIN ( d addr len ) @@ -198,7 +202,7 @@ Create bases 10 , 2 , A , 100 , [THEN] hex \ the defualt base for the cross-compiler is hex !! -Warnings off +\ Warnings off \ words that are generaly useful @@ -470,27 +474,17 @@ Create tfile 0 c, 255 chars allot THEN ; : compact.. ( adr len -- adr2 len2 ) -\ deletes phrases like "xy/.." out of our directory name 2dec97jaw - over >r -1 >r - BEGIN dup WHILE - over c@ pathsep? - IF r@ -1 = - IF r> drop dup >r - ELSE 2dup 1 /string - 3 min s" ../" compare - 0= - IF r@ over - ( diff ) - 2 pick swap - ( dest-adr ) - >r 3 /string r> swap 2dup >r >r - move r> r> - ELSE r> drop dup >r - THEN - THEN - THEN - 1 /string - REPEAT - r> drop - drop r> tuck - ; + \ deletes phrases like "xy/.." out of our directory name 2dec97jaw + over swap + BEGIN dup WHILE + dup >r '/ scan 2dup 4 min s" /../" compare 0= + IF + dup r> - >r 4 /string over r> + 4 - + swap 2dup + >r move dup r> over - + ELSE + rdrop dup 1 min /string + THEN + REPEAT drop over - ; : reworkdir ( -- ) remove~+ @@ -585,6 +579,8 @@ false DebugFlag showincludedfiles : require bl word count required ; +0 [IF] + also forth definitions previous : included ( adr len -- ) included ; @@ -595,6 +591,8 @@ also forth definitions previous : require require ; +[THEN] + >CROSS hex @@ -638,7 +636,7 @@ VARIABLE GhostNames 0 GhostNames ! : GhostName ( -- addr ) - here GhostNames @ , GhostNames ! here 0 , + align here GhostNames @ , GhostNames ! here 0 , bl word count \ 2dup type space string, \ !! cfalign ? @@ -658,27 +656,95 @@ hex 4713 Constant 4714 Constant 4715 Constant -\ iForth makes only immediate directly after create -\ make atonce trick! ? +\ Compiler States -Variable atonce atonce off +Variable comp-state +0 Constant interpreting +1 Constant compiling +2 Constant resolving +3 Constant assembling -: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ; +Defer lit, ( n -- ) +Defer alit, ( n -- ) -: GhostHeader , 0 , ['] NoExec , ; +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 -: >end 3 cells + ; \ room for additional tags +: >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 +\ resolve structure + +: >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 + ; + +\ refer variables + Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes> 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# , + ; + +\ iForth makes only immediate directly after create +\ make atonce trick! ? + +Variable atonce atonce off + +: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ; + +: is-forward ( ghost -- ) + colonmark, 0 (refered) ; \ compile space for call + +: GhostHeader , 0 , ['] NoExec , ['] is-forward , ; + : Make-Ghost ( "name" -- ghost ) >in @ GhostName swap >in ! ghostname type ; + \ ' >ghostname ALIAS @name : forward? ( ghost -- flag ) @@ -743,9 +811,10 @@ ghost (does>) ghost noop ghost (.") ghost (S") ghost (ABORT") 2drop drop ghost ' drop ghost :docol ghost :doesjump ghost :dodoes 2drop drop -ghost :dovar drop +ghost :dovar ghost :dodefer ghost :dofield 2drop drop ghost over ghost = ghost drop 2drop drop -ghost - drop +ghost call ghost useraddr ghost execute 2drop drop +ghost + ghost - ghost @ 2drop drop ghost 2drop drop ghost 2dup drop @@ -777,7 +846,7 @@ VARIABLE env-current \ save information >ENVIRON get-order get-current swap 1+ set-order true SetValue compiler -true SetValue cross +true SetValue cross true SetValue standard-threading >TARGET previous @@ -802,6 +871,8 @@ false DefaultValue dcomps false DefaultValue hash false DefaultValue xconds false DefaultValue header +false DefaultValue backtrace +false DefaultValue new-input [THEN] true DefaultValue interpreter @@ -854,7 +925,7 @@ float Constant tfloat bits/byte Constant tbits/byte [THEN] H -tbits/byte bits/byte / Constant tbyte +tbits/char bits/byte / Constant tbyte \ Variables 06oct92py @@ -917,7 +988,7 @@ Variable mirrored-link \ linked dup >rstart @ swap >rdp @ over - ; : area ( region -- startaddr totallen ) \G returns the total area - dup >rstart swap >rlen @ ; + dup >rstart @ swap >rlen @ ; : mirrored \G mark a region as mirrored mirrored-link @@ -1170,8 +1241,19 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, : +bit ( addr n -- ) >bit over c@ or swap c! ; : -bit ( addr n -- ) >bit invert over c@ and swap c! ; -: (relon) ( taddr -- ) bit$ @ swap cell/ +bit ; -: (reloff) ( taddr -- ) bit$ @ swap cell/ -bit ; +: (relon) ( taddr -- ) + [ [IFDEF] fd-relocation-table ] + s" +" fd-relocation-table write-file throw + dup s>d <# #s #> fd-relocation-table write-line throw + [ [THEN] ] + bit$ @ swap cell/ +bit ; + +: (reloff) ( taddr -- ) + [ [IFDEF] fd-relocation-table ] + s" -" fd-relocation-table write-file throw + dup s>d <# #s #> fd-relocation-table write-line throw + [ [THEN] ] + bit$ @ swap cell/ -bit ; : (>image) ( taddr -- absaddr ) image @ + ; @@ -1212,18 +1294,18 @@ T has? relocate H : c@ ( taddr -- char ) >image Sc@ ; : c! ( char taddr -- ) >image Sc! ; : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; -: 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ; +: 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ; \ Target compilation primitives 06oct92py \ included A! 16may93jaw : here ( -- there ) there ; : allot ( n -- ) tdp +! ; -: , ( w -- ) T here H tcell T allot ! H T here drop H ; -: c, ( char -- ) T here tchar allot c! H ; -: align ( -- ) T here H align+ 0 ?DO bl T c, tchar H +LOOP ; +: , ( w -- ) T here H tcell T allot ! H ; +: c, ( char -- ) T here H tchar T allot c! H ; +: align ( -- ) T here H align+ 0 ?DO bl T c, H tchar +LOOP ; : cfalign ( -- ) - T here H cfalign+ 0 ?DO bl T c, tchar H +LOOP ; + T here H cfalign+ 0 ?DO bl T c, H tchar +LOOP ; : >address dup 0>= IF tbyte / THEN ; \ ?? jaw : A! swap >address swap dup relon T ! H ; @@ -1255,45 +1337,6 @@ previous \ \ -------------------- Compiler Plug Ins 01aug97jaw -\ Compiler States - -Variable comp-state -0 Constant interpreting -1 Constant compiling -2 Constant resolving -3 Constant assembling - -Defer lit, ( n -- ) -Defer alit, ( n -- ) - -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 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] - >TARGET DEFER >body \ we need the system >body \ and the target >body @@ -1309,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 @@ -1323,31 +1366,12 @@ 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 -\ resolve structure - -: >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 + ; - -: (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# , - ; - : refered ( ghost tag -- ) \G creates a resolve structure T here aligned H swap (refered) @@ -1368,11 +1392,11 @@ DEFER comp[ \ ends compilation Defer resolve-warning : reswarn-test ( ghost res-struct -- ghost res-struct ) - over cr ." Resolving " >ghostname type dup ." in " >ghost @ >ghostname type ; + over cr ." Resolving " .ghost dup ." in " >ghost @ .ghost ; : reswarn-forward ( ghost res-struct -- ghost res-struct ) - over warnhead >ghostname type dup ." is referenced in " - >ghost @ >ghostname type ; + over warnhead .ghost dup ." is referenced in " + >ghost @ .ghost ; \ ' reswarn-test IS resolve-warning @@ -1417,6 +1441,11 @@ Exists-Warnings on ELSE true abort" CROSS: Ghostnames inconsistent " THEN ; +: colon-resolved ( ghost -- ) + >link @ colon, ; \ compile-call +: prim-resolved ( ghost -- ) + >link @ prim, ; + : resolve ( ghost tcfa -- ) \G resolve referencies to ghost with tcfa \ is ghost resolved?, second resolve means another definition with the @@ -1426,6 +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 + ['] prim-resolved r@ >comp ! THEN \ loop through forward referencies r> -rot comp-state @ >r Resolving comp-state ! @@ -1437,17 +1468,11 @@ Exists-Warnings on \ gexecute ghost, 01nov92py -: is-forward ( ghost -- ) - colonmark, 0 (refered) ; \ compile space for call - -: is-resolved ( ghost -- ) - >link @ colon, ; \ compile-call - : gexecute ( ghost -- ) - dup @ = IF is-forward ELSE is-resolved THEN ; + dup >comp @ execute ; : addr, ( ghost -- ) - dup @ = IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ; + dup forward? IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ; \ !! : ghost, ghost gexecute ; @@ -1465,7 +1490,7 @@ variable ResolveFlag >link BEGIN @ dup WHILE cr 5 spaces - dup >ghost @ >ghostname type + dup >ghost @ .ghost ." file " dup >file @ ?dup IF count type ELSE ." CON" THEN ." line " dup >line @ .dec REPEAT @@ -1479,7 +1504,6 @@ variable ResolveFlag ELSE drop THEN ; ->MINIMAL : .unresolved ( -- ) ResolveFlag off cr ." Unresolved: " Ghostnames @@ -1498,19 +1522,29 @@ variable ResolveFlag cr ." named Headers: " headers-named @ . r> base ! ; +>MINIMAL + +: .unresolved .unresolved ; + >CROSS \ Header states 12dec92py -: flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ; +bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+ +: flag! ( w -- ) tlast @ flag+ + dup >r T c@ xor r> c! H ; VARIABLE ^imm +\ !! should be target wordsize specific +$80 constant alias-mask +$40 constant immediate-mask +$20 constant restrict-mask + >TARGET -: immediate 40 flag! +: immediate immediate-mask flag! ^imm @ @ dup = IF drop EXIT THEN <> ABORT" CROSS: Cannot immediate a unresolved word" ^imm @ ! ; -: restrict 20 flag! ; +: restrict restrict-mask flag! ; : isdoer \G define a forth word as doer, this makes obviously only sence on @@ -1518,18 +1552,14 @@ VARIABLE ^imm last-header-ghost @ >magic ! ; >CROSS -\ ALIAS2 ansforth conform alias 9may93jaw - -: ALIAS2 create here 0 , DOES> @ execute ; -\ usage: -\ ' alias2 bla ! - \ Target Header Creation 01nov92py >TARGET : string, ( addr count -- ) - dup T c, H bounds ?DO I c@ T c, H LOOP ; -: name, ( "name" -- ) bl word count T string, cfalign H ; + dup T c, H bounds ?DO I c@ T c, H LOOP ; +: lstring, ( addr count -- ) + dup T , H bounds ?DO I c@ T c, H LOOP ; +: name, ( "name" -- ) bl word count T lstring, cfalign H ; : view, ( -- ) ( dummy ) ; >CROSS @@ -1549,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 @@ -1600,7 +1629,8 @@ Create tag-bof 1 c, 0C c, Defer skip? ' false IS skip? : skipdef ( -- ) -\G skip definition of an undefined word in undef-words mode +\G skip definition of an undefined word in undef-words and +\G all-words mode ghost dup forward? IF >magic swap ! ELSE drop THEN ; @@ -1613,6 +1643,10 @@ Defer skip? ' false IS skip? \G that's what we want ghost forward? 0= ; +: forced? ( -- flag ) \ name +\G return ture if it is a foreced skip with defskip + ghost >magic @ = ; + : needed? ( -- flag ) \ name \G returns a false flag when \G a word is not defined @@ -1632,9 +1666,6 @@ Defer skip? ' false IS skip? \ Target header creation -Variable CreateFlag -CreateFlag off - Variable NoHeaderFlag NoHeaderFlag off @@ -1642,7 +1673,9 @@ NoHeaderFlag off base @ >r hex 0 swap <# 0 ?DO # LOOP #> type r> base ! ; -: .sym + +: .sym ( adr len -- ) +\G escapes / and \ to produce sed output bounds DO I c@ dup CASE [char] / OF drop ." \/" ENDOF @@ -1660,32 +1693,27 @@ NoHeaderFlag off IF NoHeaderFlag off ELSE T align H view, - tlast @ dup 0> IF T 1 cells - H THEN T A, H there tlast ! + tlast @ dup 0> IF tcell - THEN T A, H there tlast ! 1 headers-named +! \ Statistic >in @ T name, H >in ! THEN T cfalign here H tlastcfa ! - \ Symbol table + \ Old Symbol table sed-script \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! - CreateFlag @ - IF \ for a created word we need also a definition in target - \ to execute the created word while compile time - \ dont mind if a alias is defined twice - Warnings @ >r Warnings off - >in @ alias2 swap >in ! \ create alias in target - r> Warnings ! - >in @ ghost swap >in ! - swap also ghosts ' previous swap ! \ tick ghost and store in alias - CreateFlag off - ELSE ghost - THEN + ghost + \ output symbol table to extra file + [ [IFDEF] fd-symbol-table ] + base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base ! + s" :" fd-symbol-table write-file throw + dup >ghostname fd-symbol-table write-line throw + [ [THEN] ] dup Last-Header-Ghost ! dup >magic ^imm ! \ a pointer for immediate Already @ IF dup >end tdoes ! ELSE 0 tdoes ! THEN - 80 flag! + alias-mask flag! cross-doc-entry cross-tag-entry ; VARIABLE ;Resolve 1 cells allot @@ -1702,7 +1730,7 @@ VARIABLE ;Resolve 1 cells allot IF .sourcepos ." needs prim: " >in @ bl word count type >in ! cr THEN - (THeader over resolve T A, H 80 flag! ; + (THeader over resolve T A, H alias-mask flag! ; : Alias: ( cfa -- ) \ name >in @ skip? IF 2drop EXIT THEN >in ! dup 0< s" prims" T $has? H 0= and @@ -1748,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" @@ -1777,11 +1811,11 @@ Cond: ['] T ' H alit, ;Cond \ modularized 14jun97jaw : fillcfa ( usedcells -- ) - T cells H xt>body swap - 0 ?DO 0 T c, tchar H +LOOP ; + T cells H xt>body swap - 0 ?DO 0 X c, tchar +LOOP ; : (>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, @@ -1799,7 +1833,9 @@ Cond: ['] T ' H alit, ;Cond : (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit, \ if we dont produce relocatable code alit, defaults to lit, jaw -has? relocate +\ this is just for convenience, so we don't have to define alit, +\ seperately for embedded systems.... +T has? relocate H [IF] : (alit,) ( n -- ) compile lit T a, H ; ' (alit,) IS alit, [ELSE] @@ -1833,8 +1869,6 @@ Defer (end-code) ELSE true ABORT" CROSS: Stack empty" THEN ; -( Cond ) : chars tchar * ; ( Cond ) - >CROSS \ tLiteral 12dec92py @@ -1851,33 +1885,27 @@ Cond: [Char] ( "" -- ) restrict \ some special literals 27jan97jaw \ !! Known Bug: Special Literals and plug-ins work only correct -\ on 16 and 32 Bit Targets and 32 Bit Hosts! +\ on targets with char = 8 bit Cond: MAXU restrict? - tcell 1 cells u> - IF compile lit tcell 0 ?DO FF T c, H LOOP - ELSE ffffffff lit, THEN + compile lit tcell 0 ?DO FF T c, H LOOP ;Cond Cond: MINI restrict? - tcell 1 cells u> - IF compile lit bigendian - IF 80 T c, H tcell 1 ?DO 0 T c, H LOOP - ELSE tcell 1 ?DO 0 T c, H LOOP 80 T c, H - THEN - ELSE tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN + compile lit bigendian + IF 80 T c, H tcell 1 ?DO 0 T c, H LOOP + ELSE tcell 1 ?DO 0 T c, H LOOP 80 T c, H + THEN ;Cond Cond: MAXI restrict? - tcell 1 cells u> - IF compile lit bigendian - IF 7F T c, H tcell 1 ?DO FF T c, H LOOP - ELSE tcell 1 ?DO FF T c, H LOOP 7F T c, H - THEN - ELSE tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN + compile lit bigendian + IF 7F T c, H tcell 1 ?DO FF T c, H LOOP + ELSE tcell 1 ?DO FF T c, H LOOP 7F T c, H + THEN ;Cond >CROSS @@ -1950,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 @@ -1968,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 ; @@ -1981,20 +2016,15 @@ 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 - >in @ alias2 swap dup >in ! >r >r - Make-Ghost - rot swap >exec dup @ ['] NoExec <> - IF 2drop ELSE ! THEN - , - r> r> >in ! - also ghosts ' previous swap ! ; -\ DOES> dup >exec @ execute ; + Make-Ghost ( Create-xt do-ghost ghost ) + rot swap ( do-ghost Create-xt ghost ) + >exec ! , ; : gdoes, ( ghost -- ) \ makes the codefield for a word that is built @@ -2014,28 +2044,34 @@ Cond: DOES> restrict? : TCreate ( -- ) executed-ghost @ - CreateFlag on 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 - >end @ >exec @ r> >exec ! ; +\ if the word already has a semantic (concerns S", IS, .", DOES>) +\ then keep it + >end @ + dup >exec @ r@ >exec dup @ ['] NoExec = IF ! ELSE 2drop THEN + >comp @ r> >comp ! ; : RTCreate ( -- ) \ creates a new word with code-field in ram executed-ghost @ - CreateFlag on create-forward-warn IF ['] reswarn-forward IS resolve-warning THEN \ make Alias - (THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost ) + (THeader there 0 T a, H alias-mask flag! ( S executed-ghost new-ghost ) \ store poiter to code-field switchram T cfalign H there swap T ! H there tlastcfa ! dup there resolve 0 ;Resolve ! >r dup gdoes, - >end @ >exec @ r> >exec ! ; +\ stores execution semantic in the built word +\ if the word already has a semantic (concerns S", IS, .", DOES>) +\ then keep it + >end @ >exec @ r> >exec dup @ ['] NoExec = + IF ! ELSE 2drop THEN ; : Build: ( -- [xt] [colon-sys] ) :noname postpone TCreate ; @@ -2051,24 +2087,35 @@ Cond: DOES> restrict? : gdoes> ( ghost -- addr flag ) executed-ghost @ state @ IF gexecute true EXIT THEN - >link @ T >body H false ; + g>body false ; \ DO: ;DO 11may93jaw \ changed to ?EXIT 10may93jaw -: DO: ( -- addr [xt] [colon-sys] ) +: DO: ( -- ghost [xt] [colon-sys] ) here ghostheader :noname postpone gdoes> postpone ?EXIT ; -: by: ( -- addr [xt] [colon-sys] ) \ name +: by: ( -- ghost [xt] [colon-sys] ) \ name ghost :noname postpone gdoes> postpone ?EXIT ; -: ;DO ( addr [xt] [colon-sys] -- addr ) +: ;DO ( ghost [xt] [colon-sys] -- ghost ) postpone ; ( S addr xt ) over >exec ! ; immediate -: by ( -- addr ) \ Name +T has? peephole H [IF] +: compile: ( ghost -- ghost [xt] [colon-sys] ) + :noname postpone g>body ; +: ;compile ( ghost [xt] [colon-sys] -- ghost ) + 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 @ ; >TARGET @@ -2076,6 +2123,7 @@ Cond: DOES> restrict? Build: ( n -- ) ; by: :docon ( ghost -- n ) T @ H ;DO +compile: alit, compile @ ;compile Builder (Constant) Build: ( n -- ) T , H ; @@ -2092,6 +2140,7 @@ Builder 2Constant BuildSmart: ; by: :dovar ( ghost -- addr ) ;DO +\ compile: alit, ;compile Builder Create T has? rom H [IF] @@ -2101,6 +2150,7 @@ Builder Variable [ELSE] Build: T 0 , H ; by Create +\ compile: alit, ;compile Builder Variable [THEN] @@ -2111,6 +2161,7 @@ Builder 2Variable [ELSE] Build: T 0 , 0 , H ; by Create +\ compile: alit, ;compile Builder 2Variable [THEN] @@ -2121,31 +2172,37 @@ Builder AVariable [ELSE] Build: T 0 A, H ; by Create +\ compile: alit, ;compile Builder AVariable [THEN] \ User variables 04may94py >CROSS + Variable tup 0 tup ! Variable tudp 0 tudp ! + : u, ( n -- udp ) tup @ tudp @ + T ! H tudp @ dup T cell+ H tudp ! ; + : au, ( n -- udp ) tup @ tudp @ + T A! H tudp @ dup T cell+ H tudp ! ; + >TARGET -Build: T 0 u, , H ; -by: :douser ( ghost -- up-addr ) T @ H tup @ + ;DO +Build: 0 u, X , ; +by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO +compile: compile useraddr T @ , H ;compile Builder User -Build: T 0 u, , 0 u, drop H ; +Build: 0 u, X , 0 u, drop ; by User Builder 2User -Build: T 0 au, , H ; +Build: 0 au, X , ; by User Builder AUser @@ -2159,9 +2216,10 @@ Builder AValue BuildSmart: ( -- ) [T'] noop T A, H ; by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO +compile: alit, compile @ compile execute ;compile Builder Defer -BuildSmart: ( inter comp -- ) swap T immediate A, A, H ; +Build: ( inter comp -- ) swap T immediate A, A, H ; DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO Builder interpret/compile: @@ -2175,6 +2233,7 @@ Builder interpret/compile: Build: ; by: :dofield T @ H + ;DO +compile: T @ H lit, compile + ;compile Builder (Field) Build: ( align1 offset1 align size "name" -- align2 offset2 ) @@ -2189,8 +2248,13 @@ Builder Field : cell% ( n -- size align ) T 1 cells H dup ; -\ ' 2Constant Alias2 end-struct -\ 0 1 T Chars H 2Constant struct +Build: ( m v -- m' v ) dup T , cell+ H ; +DO: abort" Not in cross mode" ;DO +Builder input-method + +Build: ( m v size -- m v' ) over T , H + ; +DO: abort" Not in cross mode" ;DO +Builder input-var \ structural conditionals 17dec92py @@ -2199,15 +2263,17 @@ Builder Field : sys? ( sys -- sys ) dup 0= ?struc ; : >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; -: branchoffset ( src dest -- ) - tchar / ; \ ?? jaw +: branchoffset ( src dest -- ) - tchar / ; \ ?? jaw -: >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; +: >resolve ( sys -- ) + X here ( dup ." >" hex. ) over branchoffset swap X ! ; -: TARGET @@ -2227,29 +2293,10 @@ Builder Field Cond: BUT restrict? sys? swap ;Cond Cond: YET restrict? sys? dup ;Cond -0 [IF] >CROSS -Variable tleavings ->TARGET - -Cond: DONE ( addr -- ) restrict? tleavings @ - BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT - tleavings ! drop ;Cond ->CROSS -: (leave) T here H tleavings @ T , H tleavings ! ; ->TARGET - -Cond: LEAVE restrict? compile branch (leave) ;Cond -Cond: ?LEAVE restrict? compile 0= compile ?branch (leave) ;Cond - -[ELSE] - \ !! This is WIP - \ The problem is (?DO)! - \ perhaps we need a plug-in for (?DO) - ->CROSS Variable tleavings 0 tleavings ! + : (done) ( addr -- ) tleavings @ BEGIN dup @@ -2279,8 +2326,6 @@ Cond: DONE ( addr -- ) restrict? (don Cond: LEAVE restrict? branchmark, (leave) ;Cond Cond: ?LEAVE restrict? compile 0= ?branchmark, (leave) ;Cond -[THEN] - >CROSS \ !!JW ToDo : Move to general tools section @@ -2375,7 +2420,7 @@ Cond: defers T ' >body @ compile, H ;Con \ LINKED ERR" ENV" 2ENV" 18may93jaw \ linked list primitive -: linked T here over @ A, swap ! H ; +: linked X here over X @ X A, swap X ! ; : chained T linked A, H ; : err" s" ErrLink linked" evaluate T , H @@ -2426,9 +2471,9 @@ magic 7 + c! bl parse ." Saving to " 2dup type cr w/o bin create-file throw >r TNIL IF - s" #! " r@ write-file throw - bl parse r@ write-file throw - s" -i" r@ write-file throw + s" #! " r@ write-file throw + bl parse r@ write-file throw + s" --image-file" r@ write-file throw #lf r@ emit-file throw r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index ) ?do @@ -2615,7 +2660,7 @@ previous : 2/ 2/ ; : . . ; -: all-words ['] false IS skip? ; +: all-words ['] forced? IS skip? ; : needed-words ['] needed? IS skip? ; : undef-words ['] defined2? IS skip? ; : skipdef skipdef ; @@ -2653,15 +2698,19 @@ previous : .s .s ; : bye bye ; +\ dummy + +: group source >in ! drop ; + \ turnkey direction : H forth ; immediate : T minimal ; immediate : G ghosts ; immediate : turnkey - \GFORTH 0 set-order also Target - \ANSI [ ' target >wordlist ] Literal 1 set-order - definitions + \GFORTH 0 set-order also ghosts + \ANSI [ ' ghosts >wordlist ] Literal 1 set-order + also target definitions also Minimal also ; \ these ones are pefered: @@ -2671,7 +2720,7 @@ previous \ also minimal : [[ also unlock ; -: ]] previous previous ; +: ]] previous previous also also ; unlock definitions also minimal : lock lock ;