version 1.71, 1999/02/22 18:27:22
|
version 1.74, 1999/05/05 18:07:51
|
Line 58 Warnings off
|
Line 58 Warnings off
|
\ we have to set current to be topmost context wordlist |
\ we have to set current to be topmost context wordlist |
get-order get-order get-current swap 1+ set-order |
get-order get-order get-current swap 1+ set-order |
r> ['] to execute |
r> ['] to execute |
set-order order |
set-order |
ELSE Value THEN ; |
ELSE Value THEN ; |
|
|
: DefaultValue ( n -- <name> ) |
: DefaultValue ( n -- <name> ) |
Line 118 also forth definitions \ these values m
|
Line 118 also forth definitions \ these values m
|
false DefaultValue stack-warn \ check on empty stack at any definition |
false DefaultValue stack-warn \ check on empty stack at any definition |
false DefaultValue create-forward-warn \ warn on forward declaration of created words |
false DefaultValue create-forward-warn \ warn on forward declaration of created words |
|
|
[IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN] |
|
[IFUNDEF] DebugMaskCross Variable DebugMaskCross 0 DebugMaskCross ! [THEN] |
|
|
|
|
|
previous >CROSS |
previous >CROSS |
|
|
Line 143 stack-warn [IF]
|
Line 144 stack-warn [IF]
|
: defempty? ; immediate |
: defempty? ; immediate |
[THEN] |
[THEN] |
|
|
|
\ debugging |
|
|
|
0 [IF] |
|
|
|
This implements debugflags for the cross compiler and the compiled |
|
images. It works identical to the has-flags in the environment. |
|
The debugflags are defined in a vocabluary. If the word exists and |
|
its value is true, the flag is switched on. |
|
|
|
[THEN] |
|
|
|
Vocabulary debugflags \ debug flags for cross |
|
also debugflags get-order over |
|
Constant debugflags-wl |
|
set-order previous |
|
|
|
: DebugFlag |
|
get-current >r debugflags-wl set-current |
|
SetValue |
|
r> set-current ; |
|
|
|
: Debug? ( adr u -- flag ) |
|
\G return true if debug flag is defined or switched on |
|
debugflags-wl search-wordlist |
|
IF EXECUTE |
|
ELSE false THEN ; |
|
|
|
: D? ( <name> -- flag ) |
|
\G return true if debug flag is defined or switched on |
|
\G while compiling we do not return the current value but |
|
bl word count debug? ; |
|
|
|
: [d?] |
|
\G compile the value-xt so the debug flag can be switched |
|
\G the flag must exist! |
|
bl word count debugflags-wl search-wordlist |
|
IF compile, |
|
ELSE -1 ABORT" unknown debug flag" |
|
\ POSTPONE false |
|
THEN ; immediate |
|
|
\ \ GhostNames Ghosts 9may93jaw |
\ \ GhostNames Ghosts 9may93jaw |
|
|
Line 315 false DefaultValue header
|
Line 355 false DefaultValue header
|
true DefaultValue interpreter |
true DefaultValue interpreter |
true DefaultValue ITC |
true DefaultValue ITC |
false DefaultValue rom |
false DefaultValue rom |
|
true DefaultValue standardthreading |
|
|
>TARGET |
>TARGET |
s" relocate" T environment? H |
s" relocate" T environment? H |
Line 377 Variable bit$
|
Line 418 Variable bit$
|
Variable headers-named 0 headers-named ! |
Variable headers-named 0 headers-named ! |
Variable user-vars 0 user-vars ! |
Variable user-vars 0 user-vars ! |
|
|
\ Memory initialisation 05dec92py |
|
|
|
[IFDEF] Memory \ Memory is a bigFORTH feature |
|
also Memory |
|
: initmem ( var len -- ) |
|
2dup swap handle! >r @ r> erase ; |
|
toss |
|
[ELSE] |
|
: initmem ( var len -- ) |
|
tuck allocate abort" CROSS: No memory for target" |
|
( len var adr ) dup rot ! |
|
( len adr ) swap erase ; |
|
[THEN] |
|
|
|
\ MakeKernal 12dec92py |
|
|
|
: makekernel ( targetsize -- targetsize ) |
|
bit$ over 1- tcell>bit rshift 1+ initmem |
|
image over initmem ; |
|
|
|
>MINIMAL |
|
: makekernel makekernel ; |
|
>CROSS |
|
|
|
: target>bitmask-size ( u1 -- u2 ) |
: target>bitmask-size ( u1 -- u2 ) |
1- tcell>bit rshift 1+ ; |
1- tcell>bit rshift 1+ ; |
|
|
Line 408 Variable user-vars 0 user-vars !
|
Line 425 Variable user-vars 0 user-vars !
|
dup allocate ABORT" CROSS: No memory for target" |
dup allocate ABORT" CROSS: No memory for target" |
swap over swap erase ; |
swap over swap erase ; |
|
|
|
|
|
|
\ \ memregion.fs |
\ \ memregion.fs |
|
|
|
|
Line 515 T has? rom H
|
Line 530 T has? rom H
|
: setup-target ( -- ) \G initialize targets memory space |
: setup-target ( -- ) \G initialize targets memory space |
s" rom" T $has? H |
s" rom" T $has? H |
IF \ check for ram and rom... |
IF \ check for ram and rom... |
address-space area nip 0<> |
\ address-space area nip 0<> |
ram-dictionary area nip 0<> |
ram-dictionary area nip 0<> |
rom-dictionary area nip 0<> |
rom-dictionary area nip 0<> |
and and 0= |
and 0= |
ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!" |
ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!" |
THEN |
THEN |
address-space area nip |
address-space area nip |
Line 543 T has? rom H
|
Line 558 T has? rom H
|
r@ >rmem ! |
r@ >rmem ! |
|
|
target>bitmask-size allocatetarget |
target>bitmask-size allocatetarget |
dup |
dup bit$ ! |
bit$ ! |
|
r> >rbm ! |
r> >rbm ! |
|
|
ELSE r> drop THEN |
ELSE r> drop THEN |
REPEAT ; |
REPEAT drop ; |
|
|
|
\ MakeKernal 22feb99jaw |
|
|
|
: makekernel ( targetsize -- targetsize ) |
|
dup dictionary >rlen ! setup-target ; |
|
|
|
>MINIMAL |
|
: makekernel makekernel ; |
|
>CROSS |
|
|
\ \ switched tdp for rom support 03jun97jaw |
\ \ switched tdp for rom support 03jun97jaw |
|
|
Line 765 T has? relocate H
|
Line 788 T has? relocate H
|
\ \ Load Assembler |
\ \ Load Assembler |
|
|
>TARGET |
>TARGET |
H also Forth definitions \ ." asm: " order |
H also Forth definitions |
|
|
: X also target bl word find |
: X also target bl word find |
IF state @ IF compile, |
IF state @ IF compile, |
Line 883 Create NoFile ," #load-file#"
|
Line 906 Create NoFile ," #load-file#"
|
REPEAT |
REPEAT |
2drop drop false ; |
2drop drop false ; |
|
|
|
false DebugFlag showincludedfiles |
|
|
: included |
: included |
\ cr ." Including: " 2dup type ." ..." |
[d?] showincludedfiles |
|
IF cr ." Including: " 2dup type ." ..." THEN |
FileMem >r |
FileMem >r |
2dup add-included-file included |
2dup add-included-file included |
r> to FileMem ; |
r> to FileMem ; |
Line 2037 Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
|
Line 2063 Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
|
|
|
also minimal |
also minimal |
|
|
\G doesn't skip line when bit is set in debugmask |
: d? d? ; |
: \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ; |
|
|
\G doesn't skip line when debug switch is on |
|
: \D D? 0= IF postpone \ THEN ; |
|
|
\G interprets the line if word is not defined |
\G interprets the line if word is not defined |
: \- defined? IF postpone \ THEN ; |
: \- defined? IF postpone \ THEN ; |
Line 2208 minimal
|
Line 2236 minimal
|
\ these ones are pefered: |
\ these ones are pefered: |
|
|
: lock turnkey ; |
: lock turnkey ; |
: unlock forth also cross ; |
: unlock previous forth also cross ; |
|
|
: [[ also unlock ; |
: [[ also unlock ; |
: ]] previous previous ; |
: ]] previous previous ; |