version 1.105, 2001/09/05 09:42:38
|
version 1.107, 2001/09/05 11:01:27
|
Line 23
|
Line 23
|
[IF] |
[IF] |
|
|
ToDo: |
ToDo: |
Crossdoc destination ./doc/crossdoc.fd makes no sense when |
- Crossdoc destination ./doc/crossdoc.fd makes no sense when |
cross.fs is uses seperately. jaw |
cross.fs is used seperately. jaw |
Do we need this char translation with >address and in branchoffset? |
- Do we need this char translation with >address and in branchoffset? |
(>body also affected) jaw |
(>body also affected) jaw |
Clean up mark> and >resolve stuff jaw |
- MAXU etc. can be done with dlit, |
|
|
[THEN] |
[THEN] |
|
|
Line 690 Variable ppi-temp 0 ppi-temp !
|
Line 690 Variable ppi-temp 0 ppi-temp !
|
POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate |
POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate |
|
|
|
|
|
Plugin dlit, ( d -- ) \ compile numerical value the target |
Plugin lit, ( n -- ) |
Plugin lit, ( n -- ) |
Plugin alit, ( n -- ) |
Plugin alit, ( n -- ) |
|
|
Line 801 Struct
|
Line 802 Struct
|
\ points to the where we have to resolve (linked-list) |
\ points to the where we have to resolve (linked-list) |
cell% field >link |
cell% field >link |
|
|
\ execution symantics (while target compiling) of ghost |
\ execution semantics (while target compiling) of ghost |
cell% field >exec |
cell% field >exec |
|
|
|
\ compilation action of this ghost; this is what is |
|
\ done to compile a call (or whatever) to this definition. |
|
\ E.g. >comp contains the semantic of postpone s" |
|
\ whereas >exec-compile contains the semantic of s" |
cell% field >comp |
cell% field >comp |
|
|
|
\ Compilation sematics (while parsing) of this ghost. E.g. |
|
\ "\" will skip the rest of line. |
|
\ These semantics are defined by Cond: and |
|
\ if a word is made immediate in instant, then the >exec2 field |
|
\ gets copied to here |
cell% field >exec-compile |
cell% field >exec-compile |
|
|
|
\ Additional execution semantics of this ghost. This is used |
|
\ for code generated by instant and for the doer-xt of created |
|
\ words |
cell% field >exec2 |
cell% field >exec2 |
|
|
cell% field >created |
cell% field >created |
Line 865 Variable cross-space-dp-orig
|
Line 878 Variable cross-space-dp-orig
|
cross-space-end u> ABORT" CROSS: cross-space overflow" |
cross-space-end u> ABORT" CROSS: cross-space overflow" |
cross-space-dp-orig @ dp ! ; |
cross-space-dp-orig @ dp ! ; |
|
|
|
\ this is just for debugging, to see this in the backtrace |
: execute-exec execute ; |
: execute-exec execute ; |
: execute-exec2 execute ; |
: execute-exec2 execute ; |
: execute-exec-compile execute ; |
: execute-exec-compile execute ; |
Line 1443 variable constflag constflag off
|
Line 1457 variable constflag constflag off
|
|
|
bigendian |
bigendian |
[IF] |
[IF] |
: S! ( n addr -- ) >r s>d r> tcell bounds swap 1- |
: DS! ( d addr -- ) tcell bounds swap 1- |
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; |
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; |
: S@ ( addr -- n ) >r 0 0 r> tcell bounds |
: DS@ ( addr -- d ) >r 0 0 r> tcell bounds |
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; |
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP ; |
: Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1- |
: Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1- |
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; |
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; |
: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds |
: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds |
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; |
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; |
[ELSE] |
[ELSE] |
: S! ( n addr -- ) >r s>d r> tcell bounds |
: DS! ( d addr -- ) tcell bounds |
DO maxbyte ud/mod rot I c! LOOP 2drop ; |
DO maxbyte ud/mod rot I c! LOOP 2drop ; |
: S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1- |
: DS@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1- |
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; |
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP ; |
: Sc! ( n addr -- ) >r s>d r> tchar bounds |
: Sc! ( n addr -- ) >r s>d r> tchar bounds |
DO maxbyte ud/mod rot I c! LOOP 2drop ; |
DO maxbyte ud/mod rot I c! LOOP 2drop ; |
: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1- |
: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1- |
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; |
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; |
[THEN] |
[THEN] |
|
|
|
: S! ( n addr -- ) >r s>d r> DS! ; |
|
: S@ ( addr -- n ) DS@ d>s ; |
|
|
: taddr>region ( taddr -- region | 0 ) |
: taddr>region ( taddr -- region | 0 ) |
\G finds for a target-address the correct region |
\G finds for a target-address the correct region |
\G returns 0 if taddr is not in range of a target memory region |
\G returns 0 if taddr is not in range of a target memory region |
Line 1596 T has? relocate H
|
Line 1613 T has? relocate H
|
: A, ( w -- ) >address T here H relon T , H ; |
: A, ( w -- ) >address T here H relon T , H ; |
|
|
|
|
>CROSS |
|
|
|
: tcmove ( source dest len -- ) |
|
\G cmove in target memory |
|
tchar * bounds |
|
?DO dup T c@ H I T c! H 1+ |
|
tchar +LOOP drop ; |
|
|
|
|
|
\ \ Load Assembler |
|
|
|
>TARGET |
|
H also Forth definitions |
|
|
|
\ FIXME: should we include the assembler really in the forth |
|
\ dictionary?!?!?!? This conflicts with the existing assembler |
|
\ of the host forth system!! |
|
[IFDEF] asm-include asm-include [THEN] hex |
|
|
|
previous |
|
|
|
\ \ -------------------- Host/Target copy etc. 29aug01jaw |
\ \ -------------------- Host/Target copy etc. 29aug01jaw |
|
|
|
|
>CROSS |
>CROSS |
|
|
|
: TD! >image DS! ; |
|
: TD@ >image DS@ ; |
|
|
: th-count ( taddr -- host-addr len ) |
: th-count ( taddr -- host-addr len ) |
\G returns host address of target string |
\G returns host address of target string |
assert1( tbyte 1 = ) |
assert1( tbyte 1 = ) |
Line 1645 previous
|
Line 1644 previous
|
: on T -1 swap ! H ; |
: on T -1 swap ! H ; |
: off T 0 swap ! H ; |
: off T 0 swap ! H ; |
|
|
|
: tcmove ( source dest len -- ) |
|
\G cmove in target memory |
|
tchar * bounds |
|
?DO dup T c@ H I T c! H 1+ |
|
tchar +LOOP drop ; |
|
|
|
: td, ( d -- ) |
|
\G Store a host value as one cell into the target |
|
there tcell X allot TD! ; |
|
|
|
\ \ Load Assembler |
|
|
|
>TARGET |
|
H also Forth definitions |
|
|
|
\ FIXME: should we include the assembler really in the forth |
|
\ dictionary?!?!?!? This conflicts with the existing assembler |
|
\ of the host forth system!! |
|
[IFDEF] asm-include asm-include [THEN] hex |
|
|
|
previous |
|
|
|
|
>CROSS |
>CROSS |
|
|
: (cc) T a, H ; ' (cc) plugin-of colon, |
: (cc) T a, H ; ' (cc) plugin-of colon, |
Line 1666 previous
|
Line 1688 previous
|
|
|
>TARGET |
>TARGET |
: compile, ( xt -- ) |
: compile, ( xt -- ) |
dup xt>ghost >ghost-flags <primitive> get-flag |
dup xt>ghost >comp @ EXECUTE ; |
IF prim, ELSE colon, THEN ; |
|
>CROSS |
>CROSS |
|
|
\ resolve structure |
\ resolve structure |
Line 2183 Cond: ['] T ' H alit, ;Cond
|
Line 2204 Cond: ['] T ' H alit, ;Cond
|
\ \ threading modell 13dec92py |
\ \ threading modell 13dec92py |
\ modularized 14jun97jaw |
\ modularized 14jun97jaw |
|
|
T 2 cells H .s Value xt>body |
T 2 cells H Value xt>body |
|
|
: (>body) ( cfa -- pfa ) |
: (>body) ( cfa -- pfa ) |
xt>body + ; ' (>body) plugin-of t>body |
xt>body + ; ' (>body) plugin-of t>body |
|
|
: fillcfa ( usedcells -- ) |
: fillcfa ( usedcells -- ) |
T cells H xt>body swap - dup . |
T cells H xt>body swap - |
assert1( dup 0 >= ) |
assert1( dup 0 >= ) |
0 ?DO 0 X c, tchar +LOOP ; |
0 ?DO 0 X c, tchar +LOOP ; |
|
|
Line 2212 T 2 cells H .s Value xt>body
|
Line 2233 T 2 cells H .s Value xt>body
|
[ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ] |
[ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ] |
2 fillcfa ; ' (dodoes,) plugin-of dodoes, |
2 fillcfa ; ' (dodoes,) plugin-of dodoes, |
|
|
: (lit,) ( n -- ) compile lit T , H ; ' (lit,) plugin-of lit, |
: (dlit,) ( n -- ) compile lit td, ; ' (dlit,) plugin-of dlit, |
|
|
|
: (lit,) ( n -- ) s>d dlit, ; ' (lit,) plugin-of lit, |
|
|
\ if we dont produce relocatable code alit, defaults to lit, jaw |
\ if we dont produce relocatable code alit, defaults to lit, jaw |
\ this is just for convenience, so we don't have to define alit, |
\ this is just for convenience, so we don't have to define alit, |
Line 2273 Cond: chars ;Cond
|
Line 2296 Cond: chars ;Cond
|
\ !! 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 16 and 32 Bit Targets and 32 Bit Hosts! |
|
|
|
\ This section could be done with dlit, now. But first I need |
|
\ some test code JAW |
|
|
Cond: MAXU |
Cond: MAXU |
tcell 1 cells u> |
tcell 1 cells u> |
IF compile lit tcell 0 ?DO FF T c, H LOOP |
IF compile lit tcell 0 ?DO FF T c, H LOOP |
Line 2437 Cond: DOES>
|
Line 2463 Cond: DOES>
|
: Builder ( Create-xt do-ghost "name" -- ) |
: Builder ( Create-xt do-ghost "name" -- ) |
\ builds up a builder in current vocabulary |
\ builds up a builder in current vocabulary |
\ create-xt is executed when word is interpreted |
\ create-xt is executed when word is interpreted |
\ do:-xt is executet when the created word from builder is executed |
\ do:-xt is executed when the created word from builder is executed |
\ for do:-xt an additional entry after the normal ghost-entrys is used |
\ for do:-xt an additional entry after the normal ghost-entrys is used |
|
|
Make-Ghost ( Create-xt do-ghost ghost ) |
Make-Ghost ( Create-xt do-ghost ghost ) |
Line 2521 Cond: DOES>
|
Line 2547 Cond: DOES>
|
\ DO: ;DO 11may93jaw |
\ DO: ;DO 11may93jaw |
\ changed to ?EXIT 10may93jaw |
\ changed to ?EXIT 10may93jaw |
|
|
: DO: ( -- ghost [xt] [colon-sys] ) |
: DO: ( -- do-ghost [xt] [colon-sys] ) |
here ghostheader |
here ghostheader |
:noname postpone gdoes> ( postpone ?EXIT ) ; |
:noname postpone gdoes> ( postpone ?EXIT ) ; |
|
|
: by: ( -- ghost [xt] [colon-sys] ) \ name |
: by: ( -- do-ghost [xt] [colon-sys] ) \ name |
Ghost |
Ghost |
:noname postpone gdoes> ( postpone ?EXIT ) ; |
:noname postpone gdoes> ( postpone ?EXIT ) ; |
|
|
: ;DO ( ghost [xt] [colon-sys] -- addr ) |
: ;DO ( do-ghost [xt] [colon-sys] -- do-ghost ) |
postpone ; ( S addr xt ) |
postpone ; ( S addr xt ) |
over >exec ! ; immediate |
over >exec ! ; immediate |
|
|
: by ( -- addr ) \ Name |
: by ( -- do-ghost ) \ Name |
Ghost >do:ghost @ ; |
Ghost >do:ghost @ ; |
|
|
|
: compile: ( do-ghost -- do-ghost [xt] [colon-sys] ) |
|
\G defines a compile time action for created words |
|
\G by this builder |
|
:noname ; |
|
|
|
: ;compile ( do-ghost [xt] [colon-sys] -- do-ghost ) |
|
postpone ; over >comp ! ; immediate |
|
|
|
|
|
|
>TARGET |
>TARGET |
\ Variables and Constants 05dec92py |
\ Variables and Constants 05dec92py |
|
|