version 1.77, 1999/05/17 15:05:17
|
version 1.93, 2001/03/11 21:47:27
|
Line 1
|
Line 1
|
\ CROSS.FS The Cross-Compiler 06oct92py |
\ CROSS.FS The Cross-Compiler 06oct92py |
\ Idea and implementation: Bernd Paysan (py) |
\ 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. |
\ This file is part of Gforth. |
|
|
Line 17
|
Line 17
|
|
|
\ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
\ along with this program; if not, write to the Free Software |
\ 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 |
0 |
[IF] |
[IF] |
Line 53 Vocabulary Minimal
|
Line 53 Vocabulary Minimal
|
only Forth also Target also also |
only Forth also Target also also |
definitions Forth |
definitions Forth |
|
|
: T previous Cross also Target ; immediate |
: T previous Ghosts also Target ; immediate |
: G Ghosts ; immediate |
: G Ghosts ; immediate |
: H previous Forth also Cross ; immediate |
: H previous Forth also Cross ; immediate |
|
|
forth definitions |
forth definitions |
|
|
: T previous Cross also Target ; immediate |
: T previous Ghosts also Target ; immediate |
: G Ghosts ; immediate |
: G Ghosts ; immediate |
|
|
: >cross also Cross definitions previous ; |
: >cross also Cross definitions previous ; |
Line 135 Create bases 10 , 2 , A , 100 ,
|
Line 135 Create bases 10 , 2 , A , 100 ,
|
r> ; |
r> ; |
|
|
: s>unumber? ( addr u -- ud flag ) |
: 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 |
base @ >r dpl on getbase |
0. 2swap |
0. 2swap |
BEGIN ( d addr len ) |
BEGIN ( d addr len ) |
Line 198 Create bases 10 , 2 , A , 100 ,
|
Line 202 Create bases 10 , 2 , A , 100 ,
|
[THEN] |
[THEN] |
|
|
hex \ the defualt base for the cross-compiler is hex !! |
hex \ the defualt base for the cross-compiler is hex !! |
Warnings off |
\ Warnings off |
|
|
\ words that are generaly useful |
\ words that are generaly useful |
|
|
Line 470 Create tfile 0 c, 255 chars allot
|
Line 474 Create tfile 0 c, 255 chars allot
|
THEN ; |
THEN ; |
|
|
: compact.. ( adr len -- adr2 len2 ) |
: compact.. ( adr len -- adr2 len2 ) |
\ deletes phrases like "xy/.." out of our directory name 2dec97jaw |
\ deletes phrases like "xy/.." out of our directory name 2dec97jaw |
over >r -1 >r |
over swap |
BEGIN dup WHILE |
BEGIN dup WHILE |
over c@ pathsep? |
dup >r '/ scan 2dup 4 min s" /../" compare 0= |
IF r@ -1 = |
IF |
IF r> drop dup >r |
dup r> - >r 4 /string over r> + 4 - |
ELSE 2dup 1 /string |
swap 2dup + >r move dup r> over - |
3 min s" ../" compare |
ELSE |
0= |
rdrop dup 1 min /string |
IF r@ over - ( diff ) |
THEN |
2 pick swap - ( dest-adr ) |
REPEAT drop over - ; |
>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 - ; |
|
|
|
: reworkdir ( -- ) |
: reworkdir ( -- ) |
remove~+ |
remove~+ |
Line 585 false DebugFlag showincludedfiles
|
Line 579 false DebugFlag showincludedfiles
|
|
|
: require bl word count required ; |
: require bl word count required ; |
|
|
|
0 [IF] |
|
|
also forth definitions previous |
also forth definitions previous |
|
|
: included ( adr len -- ) included ; |
: included ( adr len -- ) included ; |
Line 595 also forth definitions previous
|
Line 591 also forth definitions previous
|
|
|
: require require ; |
: require require ; |
|
|
|
[THEN] |
|
|
>CROSS |
>CROSS |
hex |
hex |
|
|
Line 638 VARIABLE GhostNames
|
Line 636 VARIABLE GhostNames
|
0 GhostNames ! |
0 GhostNames ! |
|
|
: GhostName ( -- addr ) |
: GhostName ( -- addr ) |
here GhostNames @ , GhostNames ! here 0 , |
align here GhostNames @ , GhostNames ! here 0 , |
bl word count |
bl word count |
\ 2dup type space |
\ 2dup type space |
string, \ !! cfalign ? |
string, \ !! cfalign ? |
Line 658 hex
|
Line 656 hex
|
4713 Constant <imm> 4714 Constant <do:> |
4713 Constant <imm> 4714 Constant <do:> |
4715 Constant <skip> |
4715 Constant <skip> |
|
|
\ iForth makes only immediate directly after create |
\ Compiler States |
\ make atonce trick! ? |
|
|
|
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 -- ) |
|
|
|
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 |
|
|
: GhostHeader <fwd> , 0 , ['] NoExec , ; |
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] |
|
|
|
\ ghost structure |
|
|
: >magic ; \ type of ghost |
: >magic ; \ type of ghost |
: >link cell+ ; \ pointer where ghost is in target, or if unresolved |
: >link cell+ ; \ pointer where ghost is in target, or if unresolved |
\ points to the where we have to resolve (linked-list) |
\ points to the where we have to resolve (linked-list) |
: >exec cell+ cell+ ; \ execution symantics (while target compiling) of ghost |
: >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 |
\ for builder (create, variable...) words the |
\ execution symantics of words built are placed here |
\ 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 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 |
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 <fwd> , 0 , ['] NoExec , ['] is-forward , ; |
|
|
: Make-Ghost ( "name" -- ghost ) |
: Make-Ghost ( "name" -- ghost ) |
>in @ GhostName swap >in ! |
>in @ GhostName swap >in ! |
<T Create atonce @ IF immediate atonce off THEN |
<T Create atonce @ IF immediate atonce off THEN |
Line 721 VARIABLE Already
|
Line 785 VARIABLE Already
|
s" ?!?!?!" |
s" ?!?!?!" |
THEN ; |
THEN ; |
|
|
|
: .ghost ( ghost -- ) >ghostname type ; |
|
|
\ ' >ghostname ALIAS @name |
\ ' >ghostname ALIAS @name |
|
|
: forward? ( ghost -- flag ) |
: forward? ( ghost -- flag ) |
Line 743 ghost (does>) ghost noop
|
Line 809 ghost (does>) ghost noop
|
ghost (.") ghost (S") ghost (ABORT") 2drop drop |
ghost (.") ghost (S") ghost (ABORT") 2drop drop |
ghost ' drop |
ghost ' drop |
ghost :docol ghost :doesjump ghost :dodoes 2drop 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 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 2drop drop |
ghost 2dup drop |
ghost 2dup drop |
|
|
Line 777 VARIABLE env-current \ save information
|
Line 844 VARIABLE env-current \ save information
|
|
|
>ENVIRON get-order get-current swap 1+ set-order |
>ENVIRON get-order get-current swap 1+ set-order |
true SetValue compiler |
true SetValue compiler |
true SetValue cross |
true SetValue cross |
true SetValue standard-threading |
true SetValue standard-threading |
>TARGET previous |
>TARGET previous |
|
|
Line 802 false DefaultValue dcomps
|
Line 869 false DefaultValue dcomps
|
false DefaultValue hash |
false DefaultValue hash |
false DefaultValue xconds |
false DefaultValue xconds |
false DefaultValue header |
false DefaultValue header |
|
false DefaultValue backtrace |
|
false DefaultValue new-input |
[THEN] |
[THEN] |
|
|
true DefaultValue interpreter |
true DefaultValue interpreter |
Line 854 float Constant tfloat
|
Line 923 float Constant tfloat
|
bits/byte Constant tbits/byte |
bits/byte Constant tbits/byte |
[THEN] |
[THEN] |
H |
H |
tbits/byte bits/byte / Constant tbyte |
tbits/char bits/byte / Constant tbyte |
|
|
|
|
\ Variables 06oct92py |
\ Variables 06oct92py |
Line 917 Variable mirrored-link \ linked
|
Line 986 Variable mirrored-link \ linked
|
dup >rstart @ swap >rdp @ over - ; |
dup >rstart @ swap >rdp @ over - ; |
|
|
: area ( region -- startaddr totallen ) \G returns the total area |
: 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 \G mark a region as mirrored |
mirrored-link |
mirrored-link |
Line 1170 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 1239 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
: +bit ( addr n -- ) >bit over c@ or swap c! ; |
: +bit ( addr n -- ) >bit over c@ or swap c! ; |
: -bit ( addr n -- ) >bit invert over c@ and swap c! ; |
: -bit ( addr n -- ) >bit invert over c@ and swap c! ; |
|
|
: (relon) ( taddr -- ) bit$ @ swap cell/ +bit ; |
: (relon) ( taddr -- ) |
: (reloff) ( taddr -- ) bit$ @ swap cell/ -bit ; |
[ [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 @ + ; |
: (>image) ( taddr -- absaddr ) image @ + ; |
|
|
Line 1212 T has? relocate H
|
Line 1292 T has? relocate H
|
: c@ ( taddr -- char ) >image Sc@ ; |
: c@ ( taddr -- char ) >image Sc@ ; |
: c! ( char taddr -- ) >image Sc! ; |
: c! ( char taddr -- ) >image Sc! ; |
: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; |
: 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 |
\ Target compilation primitives 06oct92py |
\ included A! 16may93jaw |
\ included A! 16may93jaw |
|
|
: here ( -- there ) there ; |
: here ( -- there ) there ; |
: allot ( n -- ) tdp +! ; |
: allot ( n -- ) tdp +! ; |
: , ( w -- ) T here H tcell T allot ! H T here drop H ; |
: , ( w -- ) T here H tcell T allot ! H ; |
: c, ( char -- ) T here tchar allot c! H ; |
: c, ( char -- ) T here H tchar T allot c! H ; |
: align ( -- ) T here H align+ 0 ?DO bl T c, tchar H +LOOP ; |
: align ( -- ) T here H align+ 0 ?DO bl T c, H tchar +LOOP ; |
: cfalign ( -- ) |
: 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 |
: >address dup 0>= IF tbyte / THEN ; \ ?? jaw |
: A! swap >address swap dup relon T ! H ; |
: A! swap >address swap dup relon T ! H ; |
Line 1255 previous
|
Line 1335 previous
|
|
|
\ \ -------------------- Compiler Plug Ins 01aug97jaw |
\ \ -------------------- 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 |
>TARGET |
DEFER >body \ we need the system >body |
DEFER >body \ we need the system >body |
\ and the target >body |
\ and the target >body |
Line 1329 DEFER comp[ \ ends compilation
|
Line 1370 DEFER comp[ \ ends compilation
|
: compile, colon, ; |
: compile, colon, ; |
>CROSS |
>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 -- ) |
: refered ( ghost tag -- ) |
\G creates a resolve structure |
\G creates a resolve structure |
T here aligned H swap (refered) |
T here aligned H swap (refered) |
Line 1368 DEFER comp[ \ ends compilation
|
Line 1390 DEFER comp[ \ ends compilation
|
Defer resolve-warning |
Defer resolve-warning |
|
|
: reswarn-test ( ghost res-struct -- ghost res-struct ) |
: 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 ) |
: reswarn-forward ( ghost res-struct -- ghost res-struct ) |
over warnhead >ghostname type dup ." is referenced in " |
over warnhead .ghost dup ." is referenced in " |
>ghost @ >ghostname type ; |
>ghost @ .ghost ; |
|
|
\ ' reswarn-test IS resolve-warning |
\ ' reswarn-test IS resolve-warning |
|
|
Line 1417 Exists-Warnings on
|
Line 1439 Exists-Warnings on
|
ELSE true abort" CROSS: Ghostnames inconsistent " |
ELSE true abort" CROSS: Ghostnames inconsistent " |
THEN ; |
THEN ; |
|
|
|
: is-resolved ( ghost -- ) |
|
>link @ colon, ; \ compile-call |
|
|
: resolve ( ghost tcfa -- ) |
: resolve ( ghost tcfa -- ) |
\G resolve referencies to ghost with tcfa |
\G resolve referencies to ghost with tcfa |
\ is ghost resolved?, second resolve means another definition with the |
\ is ghost resolved?, second resolve means another definition with the |
Line 1426 Exists-Warnings on
|
Line 1451 Exists-Warnings on
|
swap >r r@ >link @ swap \ ( list tcfa R: ghost ) |
swap >r r@ >link @ swap \ ( list tcfa R: ghost ) |
\ mark ghost as resolved |
\ mark ghost as resolved |
dup r@ >link ! <res> r@ >magic ! |
dup r@ >link ! <res> r@ >magic ! |
|
r@ >comp @ ['] is-forward = IF ['] is-resolved r@ >comp ! THEN |
\ loop through forward referencies |
\ loop through forward referencies |
r> -rot |
r> -rot |
comp-state @ >r Resolving comp-state ! |
comp-state @ >r Resolving comp-state ! |
Line 1437 Exists-Warnings on
|
Line 1463 Exists-Warnings on
|
|
|
\ gexecute ghost, 01nov92py |
\ gexecute ghost, 01nov92py |
|
|
: is-forward ( ghost -- ) |
|
colonmark, 0 (refered) ; \ compile space for call |
|
|
|
: is-resolved ( ghost -- ) |
|
>link @ colon, ; \ compile-call |
|
|
|
: gexecute ( ghost -- ) |
: gexecute ( ghost -- ) |
dup @ <fwd> = IF is-forward ELSE is-resolved THEN ; |
dup >comp @ execute ; |
|
|
: addr, ( ghost -- ) |
: addr, ( ghost -- ) |
dup @ <fwd> = 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 ; |
\ !! : ghost, ghost gexecute ; |
|
|
Line 1465 variable ResolveFlag
|
Line 1485 variable ResolveFlag
|
>link |
>link |
BEGIN @ dup |
BEGIN @ dup |
WHILE cr 5 spaces |
WHILE cr 5 spaces |
dup >ghost @ >ghostname type |
dup >ghost @ .ghost |
." file " dup >file @ ?dup IF count type ELSE ." CON" THEN |
." file " dup >file @ ?dup IF count type ELSE ." CON" THEN |
." line " dup >line @ .dec |
." line " dup >line @ .dec |
REPEAT |
REPEAT |
Line 1479 variable ResolveFlag
|
Line 1499 variable ResolveFlag
|
ELSE drop |
ELSE drop |
THEN ; |
THEN ; |
|
|
>MINIMAL |
|
: .unresolved ( -- ) |
: .unresolved ( -- ) |
ResolveFlag off cr ." Unresolved: " |
ResolveFlag off cr ." Unresolved: " |
Ghostnames |
Ghostnames |
Line 1498 variable ResolveFlag
|
Line 1517 variable ResolveFlag
|
cr ." named Headers: " headers-named @ . |
cr ." named Headers: " headers-named @ . |
r> base ! ; |
r> base ! ; |
|
|
|
>MINIMAL |
|
|
|
: .unresolved .unresolved ; |
|
|
>CROSS |
>CROSS |
\ Header states 12dec92py |
\ 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 |
VARIABLE ^imm |
|
|
|
\ !! should be target wordsize specific |
|
$80 constant alias-mask |
|
$40 constant immediate-mask |
|
$20 constant restrict-mask |
|
|
>TARGET |
>TARGET |
: immediate 40 flag! |
: immediate immediate-mask flag! |
^imm @ @ dup <imm> = IF drop EXIT THEN |
^imm @ @ dup <imm> = IF drop EXIT THEN |
<res> <> ABORT" CROSS: Cannot immediate a unresolved word" |
<res> <> ABORT" CROSS: Cannot immediate a unresolved word" |
<imm> ^imm @ ! ; |
<imm> ^imm @ ! ; |
: restrict 20 flag! ; |
: restrict restrict-mask flag! ; |
|
|
: isdoer |
: isdoer |
\G define a forth word as doer, this makes obviously only sence on |
\G define a forth word as doer, this makes obviously only sence on |
Line 1518 VARIABLE ^imm
|
Line 1547 VARIABLE ^imm
|
<do:> last-header-ghost @ >magic ! ; |
<do:> last-header-ghost @ >magic ! ; |
>CROSS |
>CROSS |
|
|
\ ALIAS2 ansforth conform alias 9may93jaw |
|
|
|
: ALIAS2 create here 0 , DOES> @ execute ; |
|
\ usage: |
|
\ ' <name> alias2 bla ! |
|
|
|
\ Target Header Creation 01nov92py |
\ Target Header Creation 01nov92py |
|
|
>TARGET |
>TARGET |
: string, ( addr count -- ) |
: string, ( addr count -- ) |
dup T c, H bounds ?DO I c@ T c, H LOOP ; |
dup T c, H bounds ?DO I c@ T c, H LOOP ; |
: name, ( "name" -- ) bl word count T string, cfalign H ; |
: 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 ) ; |
: view, ( -- ) ( dummy ) ; |
>CROSS |
>CROSS |
|
|
Line 1600 Create tag-bof 1 c, 0C c,
|
Line 1625 Create tag-bof 1 c, 0C c,
|
Defer skip? ' false IS skip? |
Defer skip? ' false IS skip? |
|
|
: skipdef ( <name> -- ) |
: skipdef ( <name> -- ) |
\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? |
ghost dup forward? |
IF >magic <skip> swap ! |
IF >magic <skip> swap ! |
ELSE drop THEN ; |
ELSE drop THEN ; |
Line 1613 Defer skip? ' false IS skip?
|
Line 1639 Defer skip? ' false IS skip?
|
\G that's what we want |
\G that's what we want |
ghost forward? 0= ; |
ghost forward? 0= ; |
|
|
|
: forced? ( -- flag ) \ name |
|
\G return ture if it is a foreced skip with defskip |
|
ghost >magic @ <skip> = ; |
|
|
: needed? ( -- flag ) \ name |
: needed? ( -- flag ) \ name |
\G returns a false flag when |
\G returns a false flag when |
\G a word is not defined |
\G a word is not defined |
Line 1632 Defer skip? ' false IS skip?
|
Line 1662 Defer skip? ' false IS skip?
|
|
|
\ Target header creation |
\ Target header creation |
|
|
Variable CreateFlag |
|
CreateFlag off |
|
|
|
Variable NoHeaderFlag |
Variable NoHeaderFlag |
NoHeaderFlag off |
NoHeaderFlag off |
|
|
Line 1642 NoHeaderFlag off
|
Line 1669 NoHeaderFlag off
|
base @ >r hex |
base @ >r hex |
0 swap <# 0 ?DO # LOOP #> type |
0 swap <# 0 ?DO # LOOP #> type |
r> base ! ; |
r> base ! ; |
: .sym |
|
|
: .sym ( adr len -- ) |
|
\G escapes / and \ to produce sed output |
bounds |
bounds |
DO I c@ dup |
DO I c@ dup |
CASE [char] / OF drop ." \/" ENDOF |
CASE [char] / OF drop ." \/" ENDOF |
Line 1660 NoHeaderFlag off
|
Line 1689 NoHeaderFlag off
|
IF NoHeaderFlag off |
IF NoHeaderFlag off |
ELSE |
ELSE |
T align H view, |
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 |
1 headers-named +! \ Statistic |
>in @ T name, H >in ! |
>in @ T name, H >in ! |
THEN |
THEN |
T cfalign here H tlastcfa ! |
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 ! |
\ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! |
CreateFlag @ |
ghost |
IF \ for a created word we need also a definition in target |
\ output symbol table to extra file |
\ to execute the created word while compile time |
[ [IFDEF] fd-symbol-table ] |
\ dont mind if a alias is defined twice |
base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base ! |
Warnings @ >r Warnings off |
s" :" fd-symbol-table write-file throw |
>in @ alias2 swap >in ! \ create alias in target |
dup >ghostname fd-symbol-table write-line throw |
r> Warnings ! |
[ [THEN] ] |
>in @ ghost swap >in ! |
|
swap also ghosts ' previous swap ! \ tick ghost and store in alias |
|
CreateFlag off |
|
ELSE ghost |
|
THEN |
|
dup Last-Header-Ghost ! |
dup Last-Header-Ghost ! |
dup >magic ^imm ! \ a pointer for immediate |
dup >magic ^imm ! \ a pointer for immediate |
Already @ |
Already @ |
IF dup >end tdoes ! |
IF dup >end tdoes ! |
ELSE 0 tdoes ! |
ELSE 0 tdoes ! |
THEN |
THEN |
80 flag! |
alias-mask flag! |
cross-doc-entry cross-tag-entry ; |
cross-doc-entry cross-tag-entry ; |
|
|
VARIABLE ;Resolve 1 cells allot |
VARIABLE ;Resolve 1 cells allot |
Line 1702 VARIABLE ;Resolve 1 cells allot
|
Line 1726 VARIABLE ;Resolve 1 cells allot
|
IF |
IF |
.sourcepos ." needs prim: " >in @ bl word count type >in ! cr |
.sourcepos ." needs prim: " >in @ bl word count type >in ! cr |
THEN |
THEN |
(THeader over resolve T A, H 80 flag! ; |
(THeader over resolve T A, H alias-mask flag! ; |
: Alias: ( cfa -- ) \ name |
: Alias: ( cfa -- ) \ name |
>in @ skip? IF 2drop EXIT THEN >in ! |
>in @ skip? IF 2drop EXIT THEN >in ! |
dup 0< s" prims" T $has? H 0= and |
dup 0< s" prims" T $has? H 0= and |
Line 1777 Cond: ['] T ' H alit, ;Cond
|
Line 1801 Cond: ['] T ' H alit, ;Cond
|
\ modularized 14jun97jaw |
\ modularized 14jun97jaw |
|
|
: fillcfa ( usedcells -- ) |
: 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 |
: (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H |
|
|
Line 1799 Cond: ['] T ' H alit, ;Cond
|
Line 1823 Cond: ['] T ' H alit, ;Cond
|
: (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit, |
: (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit, |
|
|
\ if we dont produce relocatable code alit, defaults to lit, jaw |
\ 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] |
[IF] |
: (alit,) ( n -- ) compile lit T a, H ; ' (alit,) IS alit, |
: (alit,) ( n -- ) compile lit T a, H ; ' (alit,) IS alit, |
[ELSE] |
[ELSE] |
Line 1833 Defer (end-code)
|
Line 1859 Defer (end-code)
|
ELSE true ABORT" CROSS: Stack empty" THEN |
ELSE true ABORT" CROSS: Stack empty" THEN |
; |
; |
|
|
( Cond ) : chars tchar * ; ( Cond ) |
|
|
|
>CROSS |
>CROSS |
|
|
\ tLiteral 12dec92py |
\ tLiteral 12dec92py |
Line 1851 Cond: [Char] ( "<char>" -- ) restrict
|
Line 1875 Cond: [Char] ( "<char>" -- ) restrict
|
\ some special literals 27jan97jaw |
\ some special literals 27jan97jaw |
|
|
\ !! Known Bug: Special Literals and plug-ins work only correct |
\ !! 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 |
Cond: MAXU |
restrict? |
restrict? |
tcell 1 cells u> |
compile lit tcell 0 ?DO FF T c, H LOOP |
IF compile lit tcell 0 ?DO FF T c, H LOOP |
|
ELSE ffffffff lit, THEN |
|
;Cond |
;Cond |
|
|
Cond: MINI |
Cond: MINI |
restrict? |
restrict? |
tcell 1 cells u> |
compile lit bigendian |
IF compile lit bigendian |
IF 80 T c, H tcell 1 ?DO 0 T c, H LOOP |
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 |
ELSE tcell 1 ?DO 0 T c, H LOOP 80 T c, H |
THEN |
THEN |
|
ELSE tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN |
|
;Cond |
;Cond |
|
|
Cond: MAXI |
Cond: MAXI |
restrict? |
restrict? |
tcell 1 cells u> |
compile lit bigendian |
IF compile lit bigendian |
IF 7F T c, H tcell 1 ?DO FF T c, H LOOP |
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 |
ELSE tcell 1 ?DO FF T c, H LOOP 7F T c, H |
THEN |
THEN |
|
ELSE tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN |
|
;Cond |
;Cond |
|
|
>CROSS |
>CROSS |
Line 1987 Cond: DOES> restrict?
|
Line 2005 Cond: DOES> restrict?
|
\ do:-xt is executet when the created word from builder is executed |
\ 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 |
\ for do:-xt an additional entry after the normal ghost-enrys is used |
|
|
>in @ alias2 swap dup >in ! >r >r |
Make-Ghost ( Create-xt do:-xt ghost ) |
Make-Ghost |
rot swap ( do:-xt Create-xt ghost ) |
rot swap >exec dup @ ['] NoExec <> |
>exec ! , ; |
IF 2drop ELSE ! THEN |
|
, |
|
r> r> >in ! |
|
also ghosts ' previous swap ! ; |
|
\ DOES> dup >exec @ execute ; |
|
|
|
: gdoes, ( ghost -- ) |
: gdoes, ( ghost -- ) |
\ makes the codefield for a word that is built |
\ makes the codefield for a word that is built |
Line 2014 Cond: DOES> restrict?
|
Line 2027 Cond: DOES> restrict?
|
|
|
: TCreate ( <name> -- ) |
: TCreate ( <name> -- ) |
executed-ghost @ |
executed-ghost @ |
CreateFlag on |
|
create-forward-warn |
create-forward-warn |
IF ['] reswarn-forward IS resolve-warning THEN |
IF ['] reswarn-forward IS resolve-warning THEN |
Theader >r dup gdoes, |
Theader >r dup gdoes, |
\ stores execution semantic in the built word |
\ 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 ( <name> -- ) |
: RTCreate ( <name> -- ) |
\ creates a new word with code-field in ram |
\ creates a new word with code-field in ram |
executed-ghost @ |
executed-ghost @ |
CreateFlag on |
|
create-forward-warn |
create-forward-warn |
IF ['] reswarn-forward IS resolve-warning THEN |
IF ['] reswarn-forward IS resolve-warning THEN |
\ make Alias |
\ 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 |
\ store poiter to code-field |
switchram T cfalign H |
switchram T cfalign H |
there swap T ! H |
there swap T ! H |
there tlastcfa ! |
there tlastcfa ! |
dup there resolve 0 ;Resolve ! |
dup there resolve 0 ;Resolve ! |
>r dup gdoes, |
>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] ) |
: Build: ( -- [xt] [colon-sys] ) |
:noname postpone TCreate ; |
:noname postpone TCreate ; |
Line 2048 Cond: DOES> restrict?
|
Line 2067 Cond: DOES> restrict?
|
postpone TCreate |
postpone TCreate |
[ [THEN] ] ; |
[ [THEN] ] ; |
|
|
|
: g>body ( ghost -- body ) |
|
>link @ T >body H ; |
: gdoes> ( ghost -- addr flag ) |
: gdoes> ( ghost -- addr flag ) |
executed-ghost @ |
executed-ghost @ |
state @ IF gexecute true EXIT THEN |
state @ IF gexecute true EXIT THEN |
>link @ T >body H false ; |
g>body false ; |
|
|
\ DO: ;DO 11may93jaw |
\ DO: ;DO 11may93jaw |
\ changed to ?EXIT 10may93jaw |
\ changed to ?EXIT 10may93jaw |
|
|
: DO: ( -- addr [xt] [colon-sys] ) |
: DO: ( -- ghost [xt] [colon-sys] ) |
here ghostheader |
here ghostheader |
:noname postpone gdoes> postpone ?EXIT ; |
:noname postpone gdoes> postpone ?EXIT ; |
|
|
: by: ( -- addr [xt] [colon-sys] ) \ name |
: by: ( -- ghost [xt] [colon-sys] ) \ name |
ghost |
ghost |
:noname postpone gdoes> postpone ?EXIT ; |
:noname postpone gdoes> postpone ?EXIT ; |
|
|
: ;DO ( addr [xt] [colon-sys] -- addr ) |
: ;DO ( ghost [xt] [colon-sys] -- ghost ) |
postpone ; ( S addr xt ) |
postpone ; ( S addr xt ) |
over >exec ! ; immediate |
over >exec ! ; immediate |
|
|
: by ( -- addr ) \ Name |
: compile: ( ghost -- ghost [xt] [colon-sys] ) |
|
:noname postpone g>body ; |
|
: ;compile ( ghost [xt] [colon-sys] -- ghost ) |
|
postpone ; over >comp ! ; |
|
|
|
: by ( -- ghost ) \ Name |
ghost >end @ ; |
ghost >end @ ; |
|
|
>TARGET |
>TARGET |
Line 2076 Cond: DOES> restrict?
|
Line 2102 Cond: DOES> restrict?
|
|
|
Build: ( n -- ) ; |
Build: ( n -- ) ; |
by: :docon ( ghost -- n ) T @ H ;DO |
by: :docon ( ghost -- n ) T @ H ;DO |
|
\ compile: alit, compile @ ;compile |
Builder (Constant) |
Builder (Constant) |
|
|
Build: ( n -- ) T , H ; |
Build: ( n -- ) T , H ; |
Line 2092 Builder 2Constant
|
Line 2119 Builder 2Constant
|
|
|
BuildSmart: ; |
BuildSmart: ; |
by: :dovar ( ghost -- addr ) ;DO |
by: :dovar ( ghost -- addr ) ;DO |
|
\ compile: alit, ;compile |
Builder Create |
Builder Create |
|
|
T has? rom H [IF] |
T has? rom H [IF] |
Line 2127 Builder AVariable
|
Line 2155 Builder AVariable
|
\ User variables 04may94py |
\ User variables 04may94py |
|
|
>CROSS |
>CROSS |
|
|
Variable tup 0 tup ! |
Variable tup 0 tup ! |
Variable tudp 0 tudp ! |
Variable tudp 0 tudp ! |
|
|
: u, ( n -- udp ) |
: u, ( n -- udp ) |
tup @ tudp @ + T ! H |
tup @ tudp @ + T ! H |
tudp @ dup T cell+ H tudp ! ; |
tudp @ dup T cell+ H tudp ! ; |
|
|
: au, ( n -- udp ) |
: au, ( n -- udp ) |
tup @ tudp @ + T A! H |
tup @ tudp @ + T A! H |
tudp @ dup T cell+ H tudp ! ; |
tudp @ dup T cell+ H tudp ! ; |
|
|
>TARGET |
>TARGET |
|
|
Build: T 0 u, , H ; |
Build: 0 u, X , ; |
by: :douser ( ghost -- up-addr ) T @ H tup @ + ;DO |
by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO |
|
\ compile: compile useraddr @ , ;compile |
Builder User |
Builder User |
|
|
Build: T 0 u, , 0 u, drop H ; |
Build: 0 u, X , 0 u, drop ; |
by User |
by User |
Builder 2User |
Builder 2User |
|
|
Build: T 0 au, , H ; |
Build: 0 au, X , ; |
by User |
by User |
Builder AUser |
Builder AUser |
|
|
Line 2159 Builder AValue
|
Line 2192 Builder AValue
|
|
|
BuildSmart: ( -- ) [T'] noop T A, H ; |
BuildSmart: ( -- ) [T'] noop T A, H ; |
by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
|
\ compile: alit, compile @ compile execute ;compile |
Builder Defer |
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 |
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
Builder interpret/compile: |
Builder interpret/compile: |
|
|
Line 2175 Builder interpret/compile:
|
Line 2209 Builder interpret/compile:
|
|
|
Build: ; |
Build: ; |
by: :dofield T @ H + ;DO |
by: :dofield T @ H + ;DO |
|
\ compile: T @ H lit, compile + ;compile |
Builder (Field) |
Builder (Field) |
|
|
Build: ( align1 offset1 align size "name" -- align2 offset2 ) |
Build: ( align1 offset1 align size "name" -- align2 offset2 ) |
Line 2189 Builder Field
|
Line 2224 Builder Field
|
: cell% ( n -- size align ) |
: cell% ( n -- size align ) |
T 1 cells H dup ; |
T 1 cells H dup ; |
|
|
\ ' 2Constant Alias2 end-struct |
Build: ( m v -- m' v ) dup T , cell+ H ; |
\ 0 1 T Chars H 2Constant struct |
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 |
\ structural conditionals 17dec92py |
|
|
Line 2199 Builder Field
|
Line 2239 Builder Field
|
: sys? ( sys -- sys ) dup 0= ?struc ; |
: sys? ( sys -- sys ) dup 0= ?struc ; |
: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; |
: >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 ! ; |
|
|
: <resolve ( sys -- ) T here ( dup ." <" hex. ) branchoffset , H ; |
: <resolve ( sys -- ) |
|
X here ( dup ." <" hex. ) branchoffset X , ; |
|
|
:noname compile branch T here branchoffset , H ; |
:noname compile branch X here branchoffset X , ; |
IS branch, ( target-addr -- ) |
IS branch, ( target-addr -- ) |
:noname compile ?branch T here branchoffset , H ; |
:noname compile ?branch X here branchoffset X , ; |
IS ?branch, ( target-addr -- ) |
IS ?branch, ( target-addr -- ) |
:noname compile branch T here 0 , H ; |
:noname compile branch T here 0 , H ; |
IS branchmark, ( -- branchtoken ) |
IS branchmark, ( -- branchtoken ) |
Line 2215 Builder Field
|
Line 2257 Builder Field
|
IS ?branchmark, ( -- branchtoken ) |
IS ?branchmark, ( -- branchtoken ) |
:noname T here 0 , H ; |
:noname T here 0 , H ; |
IS ?domark, ( -- branchtoken ) |
IS ?domark, ( -- branchtoken ) |
:noname dup T @ H ?struc T here over branchoffset swap ! H ; |
:noname dup X @ ?struc X here over branchoffset swap X ! ; |
IS branchtoresolve, ( branchtoken -- ) |
IS branchtoresolve, ( branchtoken -- ) |
:noname branchto, T here H ; |
:noname branchto, X here ; |
IS branchtomark, ( -- target-addr ) |
IS branchtomark, ( -- target-addr ) |
|
|
>TARGET |
>TARGET |
Line 2227 Builder Field
|
Line 2269 Builder Field
|
Cond: BUT restrict? sys? swap ;Cond |
Cond: BUT restrict? sys? swap ;Cond |
Cond: YET restrict? sys? dup ;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 |
>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 ! |
Variable tleavings 0 tleavings ! |
|
|
: (done) ( addr -- ) |
: (done) ( addr -- ) |
tleavings @ |
tleavings @ |
BEGIN dup |
BEGIN dup |
Line 2279 Cond: DONE ( addr -- ) restrict? (don
|
Line 2302 Cond: DONE ( addr -- ) restrict? (don
|
Cond: LEAVE restrict? branchmark, (leave) ;Cond |
Cond: LEAVE restrict? branchmark, (leave) ;Cond |
Cond: ?LEAVE restrict? compile 0= ?branchmark, (leave) ;Cond |
Cond: ?LEAVE restrict? compile 0= ?branchmark, (leave) ;Cond |
|
|
[THEN] |
|
|
|
>CROSS |
>CROSS |
\ !!JW ToDo : Move to general tools section |
\ !!JW ToDo : Move to general tools section |
|
|
Line 2375 Cond: defers T ' >body @ compile, H ;Con
|
Line 2396 Cond: defers T ' >body @ compile, H ;Con
|
\ LINKED ERR" ENV" 2ENV" 18may93jaw |
\ LINKED ERR" ENV" 2ENV" 18may93jaw |
|
|
\ linked list primitive |
\ linked list primitive |
: linked T here over @ A, swap ! H ; |
: linked X here over X @ X A, swap X ! ; |
: chained T linked A, H ; |
: chained T linked A, H ; |
|
|
: err" s" ErrLink linked" evaluate T , H |
: err" s" ErrLink linked" evaluate T , H |
Line 2426 magic 7 + c!
|
Line 2447 magic 7 + c!
|
bl parse ." Saving to " 2dup type cr |
bl parse ." Saving to " 2dup type cr |
w/o bin create-file throw >r |
w/o bin create-file throw >r |
TNIL IF |
TNIL IF |
s" #! " r@ write-file throw |
s" #! " r@ write-file throw |
bl parse r@ write-file throw |
bl parse r@ write-file throw |
s" -i" r@ write-file throw |
s" --image-file" r@ write-file throw |
#lf r@ emit-file throw |
#lf r@ emit-file throw |
r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index ) |
r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index ) |
?do |
?do |
Line 2615 previous
|
Line 2636 previous
|
: 2/ 2/ ; |
: 2/ 2/ ; |
: . . ; |
: . . ; |
|
|
: all-words ['] false IS skip? ; |
: all-words ['] forced? IS skip? ; |
: needed-words ['] needed? IS skip? ; |
: needed-words ['] needed? IS skip? ; |
: undef-words ['] defined2? IS skip? ; |
: undef-words ['] defined2? IS skip? ; |
: skipdef skipdef ; |
: skipdef skipdef ; |
Line 2659 previous
|
Line 2680 previous
|
: G ghosts ; immediate |
: G ghosts ; immediate |
|
|
: turnkey |
: turnkey |
\GFORTH 0 set-order also Target |
\GFORTH 0 set-order also ghosts |
\ANSI [ ' target >wordlist ] Literal 1 set-order |
\ANSI [ ' ghosts >wordlist ] Literal 1 set-order |
definitions |
also target definitions |
also Minimal also ; |
also Minimal also ; |
|
|
\ these ones are pefered: |
\ these ones are pefered: |
Line 2671 previous
|
Line 2692 previous
|
|
|
\ also minimal |
\ also minimal |
: [[ also unlock ; |
: [[ also unlock ; |
: ]] previous previous ; |
: ]] previous previous also also ; |
|
|
unlock definitions also minimal |
unlock definitions also minimal |
: lock lock ; |
: lock lock ; |