version 1.44, 1997/02/09 21:51:38
|
version 1.50, 1997/07/06 15:42:22
|
Line 37
|
Line 37
|
\ targets 09jun93jaw |
\ targets 09jun93jaw |
\ added: 2user and value 11jun93jaw |
\ added: 2user and value 11jun93jaw |
|
|
|
\ needed? works better now!!! 01mar97jaw |
|
\ mach file is only loaded into target |
|
\ cell corrected |
|
|
|
|
\ include other.fs \ ansforth extentions for cross |
\ include other.fs \ ansforth extentions for cross |
|
|
: string, ( c-addr u -- ) |
: string, ( c-addr u -- ) |
Line 93 H
|
Line 98 H
|
|
|
\ Parameter for target systems 06oct92py |
\ Parameter for target systems 06oct92py |
|
|
|
>TARGET |
mach-file count included |
mach-file count included |
|
|
|
[IFUNDEF] has-interpreter true CONSTANT has-interpreter [THEN] |
|
|
also Forth definitions |
also Forth definitions |
|
|
[IFDEF] asm-include asm-include [THEN] |
[IFDEF] asm-include asm-include [THEN] |
|
|
previous |
previous |
|
hex |
|
|
>CROSS |
>CROSS |
|
|
\ Variables 06oct92py |
|
|
|
Variable image |
|
Variable tlast NIL tlast ! \ Last name field |
|
Variable tlastcfa \ Last code field |
|
Variable tdoes \ Resolve does> calls |
|
Variable bit$ |
|
Variable tdp |
|
: there tdp @ ; |
|
|
|
\ Create additional parameters 19jan95py |
\ Create additional parameters 19jan95py |
|
|
T |
T |
|
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 |
Line 124 float Constant tfloat
|
Line 124 float Constant tfloat
|
1 bits/byte lshift Constant maxbyte |
1 bits/byte lshift Constant maxbyte |
H |
H |
|
|
|
\ Variables 06oct92py |
|
|
|
Variable image |
|
Variable tlast TNIL tlast ! \ Last name field |
|
Variable tlastcfa \ Last code field |
|
Variable tdoes \ Resolve does> calls |
|
Variable bit$ |
|
Variable tdp |
|
: there tdp @ ; |
|
|
|
|
>TARGET |
>TARGET |
|
|
\ Byte ordering and cell size 06oct92py |
\ Byte ordering and cell size 06oct92py |
Line 131 H
|
Line 142 H
|
: cell+ tcell + ; |
: cell+ tcell + ; |
: cells tcell<< lshift ; |
: cells tcell<< lshift ; |
: chars ; |
: chars ; |
|
: char+ 1 + ; |
: floats tfloat * ; |
: floats tfloat * ; |
|
|
>CROSS |
>CROSS |
: cell/ tcell<< rshift ; |
: cell/ tcell<< rshift ; |
>TARGET |
>TARGET |
20 CONSTANT bl |
20 CONSTANT bl |
-1 Constant NIL |
TNIL Constant NIL |
|
|
>CROSS |
>CROSS |
|
|
Line 173 bigendian
|
Line 185 bigendian
|
|
|
>MINIMAL |
>MINIMAL |
: makekernel ( targetsize -- targetsize ) |
: makekernel ( targetsize -- targetsize ) |
bit$ over 1- cell>bit rshift 1+ initmem |
bit$ over 1- tcell>bit rshift 1+ initmem |
image over initmem tdp off ; |
image over initmem tdp off ; |
|
|
>CROSS |
>CROSS |
Line 191 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 203 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
\ Target memory access 06oct92py |
\ Target memory access 06oct92py |
|
|
: align+ ( taddr -- rest ) |
: align+ ( taddr -- rest ) |
cell tuck 1- and - [ cell 1- ] Literal and ; |
tcell tuck 1- and - [ tcell 1- ] Literal and ; |
: cfalign+ ( taddr -- rest ) |
: cfalign+ ( taddr -- rest ) |
\ see kernel.fs:cfaligned |
\ see kernel.fs:cfaligned |
/maxalign tuck 1- and - [ /maxalign 1- ] Literal and ; |
/maxalign tuck 1- and - [ /maxalign 1- ] Literal and ; |
Line 219 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 231 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
|
|
: here ( -- there ) there ; |
: here ( -- there ) there ; |
: allot ( n -- ) tdp +! ; |
: allot ( n -- ) tdp +! ; |
: , ( w -- ) T here H cell T allot ! H ; |
: , ( w -- ) T here H tcell T allot ! H ; |
: c, ( char -- ) T here 1 allot c! H ; |
: c, ( char -- ) T here 1 allot c! H ; |
: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; |
: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; |
: cfalign ( -- ) |
: cfalign ( -- ) |
Line 245 VARIABLE VocTemp
|
Line 257 VARIABLE VocTemp
|
: <T get-current VocTemp ! also Ghosts definitions ; |
: <T get-current VocTemp ! also Ghosts definitions ; |
: T> previous VocTemp @ set-current ; |
: T> previous VocTemp @ set-current ; |
|
|
|
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:> |
|
|
Line 269 Variable last-ghost
|
Line 282 Variable last-ghost
|
here tuck swap ! ghostheader T> |
here tuck swap ! ghostheader T> |
DOES> dup last-ghost ! >exec @ execute ; |
DOES> dup last-ghost ! >exec @ execute ; |
|
|
|
variable cfalist 0 cfalist ! |
|
|
|
: markcfa |
|
cfalist here over @ , swap ! , ; |
|
|
\ ghost words 14oct92py |
\ ghost words 14oct92py |
\ changed: 10may93py/jaw |
\ changed: 10may93py/jaw |
|
|
Line 338 variable ResolveFlag
|
Line 356 variable ResolveFlag
|
WHILE dup ?resolved |
WHILE dup ?resolved |
REPEAT drop ResolveFlag @ |
REPEAT drop ResolveFlag @ |
IF |
IF |
abort" Unresolved words!" |
-1 abort" Unresolved words!" |
ELSE |
ELSE |
." Nothing!" |
." Nothing!" |
THEN |
THEN |
Line 374 VARIABLE ^imm
|
Line 392 VARIABLE ^imm
|
|
|
\ Target Document Creation (goes to crossdoc.fd) 05jul95py |
\ Target Document Creation (goes to crossdoc.fd) 05jul95py |
|
|
s" crossdoc.fd" r/w create-file throw value doc-file-id |
s" doc/crossdoc.fd" r/w create-file throw value doc-file-id |
\ contains the file-id of the documentation file |
\ contains the file-id of the documentation file |
|
|
: T-\G ( -- ) |
: T-\G ( -- ) |
Line 441 Defer skip? ' false IS skip?
|
Line 459 Defer skip? ' false IS skip?
|
ghost >magic @ <fwd> <> ; |
ghost >magic @ <fwd> <> ; |
|
|
: needed? ( -- flag ) \ name |
: needed? ( -- flag ) \ name |
ghost dup >magic @ <fwd> = |
\G returns a false flag when |
IF >link @ 0<> ELSE drop false THEN ; |
\G a word is not defined |
|
\G a forward reference exists |
|
\G so the definition is not skipped! |
|
bl word gfind |
|
IF dup >magic @ <fwd> = |
|
\ swap >link @ 0<> and |
|
nip |
|
0= |
|
ELSE drop true THEN ; |
|
|
: doer? ( -- flag ) \ name |
: doer? ( -- flag ) \ name |
ghost >magic @ <do:> = ; |
ghost >magic @ <do:> = ; |
Line 528 ghost (does>) ghost noop
|
Line 554 ghost (does>) ghost noop
|
ghost (.") ghost (S") ghost (ABORT") 2drop drop |
ghost (.") ghost (S") ghost (ABORT") 2drop drop |
ghost ' drop |
ghost ' drop |
ghost :docol ghost :doesjump ghost :dodoes 2drop drop |
ghost :docol ghost :doesjump ghost :dodoes 2drop drop |
|
ghost over ghost = ghost drop 2drop drop |
|
|
\ compile 10may93jaw |
\ compile 10may93jaw |
|
|
Line 542 ghost :docol ghost :doesjump ghost :d
|
Line 569 ghost :docol ghost :doesjump ghost :d
|
\ generic threading modell |
\ generic threading modell |
: docol, ( -- ) compile :docol T 0 , H ; |
: docol, ( -- ) compile :docol T 0 , H ; |
|
|
: dodoes, ( -- ) compile :doesjump T 0 , H ; |
: dodoes, ( -- ) T cfalign H compile :doesjump T 0 , H ; |
|
|
[IFUNDEF] (code) |
[IFUNDEF] (code) |
Defer (code) |
Defer (code) |
Defer (end-code) |
Defer (end-code) |
[THEN] |
[THEN] |
|
|
|
[IFUNDEF] ca>native |
|
defer ca>native |
|
[THEN] |
|
|
>TARGET |
>TARGET |
: Code |
: Code |
(THeader there resolve |
(THeader there resolve |
there 2 T cells H + T a, 0 , H |
[ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF] |
depth (code) ; |
there 2 T cells H + ca>native T a, 0 , H |
|
[THEN] |
|
depth (code) ; |
|
|
: Code: |
: Code: |
ghost dup there resolve <do:> swap >magic ! |
ghost dup there ca>native resolve <do:> swap >magic ! |
depth (code) ; |
depth (code) ; |
|
|
: end-code |
: end-code |
Line 647 Cond: MAXI
|
Line 680 Cond: MAXI
|
docol, depth T ] H ; |
docol, depth T ] H ; |
|
|
: :noname ( -- colon-sys ) |
: :noname ( -- colon-sys ) |
T align H there docol, depth T ] H ; |
T cfalign H there docol, depth T ] H ; |
|
|
Cond: EXIT ( -- ) restrict? compile ;S ;Cond |
Cond: EXIT ( -- ) restrict? compile ;S ;Cond |
|
|
Line 689 Cond: DOES> restrict?
|
Line 722 Cond: DOES> restrict?
|
dup >magic @ <do:> = |
dup >magic @ <do:> = |
IF gexecute T 0 , H EXIT THEN |
IF gexecute T 0 , H EXIT THEN |
THEN |
THEN |
compile :dodoes gexecute T here H cell - reloff ; |
compile :dodoes gexecute T here H tcell - reloff ; |
|
|
: TCreate ( -- ) |
: TCreate ( -- ) |
last-ghost @ |
last-ghost @ |
Line 779 Build: ( d -- ) T , , H ;
|
Line 812 Build: ( d -- ) T , , H ;
|
DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO |
DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO |
Builder 2Constant |
Builder 2Constant |
|
|
Build: T 0 , H ; |
Build: T , H ; |
by (Constant) |
by (Constant) |
Builder Value |
Builder Value |
|
|
Build: T 0 A, H ; |
Build: T A, H ; |
by (Constant) |
by (Constant) |
Builder AValue |
Builder AValue |
|
|
Line 864 Cond: AGAIN restrict? sys? compile b
|
Line 897 Cond: AGAIN restrict? sys? compile b
|
Cond: UNTIL restrict? sys? compile ?branch <resolve ;Cond |
Cond: UNTIL restrict? sys? compile ?branch <resolve ;Cond |
Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond |
Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond |
|
|
|
Cond: CASE restrict? 0 ;Cond |
|
Cond: OF restrict? 1+ >r compile over compile = compile IF compile drop |
|
r> ;Cond |
|
Cond: ENDOF restrict? >r compile ELSE r> ;Cond |
|
Cond: ENDCASE restrict? compile drop 0 ?DO compile THEN LOOP ;Cond |
|
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
Cond: DO restrict? compile (do) T here H ;Cond |
Cond: DO restrict? compile (do) T here H ;Cond |
Cond: ?DO restrict? compile (?do) (leave T here H ;Cond |
Cond: ?DO restrict? compile (?do) T (leave here H ;Cond |
Cond: FOR restrict? compile (for) T here H ;Cond |
Cond: FOR restrict? compile (for) T here H ;Cond |
|
|
>CROSS |
>CROSS |
: loop] dup <resolve cell - compile DONE compile unloop ; |
: loop] dup <resolve tcell - compile DONE compile unloop ; |
>TARGET |
>TARGET |
|
|
Cond: LOOP restrict? sys? compile (loop) loop] ;Cond |
Cond: LOOP restrict? sys? compile (loop) loop] ;Cond |
Line 951 also minimal
|
Line 990 also minimal
|
|
|
also minimal |
also minimal |
|
|
|
\G interprets the line if word is not defined |
: \- defined? IF postpone \ THEN ; |
: \- defined? IF postpone \ THEN ; |
|
|
|
\G interprets the line if word is defined |
: \+ defined? 0= IF postpone \ THEN ; |
: \+ defined? 0= IF postpone \ THEN ; |
|
|
|
Cond: \- \- ;Cond |
|
Cond: \+ \+ ;Cond |
|
|
|
: ?? bl word find IF execute ELSE drop 0 THEN ; |
|
|
|
: needed: |
|
\G defines ghost for words that we want to be compiled |
|
BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ; |
|
|
: [IF] postpone [IF] ; |
: [IF] postpone [IF] ; |
: [THEN] postpone [THEN] ; |
: [THEN] postpone [THEN] ; |
: [ELSE] postpone [ELSE] ; |
: [ELSE] postpone [ELSE] ; |
Line 964 Cond: [IFUNDEF] [IFUNDEF] ;Cond
|
Line 1015 Cond: [IFUNDEF] [IFUNDEF] ;Cond
|
Cond: [THEN] [THEN] ;Cond |
Cond: [THEN] [THEN] ;Cond |
Cond: [ELSE] [ELSE] ;Cond |
Cond: [ELSE] [ELSE] ;Cond |
|
|
\ save-cross 17mar93py |
previous |
|
|
\ i'm not interested in bigforth features this time 10may93jaw |
|
\ [IFDEF] file |
|
\ also file |
|
\ [THEN] |
|
\ included throw after create-file 11may93jaw |
|
|
|
bigendian Constant bigendian |
\ save-cross 17mar93py |
|
|
|
>CROSS |
Create magic s" Gforth10" here over allot swap move |
Create magic s" Gforth10" here over allot swap move |
|
|
char 1 bigendian + cell + magic 7 + c! |
char 1 bigendian + tcell + magic 7 + c! |
|
|
: save-cross ( "image-name" "binary-name" -- ) |
: save-cross ( "image-name" "binary-name" -- ) |
bl parse ." Saving to " 2dup type cr |
bl parse ." Saving to " 2dup type cr |
w/o bin create-file throw >r |
w/o bin create-file throw >r |
NIL IF |
TNIL IF |
s" #! " r@ write-file throw |
s" #! " r@ write-file throw |
bl parse r@ write-file throw |
bl parse r@ write-file throw |
s" -i" r@ write-file throw |
s" -i" r@ write-file throw |
Line 996 char 1 bigendian + cell + magic 7 + c!
|
Line 1042 char 1 bigendian + cell + magic 7 + c!
|
bl parse 2drop |
bl parse 2drop |
THEN |
THEN |
image @ there r@ write-file throw \ write image |
image @ there r@ write-file throw \ write image |
NIL IF |
TNIL IF |
bit$ @ there 1- cell>bit rshift 1+ |
bit$ @ there 1- tcell>bit rshift 1+ |
r@ write-file throw \ write tags |
r@ write-file throw \ write tags |
THEN |
THEN |
r> close-file throw ; |
r> close-file throw ; |
|
|
\ words that should be in minimal |
\ words that should be in minimal |
|
>MINIMAL |
|
also minimal |
|
|
|
bigendian Constant bigendian |
|
: save-cross save-cross ; |
: here there ; |
: here there ; |
also forth [IFDEF] Label : Label Label ; [THEN] previous |
also forth |
|
[IFDEF] Label : Label Label ; [THEN] |
|
[IFDEF] start-macros : start-macros start-macros ; [THEN] |
|
previous |
|
|
: + + ; |
: + + ; |
: or or ; |
: or or ; |
: 1- 1- ; |
: 1- 1- ; |
Line 1023 also forth [IFDEF] Label : Label Label ;
|
Line 1077 also forth [IFDEF] Label : Label Label ;
|
: lshift lshift ; |
: lshift lshift ; |
: 2/ 2/ ; |
: 2/ 2/ ; |
: . . ; |
: . . ; |
|
: const ; |
|
|
mach-file count included |
\ mach-file count included |
|
|
: 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 ['] defined? IS skip? ; |
|
|
: \ postpone \ ; immediate |
: \ postpone \ ; immediate |
|
: \G T-\G ; immediate |
: ( postpone ( ; immediate |
: ( postpone ( ; immediate |
: include bl word count included ; |
: include bl word count included ; |
: .( [char] ) parse type ; |
: .( [char] ) parse type ; |