version 1.32, 1995/11/30 18:01:47
|
version 1.41, 1996/10/20 20:35:24
|
Line 173 bigendian
|
Line 173 bigendian
|
\ MakeKernal 12dec92py |
\ MakeKernal 12dec92py |
|
|
>MINIMAL |
>MINIMAL |
: makekernal ( targetsize -- targetsize ) |
: makekernel ( targetsize -- targetsize ) |
bit$ over 1- cell>bit rshift 1+ initmem |
bit$ over 1- cell>bit rshift 1+ initmem |
image over initmem tdp off ; |
image over initmem tdp off ; |
|
|
Line 194 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 194 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
: align+ ( taddr -- rest ) |
: align+ ( taddr -- rest ) |
cell tuck 1- and - [ cell 1- ] Literal and ; |
cell tuck 1- and - [ cell 1- ] Literal and ; |
: cfalign+ ( taddr -- rest ) |
: cfalign+ ( taddr -- rest ) |
\ see kernal.fs:cfaligned |
\ see kernel.fs:cfaligned |
float tuck 1- and - [ float 1- ] Literal and ; |
float tuck 1- and - [ float 1- ] Literal and ; |
|
|
>TARGET |
>TARGET |
Line 202 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 202 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
\ assumes cell alignment granularity (as GNU C) |
\ assumes cell alignment granularity (as GNU C) |
|
|
: cfaligned ( taddr1 -- taddr2 ) |
: cfaligned ( taddr1 -- taddr2 ) |
\ see kernal.fs |
\ see kernel.fs |
dup cfalign+ + ; |
dup cfalign+ + ; |
|
|
>CROSS |
>CROSS |
Line 278 Variable last-ghost
|
Line 278 Variable last-ghost
|
|
|
: gfind ( string -- ghost true/1 / string false ) |
: gfind ( string -- ghost true/1 / string false ) |
\ searches for string in word-list ghosts |
\ searches for string in word-list ghosts |
\ !! wouldn't it be simpler to just use search-wordlist ? ae |
|
dup count [ ' ghosts >body ] ALiteral search-wordlist |
dup count [ ' ghosts >body ] ALiteral search-wordlist |
dup IF >r >body nip r> THEN ; |
dup IF >r >body nip r> THEN ; |
|
|
VARIABLE Already |
VARIABLE Already |
|
|
Line 357 variable ResolveFlag
|
Line 356 variable ResolveFlag
|
VARIABLE ^imm |
VARIABLE ^imm |
|
|
>TARGET |
>TARGET |
: immediate 20 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 40 flag! ; |
: restrict 20 flag! ; |
>CROSS |
>CROSS |
|
|
\ ALIAS2 ansforth conform alias 9may93jaw |
\ ALIAS2 ansforth conform alias 9may93jaw |
Line 382 VARIABLE ^imm
|
Line 381 VARIABLE ^imm
|
s" crossdoc.fd" r/w create-file throw value doc-file-id |
s" 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 |
|
|
: \G ( -- ) |
: T-\G ( -- ) |
source >in @ /string doc-file-id write-line throw |
source >in @ /string doc-file-id write-line throw |
source >in ! drop ; immediate |
postpone \ ; |
|
|
Variable to-doc |
Variable to-doc to-doc on |
|
|
: cross-doc-entry ( -- ) |
: cross-doc-entry ( -- ) |
to-doc @ tlast @ 0<> and \ not an anonymous (i.e. noname) header |
to-doc @ tlast @ 0<> and \ not an anonymous (i.e. noname) header |
Line 399 Variable to-doc
|
Line 398 Variable to-doc
|
[char] ) parse doc-file-id write-file throw |
[char] ) parse doc-file-id write-file throw |
s" )" doc-file-id write-file throw |
s" )" doc-file-id write-file throw |
[char] \ parse 2drop |
[char] \ parse 2drop |
POSTPONE \g |
T-\G |
>in ! |
>in ! |
THEN to-doc on ; |
THEN ; |
|
|
\ Target TAGS creation |
\ Target TAGS creation |
|
|
s" TAGS" r/w create-file throw value tag-file-id |
s" kernel.TAGS" r/w create-file throw value tag-file-id |
\ contains the file-id of the tags file |
\ contains the file-id of the tags file |
|
|
Create tag-beg 2 c, 7F c, bl c, |
Create tag-beg 2 c, 7F c, bl c, |
Line 464 VARIABLE ;Resolve 1 cells allot
|
Line 463 VARIABLE ;Resolve 1 cells allot
|
|
|
>TARGET |
>TARGET |
: Alias ( cfa -- ) \ name |
: Alias ( cfa -- ) \ name |
dup 0< IF to-doc off THEN |
|
(THeader over resolve T A, H 80 flag! ; |
(THeader over resolve T A, H 80 flag! ; |
>CROSS |
>CROSS |
|
|
Line 501 ghost unloop ghost ;S
|
Line 499 ghost unloop ghost ;S
|
ghost lit ghost (compile) ghost ! 2drop drop |
ghost lit ghost (compile) ghost ! 2drop drop |
ghost (does>) ghost noop 2drop |
ghost (does>) ghost noop 2drop |
ghost (.") ghost (S") ghost (ABORT") 2drop drop |
ghost (.") ghost (S") ghost (ABORT") 2drop drop |
ghost ' |
ghost ' drop |
|
|
\ compile 10may93jaw |
\ compile 10may93jaw |
|
|
Line 528 Cond: chars ;Cond
|
Line 526 Cond: chars ;Cond
|
: alit, ( n -- ) compile lit T A, H ; |
: alit, ( n -- ) compile lit T A, H ; |
|
|
>TARGET |
>TARGET |
|
Cond: \G T-\G ;Cond |
|
|
Cond: Literal ( n -- ) restrict? lit, ;Cond |
Cond: Literal ( n -- ) restrict? lit, ;Cond |
Cond: ALiteral ( n -- ) restrict? alit, ;Cond |
Cond: ALiteral ( n -- ) restrict? alit, ;Cond |
|
|
Line 569 Cond: [Char] ( "<char>" -- ) restrict
|
Line 569 Cond: [Char] ( "<char>" -- ) restrict
|
(THeader ;Resolve ! there ;Resolve cell+ ! |
(THeader ;Resolve ! there ;Resolve cell+ ! |
docol, depth T ] H ; |
docol, depth T ] H ; |
|
|
|
: :noname ( -- colon-sys ) |
|
T align H there docol, depth T ] H ; |
|
|
Cond: EXIT ( -- ) restrict? compile ;S ;Cond |
Cond: EXIT ( -- ) restrict? compile ;S ;Cond |
|
|
Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond |
Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond |
Line 703 DO: ( ghost -- ) ABORT" CROSS: Don't exe
|
Line 706 DO: ( ghost -- ) ABORT" CROSS: Don't exe
|
Builder Defer |
Builder Defer |
by Defer :dodefer resolve |
by Defer :dodefer resolve |
|
|
|
Build: ( inter comp -- ) swap T immediate A, A, H ; |
|
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
|
Builder interpret/compile: |
|
|
\ Sturctures 23feb95py |
\ Sturctures 23feb95py |
|
|
>CROSS |
>CROSS |
Line 877 Cond: [ELSE] [ELSE] ;Cond
|
Line 884 Cond: [ELSE] [ELSE] ;Cond
|
|
|
bigendian Constant bigendian |
bigendian Constant bigendian |
|
|
Create magic s" gforth00" here over allot swap move |
Create magic s" Gforth10" here over allot swap move |
|
|
[char] 1 bigendian + cell + magic 7 + c! |
char 1 bigendian + cell + magic 7 + c! |
|
|
: save-cross ( "name" -- ) |
: save-cross ( "image-name" "binary-name" -- ) |
bl parse ." Saving to " 2dup type |
bl parse ." Saving to " 2dup type cr |
w/o bin create-file throw >r |
w/o bin create-file throw >r |
|
s" #! " r@ write-file throw |
|
bl parse r@ write-file throw |
|
s" -i" r@ write-file throw |
|
#lf r@ emit-file throw |
|
r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index ) |
|
?do |
|
bl over emit-file throw |
|
loop |
|
drop |
magic 8 r@ write-file throw \ write magic |
magic 8 r@ write-file throw \ write magic |
image @ there r@ write-file throw \ write image |
image @ there r@ write-file throw \ write image |
bit$ @ there 1- cell>bit rshift 1+ |
bit$ @ there 1- cell>bit rshift 1+ |
Line 905 cell constant cell
|
Line 921 cell constant cell
|
\ include bug5.fs |
\ include bug5.fs |
\ only forth also minimal definitions |
\ only forth also minimal definitions |
|
|
: \ postpone \ ; |
: \ postpone \ ; immediate |
: \G postpone \G ; |
: ( postpone ( ; immediate |
: ( postpone ( ; |
|
: include bl word count included ; |
: include bl word count included ; |
: .( [char] ) parse type ; |
: .( [char] ) parse type ; |
: cr cr ; |
: cr cr ; |
Line 921 only forth also minimal definitions
|
Line 936 only forth also minimal definitions
|
: hex hex ; |
: hex hex ; |
|
|
: tudp T tudp H ; |
: tudp T tudp H ; |
: tup T tup H ; minimal |
: tup T tup H ; |
|
|
|
: doc-off false T to-doc H ! ; |
|
: doc-on true T to-doc H ! ; |
|
|
|
minimal |
|
|
\ for debugging... |
\ for debugging... |
: order order ; |
: order order ; |