version 1.77, 1999/05/17 15:05:17
|
version 1.79, 1999/05/20 13:28:20
|
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 585 false DebugFlag showincludedfiles
|
Line 589 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 601 also forth definitions previous
|
|
|
: require require ; |
: require require ; |
|
|
|
[THEN] |
|
|
>CROSS |
>CROSS |
hex |
hex |
|
|
Line 638 VARIABLE GhostNames
|
Line 646 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 721 VARIABLE Already
|
Line 729 VARIABLE Already
|
s" ?!?!?!" |
s" ?!?!?!" |
THEN ; |
THEN ; |
|
|
|
: .ghost ( ghost -- ) >ghostname type ; |
|
|
\ ' >ghostname ALIAS @name |
\ ' >ghostname ALIAS @name |
|
|
: forward? ( ghost -- flag ) |
: forward? ( ghost -- flag ) |
Line 917 Variable mirrored-link \ linked
|
Line 927 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 1219 T has? relocate H
|
Line 1229 T has? relocate H
|
|
|
: 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 1368 DEFER comp[ \ ends compilation
|
Line 1378 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 1465 variable ResolveFlag
|
Line 1475 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 1489 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 1507 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 |
|
|
Line 1518 VARIABLE ^imm
|
Line 1531 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 |
Line 1600 Create tag-bof 1 c, 0C c,
|
Line 1607 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 1621 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 1644 Defer skip? ' false IS skip?
|
|
|
\ Target header creation |
\ Target header creation |
|
|
Variable CreateFlag |
|
CreateFlag off |
|
|
|
Variable NoHeaderFlag |
Variable NoHeaderFlag |
NoHeaderFlag off |
NoHeaderFlag off |
|
|
Line 1660 NoHeaderFlag off
|
Line 1669 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 |
\ Symbol table |
\ >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 |
|
\ 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 |
|
dup Last-Header-Ghost ! |
dup Last-Header-Ghost ! |
dup >magic ^imm ! \ a pointer for immediate |
dup >magic ^imm ! \ a pointer for immediate |
Already @ |
Already @ |
Line 1777 Cond: ['] T ' H alit, ;Cond
|
Line 1775 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 1833 Defer (end-code)
|
Line 1831 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 1987 Cond: DOES> restrict?
|
Line 1983 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 |
\ rot swap >exec dup @ ['] NoExec <> |
, |
\ 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 2007 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 @ >exec @ r> >exec dup @ ['] NoExec = |
|
IF ! ELSE 2drop THEN ; |
|
|
: 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 |
Line 2035 Cond: DOES> restrict?
|
Line 2029 Cond: DOES> restrict?
|
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 2127 Builder AVariable
|
Line 2125 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 |
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 2161 BuildSmart: ( -- ) [T'] noop T A, H ;
|
Line 2163 BuildSmart: ( -- ) [T'] noop T A, H ;
|
by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
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 2189 Builder Field
|
Line 2191 Builder Field
|
: cell% ( n -- size align ) |
: cell% ( n -- size align ) |
T 1 cells H dup ; |
T 1 cells H dup ; |
|
|
\ ' 2Constant Alias2 end-struct |
|
\ 0 1 T Chars H 2Constant struct |
|
|
|
\ structural conditionals 17dec92py |
\ structural conditionals 17dec92py |
|
|
>CROSS |
>CROSS |
Line 2199 Builder Field
|
Line 2198 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 2216 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 2228 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 |
>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 ! |
Variable tleavings 0 tleavings ! |
|
|
: (done) ( addr -- ) |
: (done) ( addr -- ) |
tleavings @ |
tleavings @ |
BEGIN dup |
BEGIN dup |
Line 2279 Cond: DONE ( addr -- ) restrict? (don
|
Line 2261 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 2355 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 2615 previous
|
Line 2595 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 2639 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 2651 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 ; |