version 1.69, 1999/02/21 11:43:12
|
version 1.76, 1999/05/17 13:12:25
|
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 |
|
|
: .dec |
: .dec |
Line 143 stack-warn [IF]
|
Line 140 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 171 VARIABLE VocTemp
|
Line 207 VARIABLE VocTemp
|
hex |
hex |
4711 Constant <fwd> 4712 Constant <res> |
4711 Constant <fwd> 4712 Constant <res> |
4713 Constant <imm> 4714 Constant <do:> |
4713 Constant <imm> 4714 Constant <do:> |
|
4715 Constant <skip> |
|
|
\ iForth makes only immediate directly after create |
\ iForth makes only immediate directly after create |
\ make atonce trick! ? |
\ make atonce trick! ? |
|
|
Variable atonce atonce off |
Variable atonce atonce off |
|
|
: NoExec true ABORT" CROSS: Don't execute ghost" ; |
: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ; |
|
|
: GhostHeader <fwd> , 0 , ['] NoExec , ; |
: GhostHeader <fwd> , 0 , ['] NoExec , ; |
|
|
Line 222 VARIABLE Already
|
Line 259 VARIABLE Already
|
|
|
: ghost ( "name" -- ghost ) |
: ghost ( "name" -- ghost ) |
Already off |
Already off |
>in @ bl word gfind IF Already on nip EXIT THEN |
>in @ bl word gfind IF atonce off Already on nip EXIT THEN |
drop >in ! Make-Ghost ; |
drop >in ! Make-Ghost ; |
|
|
: >ghostname ( ghost -- adr len ) |
: >ghostname ( ghost -- adr len ) |
Line 240 VARIABLE Already
|
Line 277 VARIABLE Already
|
: forward? ( ghost -- flag ) |
: forward? ( ghost -- flag ) |
>magic @ <fwd> = ; |
>magic @ <fwd> = ; |
|
|
|
: undefined? ( ghost -- flag ) |
|
>magic @ dup <fwd> = swap <skip> = or ; |
|
|
\ Predefined ghosts 12dec92py |
\ Predefined ghosts 12dec92py |
|
|
ghost 0= drop |
ghost 0= drop |
Line 281 VARIABLE env-current \ save information
|
Line 321 VARIABLE env-current \ save information
|
: has? bl word count T environment? H |
: has? bl word count T environment? H |
IF \ environment variable is present, return its value |
IF \ environment variable is present, return its value |
ELSE \ environment variable is not present, return false |
ELSE \ environment variable is not present, return false |
\ !! JAW abort is just for testing |
false \ debug true ABORT" arg" |
false true ABORT" arg" |
|
THEN ; |
THEN ; |
|
|
: $has? T environment? H IF ELSE false THEN ; |
: $has? T environment? H IF ELSE false THEN ; |
Line 315 false DefaultValue header
|
Line 354 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 326 s" relocate" T environment? H
|
Line 366 s" relocate" T environment? H
|
|
|
\ \ Create additional parameters 19jan95py |
\ \ Create additional parameters 19jan95py |
|
|
1 8 lshift Constant maxbyte |
\ currently cross only works for host machines with address-unit-bits |
|
\ eual to 8 because of s! and sc! |
|
\ but I start to query the environment just to modularize a little bit |
|
|
|
: check-address-unit-bits ( -- ) |
|
\ s" ADDRESS-UNIT-BITS" environment? |
|
\ IF 8 <> ELSE true THEN |
|
\ ABORT" ADDRESS-UNIT-BITS unknown or not equal to 8!" |
|
|
|
\ shit, this doesn't work because environment? is only defined for |
|
\ gforth.fi and not kernl???.fi |
|
; |
|
|
|
check-address-unit-bits |
|
8 Constant bits/byte \ we define: byte is address-unit |
|
|
|
1 bits/byte lshift Constant maxbyte |
\ this sets byte size for the target machine, an (probably right guess) jaw |
\ this sets byte size for the target machine, an (probably right guess) jaw |
|
|
T |
T |
NIL Constant TNIL |
NIL Constant TNIL |
cell Constant tcell |
cell Constant tcell |
cell<< Constant tcell<< |
cell<< Constant tcell<< |
cell>bit Constant tcell>bit |
cell>bit Constant tcell>bit |
bits/byte Constant tbits/byte |
bits/char Constant tbits/char |
bits/byte 8 / Constant tchar |
bits/char H bits/byte T / |
float Constant tfloat |
Constant tchar |
1 bits/byte lshift Constant tmaxbyte |
float Constant tfloat |
|
1 bits/char lshift Constant tmaxchar |
|
[IFUNDEF] bits/byte |
|
8 Constant tbits/byte |
|
[ELSE] |
|
bits/byte Constant tbits/byte |
|
[THEN] |
H |
H |
|
tbits/byte bits/byte / Constant tbyte |
|
|
|
|
\ Variables 06oct92py |
\ Variables 06oct92py |
|
|
Line 353 Variable bit$
|
Line 417 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 384 Variable user-vars 0 user-vars !
|
Line 424 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 491 T has? rom H
|
Line 529 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 519 T has? rom H
|
Line 557 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 603 variable constflag constflag off
|
Line 649 variable constflag constflag off
|
|
|
: cell+ tcell + ; |
: cell+ tcell + ; |
: cells tcell<< lshift ; |
: cells tcell<< lshift ; |
: chars ; |
: chars tchar * ; |
: char+ 1 + ; |
: char+ tchar + ; |
: floats tfloat * ; |
: floats tfloat * ; |
|
|
>CROSS |
>CROSS |
Line 726 T has? relocate H
|
Line 772 T has? relocate H
|
: cfalign ( -- ) |
: cfalign ( -- ) |
T here H cfalign+ 0 ?DO bl T c, tchar H +LOOP ; |
T here H cfalign+ 0 ?DO bl T c, tchar H +LOOP ; |
|
|
: >address dup 0>= IF tchar / 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 ; |
: A, ( w -- ) >address T here H relon T , H ; |
: A, ( w -- ) >address T here H relon T , H ; |
|
|
Line 741 T has? relocate H
|
Line 787 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 859 Create NoFile ," #load-file#"
|
Line 905 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 963 Exists-Warnings on
|
Line 1012 Exists-Warnings on
|
\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 |
\ same name |
\ same name |
over forward? 0= IF exists EXIT THEN |
over undefined? 0= IF exists EXIT THEN |
\ get linked-list |
\ get linked-list |
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 |
Line 1140 Create tag-bof 1 c, 0C c,
|
Line 1189 Create tag-bof 1 c, 0C c,
|
|
|
Defer skip? ' false IS skip? |
Defer skip? ' false IS skip? |
|
|
|
: skipdef ( <name> -- ) |
|
\G skip definition of an undefined word in undef-words mode |
|
ghost dup forward? |
|
IF >magic <skip> swap ! |
|
ELSE drop THEN ; |
|
|
: defined? ( -- flag ) \ name |
: defined? ( -- flag ) \ name |
|
ghost undefined? 0= ; |
|
|
|
: defined2? ( -- flag ) \ name |
|
\G return true for anything else than forward, even for <skip> |
|
\G that's what we want |
ghost forward? 0= ; |
ghost forward? 0= ; |
|
|
: needed? ( -- flag ) \ name |
: needed? ( -- flag ) \ name |
Line 1149 Defer skip? ' false IS skip?
|
Line 1209 Defer skip? ' false IS skip?
|
\G a forward reference exists |
\G a forward reference exists |
\G so the definition is not skipped! |
\G so the definition is not skipped! |
bl word gfind |
bl word gfind |
IF dup forward? |
IF dup undefined? |
nip |
nip |
0= |
0= |
ELSE drop true THEN ; |
ELSE drop true THEN ; |
Line 1198 NoHeaderFlag off
|
Line 1258 NoHeaderFlag off
|
\ 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 @ |
CreateFlag @ |
IF |
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 |
>in @ alias2 swap >in ! \ create alias in target |
|
r> Warnings ! |
>in @ ghost swap >in ! |
>in @ ghost swap >in ! |
swap also ghosts ' previous swap ! \ tick ghost and store in alias |
swap also ghosts ' previous swap ! \ tick ghost and store in alias |
CreateFlag off |
CreateFlag off |
Line 1282 Comment ( Comment \
|
Line 1346 Comment ( Comment \
|
THEN ; immediate |
THEN ; immediate |
|
|
: ghost>cfa |
: ghost>cfa |
dup forward? ABORT" CROSS: forward " >link @ ; |
dup undefined? ABORT" CROSS: forward " >link @ ; |
|
|
>TARGET |
>TARGET |
|
|
Line 1516 Cond: DOES> restrict?
|
Line 1580 Cond: DOES> restrict?
|
|
|
: gdoes, ( ghost -- ) |
: gdoes, ( ghost -- ) |
\ makes the codefield for a word that is built |
\ makes the codefield for a word that is built |
>end @ dup forward? 0= |
>end @ dup undefined? 0= |
IF |
IF |
dup >magic @ <do:> = |
dup >magic @ <do:> = |
IF doer, |
IF doer, |
Line 2013 Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
|
Line 2077 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 2138 previous
|
Line 2204 previous
|
|
|
: all-words ['] false IS skip? ; |
: all-words ['] false IS skip? ; |
: needed-words ['] needed? IS skip? ; |
: needed-words ['] needed? IS skip? ; |
: undef-words ['] defined? IS skip? ; |
: undef-words ['] defined2? IS skip? ; |
|
: skipdef skipdef ; |
|
|
: \ postpone \ ; immediate |
: \ postpone \ ; immediate |
: \G T-\G ; immediate |
: \G T-\G ; immediate |
Line 2184 minimal
|
Line 2251 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 ; |