version 1.92, 2001/03/18 11:35:35
|
version 1.97, 2001/05/13 11:02:59
|
Line 53
|
Line 53
|
|
|
warnings off |
warnings off |
|
|
[IFUNDEF] vocabulary \ we are executed just with kernel image |
[IFUNDEF] try |
\ load the rest that is needed |
include startup.fs |
\ (require fails because this file is needed from a |
|
\ different directory with the wordlibraries) |
|
include ./search.fs |
|
include ./extend.fs |
|
include ./stuff.fs |
|
[THEN] |
|
|
|
[IFUNDEF] environment? |
|
include ./environ.fs |
|
[THEN] |
[THEN] |
|
|
: struct% struct ; \ struct is redefined in gray |
: struct% struct ; \ struct is redefined in gray |
Line 431 wordlist constant prefixes
|
Line 422 wordlist constant prefixes
|
rdrop ; |
rdrop ; |
|
|
: type-prefix ( xt1 xt2 n stack "prefix" -- ) |
: type-prefix ( xt1 xt2 n stack "prefix" -- ) |
create-type |
get-current >r prefixes set-current |
|
create-type r> set-current |
does> ( item -- ) |
does> ( item -- ) |
\ initialize item |
\ initialize item |
{ item typ } |
{ item typ } |
Line 481 does> ( item -- )
|
Line 473 does> ( item -- )
|
prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ; |
prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ; |
|
|
: stack-prefix ( stack "prefix" -- ) |
: stack-prefix ( stack "prefix" -- ) |
|
get-current >r prefixes set-current |
name tuck nextname create ( stack length ) 2, |
name tuck nextname create ( stack length ) 2, |
|
r> set-current |
does> ( item -- ) |
does> ( item -- ) |
2@ { item stack prefix-length } |
2@ { item stack prefix-length } |
item item-name 2@ prefix-length /string item item-name 2! |
item item-name 2@ prefix-length /string item item-name 2! |
Line 493 does> ( item -- )
|
Line 487 does> ( item -- )
|
: stack-type-name ( addr u "name" -- ) |
: stack-type-name ( addr u "name" -- ) |
single 0 create-type ; |
single 0 create-type ; |
|
|
s" Cell" stack-type-name w |
wordlist constant type-names \ this is here just to meet the requirement |
s" Float" stack-type-name r |
\ that a type be a word; it is never used for lookup |
|
|
s" IP" save-mem w make-stack inst-stream |
: stack ( "name" "stack-pointer" "type" -- ) |
|
\ define stack |
|
name { d: stack-name } |
|
name { d: stack-pointer } |
|
name { d: stack-type } |
|
get-current type-names set-current |
|
stack-type 2dup nextname stack-type-name |
|
set-current |
|
stack-pointer lastxt >body stack-name nextname make-stack ; |
|
|
|
stack inst-stream IP Cell |
' inst-in-index inst-stream stack-in-index-xt ! |
' inst-in-index inst-stream stack-in-index-xt ! |
' inst-stream <is> inst-stream-f |
' inst-stream <is> inst-stream-f |
|
|
s" sp" save-mem w make-stack data-stack |
|
s" fp" save-mem r make-stack fp-stack |
|
s" rp" save-mem w make-stack return-stack |
|
\ !! initialize stack-in and stack-out |
\ !! initialize stack-in and stack-out |
|
|
\ offset computation |
\ offset computation |
Line 1217 warnings @ [IF]
|
Line 1217 warnings @ [IF]
|
.( parser generated ok ) cr |
.( parser generated ok ) cr |
[THEN] |
[THEN] |
|
|
|
|
|
\ run with gforth-0.5.0 (slurp-file is missing) |
|
[IFUNDEF] slurp-file |
|
: slurp-file ( c-addr1 u1 -- c-addr2 u2 ) |
|
\ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents |
|
r/o bin open-file throw >r |
|
r@ file-size throw abort" file too large" |
|
dup allocate throw swap |
|
2dup r@ read-file throw over <> abort" could not read whole file" |
|
r> close-file throw ; |
|
[THEN] |
|
|
: primfilter ( addr u -- ) |
: primfilter ( addr u -- ) |
\ process the string at addr u |
\ process the string at addr u |
over dup rawinput ! dup line-start ! cookedinput ! |
over dup rawinput ! dup line-start ! cookedinput ! |