version 1.74, 2001/01/24 10:32:01
|
version 1.77, 2001/02/06 16:53:06
|
Line 50 warnings off
|
Line 50 warnings off
|
include ./search.fs |
include ./search.fs |
include ./extend.fs |
include ./extend.fs |
[THEN] |
[THEN] |
|
include ./stuff.fs |
|
|
[IFUNDEF] environment? |
[IFUNDEF] environment? |
include ./environ.fs |
include ./environ.fs |
Line 178 create stacks max-stacks cells allot \ a
|
Line 179 create stacks max-stacks cells allot \ a
|
i xt execute |
i xt execute |
item% %size +loop ; |
item% %size +loop ; |
|
|
|
\ types |
|
|
|
: print-type-prefix ( type -- ) |
|
body> >head name>string type ; |
|
|
\ various variables for storing stuff of one primitive |
\ various variables for storing stuff of one primitive |
|
|
struct% |
struct% |
Line 188 struct%
|
Line 194 struct%
|
cell% 2* field prim-c-code |
cell% 2* field prim-c-code |
cell% 2* field prim-forth-code |
cell% 2* field prim-forth-code |
cell% 2* field prim-stack-string |
cell% 2* field prim-stack-string |
|
cell% field prim-items-wordlist \ unique items |
item% max-effect * field prim-effect-in |
item% max-effect * field prim-effect-in |
item% max-effect * field prim-effect-out |
item% max-effect * field prim-effect-out |
cell% field prim-effect-in-end |
cell% field prim-effect-in-end |
Line 227 variable name-line
|
Line 234 variable name-line
|
2variable last-name-filename |
2variable last-name-filename |
Variable function-number 0 function-number ! |
Variable function-number 0 function-number ! |
|
|
\ for several reasons stack items of a word are stored in a wordlist |
|
\ since neither forget nor marker are implemented yet, we make a new |
|
\ wordlist for every word and store it in the variable items |
|
variable itemsqq |
|
|
|
\ a few more set ops |
\ a few more set ops |
|
|
: bit-equivalent ( w1 w2 -- w3 ) |
: bit-equivalent ( w1 w2 -- w3 ) |
Line 261 variable itemsqq
|
Line 263 variable itemsqq
|
\ fetch a single stack item from its stack |
\ fetch a single stack item from its stack |
>r |
>r |
r@ item-name 2@ type |
r@ item-name 2@ type |
." = (" |
." = vm_" r@ item-stack @ stack-type @ type-c-name 2@ type |
r@ item-type @ type-c-name 2@ type ." ) " |
." 2" r@ item-type @ print-type-prefix ." (" |
r@ item-in-index r@ item-stack @ stack-access |
r@ item-in-index r@ item-stack @ stack-access |
." ;" cr |
." );" cr |
rdrop ; |
rdrop ; |
|
|
: fetch-double ( item -- ) |
: fetch-double ( item -- ) |
Line 283 variable itemsqq
|
Line 285 variable itemsqq
|
r@ item-first @ if |
r@ item-first @ if |
rdrop false exit |
rdrop false exit |
endif |
endif |
r@ item-name 2@ itemsqq @ search-wordlist 0= abort" bug" |
r@ item-name 2@ prim prim-items-wordlist @ search-wordlist 0= abort" bug" |
execute @ |
execute @ |
dup r@ = |
dup r@ = |
if \ item first appeared in output |
if \ item first appeared in output |
Line 300 variable itemsqq
|
Line 302 variable itemsqq
|
|
|
: really-store-single ( item -- ) |
: really-store-single ( item -- ) |
>r |
>r |
r@ item-out-index r@ item-stack @ stack-access ." = " |
r@ item-out-index r@ item-stack @ stack-access ." = vm_" |
r@ item-stack @ stack-cast 2@ type |
r@ item-type @ print-type-prefix ." 2" |
r@ item-name 2@ type ." ;" |
r@ item-stack @ stack-type @ type-c-name 2@ type ." (" |
|
r@ item-name 2@ type ." );" |
rdrop ; |
rdrop ; |
|
|
: store-single ( item -- ) |
: store-single ( item -- ) |
Line 370 does> ( item -- )
|
Line 373 does> ( item -- )
|
{ item typ } |
{ item typ } |
typ item item-type ! |
typ item item-type ! |
typ type-stack @ item item-stack !default |
typ type-stack @ item item-stack !default |
item item-name 2@ itemsqq @ search-wordlist 0= if \ new name |
item item-name 2@ prim prim-items-wordlist @ search-wordlist 0= if |
item item-name 2@ nextname item declare |
item item-name 2@ nextname item declare |
item item-first on |
item item-first on |
\ typ type-c-name 2@ type space type ." ;" cr |
\ typ type-c-name 2@ type space type ." ;" cr |
Line 399 does> ( item -- )
|
Line 402 does> ( item -- )
|
['] declaration map-items ; |
['] declaration map-items ; |
|
|
: declarations ( -- ) |
: declarations ( -- ) |
wordlist dup itemsqq ! set-current |
wordlist dup prim prim-items-wordlist ! set-current |
prim prim-effect-in prim prim-effect-in-end @ declaration-list |
prim prim-effect-in prim prim-effect-in-end @ declaration-list |
prim prim-effect-out prim prim-effect-out-end @ declaration-list ; |
prim prim-effect-out prim prim-effect-out-end @ declaration-list ; |
|
|
Line 426 s" Cell" single 0 create-type cell-type
|
Line 429 s" Cell" single 0 create-type cell-type
|
s" Float" single 0 create-type float-type |
s" Float" single 0 create-type float-type |
|
|
s" sp" save-mem cell-type s" (Cell)" make-stack data-stack |
s" sp" save-mem cell-type s" (Cell)" make-stack data-stack |
s" fp" save-mem cell-type s" " make-stack fp-stack |
s" fp" save-mem float-type s" " make-stack fp-stack |
s" rp" save-mem float-type s" (Cell)" make-stack return-stack |
s" rp" save-mem cell-type s" (Cell)" make-stack return-stack |
s" IP" save-mem cell-type s" error don't use # on results" make-stack inst-stream |
s" IP" save-mem cell-type s" error don't use # on results" make-stack inst-stream |
' inst-in-index inst-stream stack-in-index-xt ! |
' inst-in-index inst-stream stack-in-index-xt ! |
\ !! initialize stack-in and stack-out |
\ !! initialize stack-in and stack-out |
Line 534 s" IP" save-mem cell-type s" error don'
|
Line 537 s" IP" save-mem cell-type s" error don'
|
repeat |
repeat |
2drop type ; |
2drop type ; |
|
|
: print-type-prefix ( type -- ) |
|
body> >head .name ; |
|
|
|
: print-debug-arg { item -- } |
: print-debug-arg { item -- } |
." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); " |
." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); " |
." printarg_" item item-type @ print-type-prefix |
." printarg_" item item-type @ print-type-prefix |