version 1.37, 1996/07/16 20:57:07
|
version 1.42, 1997/02/06 21:22:58
|
Line 104 Variable tdp
|
Line 104 Variable tdp
|
|
|
\ Parameter for target systems 06oct92py |
\ Parameter for target systems 06oct92py |
|
|
included |
mach-file count included |
|
|
\ Create additional parameters 19jan95py |
\ Create additional parameters 19jan95py |
|
|
Line 131 H
|
Line 131 H
|
>TARGET |
>TARGET |
20 CONSTANT bl |
20 CONSTANT bl |
-1 Constant NIL |
-1 Constant NIL |
-2 Constant :docol |
|
-3 Constant :docon |
|
-4 Constant :dovar |
|
-5 Constant :douser |
|
-6 Constant :dodefer |
|
-7 Constant :dofield |
|
-8 Constant :dodoes |
|
-9 Constant :doesjump |
|
|
|
>CROSS |
>CROSS |
|
|
Line 173 bigendian
|
Line 165 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 186 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 194 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 233 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 225 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
|
|
\ threading modell 13dec92py |
\ threading modell 13dec92py |
|
|
\ generic threading modell |
|
: docol, ( -- ) :docol T A, 0 , H ; |
|
|
|
>TARGET |
>TARGET |
: >body ( cfa -- pfa ) T cell+ cell+ H ; |
: >body ( cfa -- pfa ) T cell+ cell+ H ; |
>CROSS |
>CROSS |
|
|
: dodoes, ( -- ) T :doesjump A, 0 , H ; |
|
|
|
\ Ghost Builder 06oct92py |
\ Ghost Builder 06oct92py |
|
|
\ <T T> new version with temp variable 10may93jaw |
\ <T T> new version with temp variable 10may93jaw |
Line 252 VARIABLE VocTemp
|
Line 239 VARIABLE VocTemp
|
: T> previous VocTemp @ set-current ; |
: T> previous VocTemp @ set-current ; |
|
|
4711 Constant <fwd> 4712 Constant <res> |
4711 Constant <fwd> 4712 Constant <res> |
4713 Constant <imm> |
4713 Constant <imm> 4714 Constant <do:> |
|
|
\ iForth makes only immediate directly after create |
\ iForth makes only immediate directly after create |
\ make atonce trick! ? |
\ make atonce trick! ? |
Line 278 Variable last-ghost
|
Line 265 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 382 VARIABLE ^imm
|
Line 368 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 385 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" kernal.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 450 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! ; |
|
: Alias: ( cfa -- ) \ name |
|
ghost tuck swap resolve <do:> swap >magic ! ; |
>CROSS |
>CROSS |
|
|
\ Conditionals and Comments 11may93jaw |
\ Conditionals and Comments 11may93jaw |
Line 501 ghost unloop ghost ;S
|
Line 488 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 |
|
ghost :docol ghost :doesjump ghost :dodoes 2drop drop |
|
|
\ compile 10may93jaw |
\ compile 10may93jaw |
|
|
Line 513 ghost '
|
Line 501 ghost '
|
ELSE postpone literal postpone gexecute THEN ; |
ELSE postpone literal postpone gexecute THEN ; |
immediate |
immediate |
|
|
|
\ generic threading modell |
|
: docol, ( -- ) compile :docol T 0 , H ; |
|
|
|
: dodoes, ( -- ) compile :doesjump T 0 , H ; |
|
|
>TARGET |
>TARGET |
: ' ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined " |
: ' ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined " |
dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ; |
dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ; |
Line 528 Cond: chars ;Cond
|
Line 521 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 586 Cond: ; ( -- ) restrict?
|
Line 581 Cond: ; ( -- ) restrict?
|
Cond: [ restrict? state off ;Cond |
Cond: [ restrict? state off ;Cond |
|
|
>CROSS |
>CROSS |
: !does :dodoes tlastcfa @ tuck T ! cell+ ! H ; |
: !does |
|
tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ; |
|
|
>TARGET |
>TARGET |
Cond: DOES> restrict? |
Cond: DOES> restrict? |
Line 607 Cond: DOES> restrict?
|
Line 603 Cond: DOES> restrict?
|
\ DOES> dup >exec @ execute ; |
\ DOES> dup >exec @ execute ; |
|
|
: gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <> |
: gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <> |
IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN |
IF |
:dodoes T A, H gexecute T here H cell - reloff ; |
dup >magic @ <do:> = |
|
IF gexecute T 0 , H EXIT THEN |
|
THEN |
|
compile :dodoes gexecute T here H cell - reloff ; |
|
|
: TCreate ( -- ) |
: TCreate ( -- ) |
last-ghost @ |
last-ghost @ |
Line 631 Cond: DOES> restrict?
|
Line 630 Cond: DOES> restrict?
|
here ghostheader |
here ghostheader |
:noname postpone gdoes> postpone ?EXIT ; |
:noname postpone gdoes> postpone ?EXIT ; |
|
|
|
: by: ( -- addr [xt] [colon-sys] ) \ name |
|
ghost |
|
:noname postpone gdoes> postpone ?EXIT ; |
|
|
: ;DO ( addr [xt] [colon-sys] -- ) |
: ;DO ( addr [xt] [colon-sys] -- ) |
postpone ; ( S addr xt ) |
postpone ; ( S addr xt ) |
over >exec ! ; immediate |
over >exec ! ; immediate |
Line 642 Cond: DOES> restrict?
|
Line 645 Cond: DOES> restrict?
|
\ Variables and Constants 05dec92py |
\ Variables and Constants 05dec92py |
|
|
Build: ; |
Build: ; |
DO: ( ghost -- addr ) ;DO |
by: :dovar ( ghost -- addr ) ;DO |
Builder Create |
Builder Create |
by Create :dovar resolve |
|
|
|
Build: T 0 , H ; |
Build: T 0 , H ; |
by Create |
by Create |
Line 668 Variable tudp 0 tudp !
|
Line 670 Variable tudp 0 tudp !
|
>TARGET |
>TARGET |
|
|
Build: T 0 u, , H ; |
Build: T 0 u, , H ; |
DO: ( ghost -- up-addr ) T @ H tup @ + ;DO |
by: :douser ( ghost -- up-addr ) T @ H tup @ + ;DO |
Builder User |
Builder User |
by User :douser resolve |
|
|
|
Build: T 0 u, , 0 u, drop H ; |
Build: T 0 u, , 0 u, drop H ; |
by User |
by User |
Line 681 by User
|
Line 682 by User
|
Builder AUser |
Builder AUser |
|
|
Build: ( n -- ) T , H ; |
Build: ( n -- ) T , H ; |
DO: ( ghost -- n ) T @ H ;DO |
by: :docon ( ghost -- n ) T @ H ;DO |
Builder Constant |
Builder Constant |
by Constant :docon resolve |
|
|
|
Build: ( n -- ) T A, H ; |
Build: ( n -- ) T A, H ; |
by Constant |
by Constant |
Line 702 by Constant
|
Line 702 by Constant
|
Builder AValue |
Builder AValue |
|
|
Build: ( -- ) compile noop ; |
Build: ( -- ) compile noop ; |
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
Builder Defer |
Builder Defer |
by Defer :dodefer resolve |
|
|
|
Build: ( inter comp -- ) swap T immediate A, A, H ; |
Build: ( inter comp -- ) swap T immediate A, A, H ; |
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
Builder special: |
Builder interpret/compile: |
|
|
\ Sturctures 23feb95py |
\ Sturctures 23feb95py |
|
|
Line 720 Builder special:
|
Line 719 Builder special:
|
|
|
Build: >r rot r@ nalign dup T , H ( align1 size offset ) |
Build: >r rot r@ nalign dup T , H ( align1 size offset ) |
+ swap r> nalign ; |
+ swap r> nalign ; |
DO: T @ H + ;DO |
by: :dofield T @ H + ;DO |
Builder Field |
Builder Field |
by Field :dofield resolve |
|
|
|
: struct T 0 1 chars H ; |
: struct T 0 1 chars H ; |
: end-struct T 2Constant H ; |
: end-struct T 2Constant H ; |
Line 916 char 1 bigendian + cell + magic 7 + c!
|
Line 914 char 1 bigendian + cell + magic 7 + c!
|
: drop drop ; : = = ; |
: drop drop ; : = = ; |
: lshift lshift ; : 2/ 2/ ; |
: lshift lshift ; : 2/ 2/ ; |
: . . ; |
: . . ; |
cell constant cell |
\ cell constant cell |
|
|
|
mach-file count included |
|
|
\ 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 937 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 ; |