version 1.91, 2001/01/29 11:39:43
|
version 1.102, 2001/09/04 11:09:59
|
Line 802 false DefaultValue dcomps
|
Line 802 false DefaultValue dcomps
|
false DefaultValue hash |
false DefaultValue hash |
false DefaultValue xconds |
false DefaultValue xconds |
false DefaultValue header |
false DefaultValue header |
false DefaultValue new-input |
|
[THEN] |
[THEN] |
|
|
true DefaultValue interpreter |
true DefaultValue interpreter |
Line 1516 variable ResolveFlag
|
Line 1515 variable ResolveFlag
|
>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+ |
bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+ |
: flag! ( w -- ) tlast @ flag+ + dup >r T c@ xor r> c! H ; |
: 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 immediate-mask flag! |
: immediate 40 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 restrict-mask flag! ; |
: restrict 20 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 1543 $20 constant restrict-mask
|
Line 1538 $20 constant restrict-mask
|
|
|
>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 ; |
|
|
: lstring, ( addr count -- ) |
: lstring, ( addr count -- ) |
dup T , H bounds ?DO I c@ T c, H LOOP ; |
dup T , H bounds ?DO I c@ T c, H LOOP ; |
|
|
: name, ( "name" -- ) bl word count T lstring, cfalign H ; |
: name, ( "name" -- ) bl word count T lstring, cfalign H ; |
: view, ( -- ) ( dummy ) ; |
: view, ( -- ) ( dummy ) ; |
>CROSS |
>CROSS |
Line 1701 NoHeaderFlag off
|
Line 1698 NoHeaderFlag off
|
IF dup >end tdoes ! |
IF dup >end tdoes ! |
ELSE 0 tdoes ! |
ELSE 0 tdoes ! |
THEN |
THEN |
alias-mask flag! |
80 flag! |
cross-doc-entry cross-tag-entry ; |
cross-doc-entry cross-tag-entry ; |
|
|
VARIABLE ;Resolve 1 cells allot |
VARIABLE ;Resolve 1 cells allot |
Line 1718 VARIABLE ;Resolve 1 cells allot
|
Line 1715 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 alias-mask flag! ; |
(THeader over resolve T A, H 80 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 2042 Cond: DOES> restrict?
|
Line 2039 Cond: DOES> restrict?
|
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 alias-mask flag! ( S executed-ghost new-ghost ) |
(THeader there 0 T a, H 80 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 |
Line 2211 Builder Field
|
Line 2208 Builder Field
|
: cell% ( n -- size align ) |
: cell% ( n -- size align ) |
T 1 cells H dup ; |
T 1 cells H dup ; |
|
|
|
|
Build: ( m v -- m' v ) dup T , cell+ H ; |
Build: ( m v -- m' v ) dup T , cell+ H ; |
DO: abort" Not in cross mode" ;DO |
DO: abort" Not in cross mode" ;DO |
Builder input-method |
Builder input-method |
Line 2219 Build: ( m v size -- m v' ) over T , H
|
Line 2217 Build: ( m v size -- m v' ) over T , H
|
DO: abort" Not in cross mode" ;DO |
DO: abort" Not in cross mode" ;DO |
Builder input-var |
Builder input-var |
|
|
|
|
|
|
\ structural conditionals 17dec92py |
\ structural conditionals 17dec92py |
|
|
>CROSS |
>CROSS |
Line 2411 Cond: postpone ( -- ) restrict? \ name
|
Line 2411 Cond: postpone ( -- ) restrict? \ name
|
ELSE dup >magic @ <imm> = |
ELSE dup >magic @ <imm> = |
IF gexecute |
IF gexecute |
ELSE compile (compile) addr, THEN THEN ;Cond |
ELSE compile (compile) addr, THEN THEN ;Cond |
|
|
|
Cond: [compile] ( -- ) restrict? \ name |
|
bl word gfind dup 0= ABORT" CROSS: Can't compile" |
|
0> IF gexecute |
|
ELSE dup >magic @ <imm> = |
|
IF gexecute |
|
ELSE compile (compile) addr, THEN THEN ;Cond |
|
|
\ save-cross 17mar93py |
\ save-cross 17mar93py |
|
|
Line 2588 bigendian Constant bigendian
|
Line 2595 bigendian Constant bigendian
|
: tempdp> tempdp> ; |
: tempdp> tempdp> ; |
: const constflag on ; |
: const constflag on ; |
: warnings name 3 = 0= twarnings ! drop ; |
: warnings name 3 = 0= twarnings ! drop ; |
|
: redefinitions-start twarnings off ; |
|
: redefinitions-end twarnings on ; |
|
: group 0 word drop ; |
|
|
: | ; |
: | ; |
\ : | NoHeaderFlag on ; \ This is broken (damages the last word) |
\ : | NoHeaderFlag on ; \ This is broken (damages the last word) |
|
|