version 1.75, 2001/01/24 13:53:32
|
version 1.79, 2001/02/08 21:30:08
|
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 202 end-struct prim%
|
Line 208 end-struct prim%
|
s" " p prim-doc 2! s" " p prim-forth-code 2! s" " p prim-wordset 2! |
s" " p prim-doc 2! s" " p prim-forth-code 2! s" " p prim-wordset 2! |
p ; |
p ; |
|
|
0 value prim |
0 value prim \ in combined prims either combined or a part |
|
0 value combined \ in combined prims the combined prim |
|
variable in-part \ true if processing a part |
|
in-part off |
|
|
|
1000 constant max-combined |
|
create combined-prims max-combined cells allot |
|
variable num-combined |
|
|
|
create current-depth max-stacks cells allot |
|
create max-depth max-stacks cells allot |
|
create min-depth max-stacks cells allot |
|
|
wordlist constant primitives |
wordlist constant primitives |
|
|
Line 238 Variable function-number 0 function-numb
|
Line 255 Variable function-number 0 function-numb
|
|
|
\ types |
\ types |
|
|
: stack-access ( n stack -- ) |
|
\ print a stack access at index n of stack |
: normal-stack-access ( n stack -- ) |
stack-pointer 2@ type |
stack-pointer 2@ type |
dup |
dup |
if |
if |
Line 248 Variable function-number 0 function-numb
|
Line 265 Variable function-number 0 function-numb
|
drop ." TOS" |
drop ." TOS" |
endif ; |
endif ; |
|
|
|
: part-stack-access { n stack -- } |
|
\ print _<stack><x>, x=maxdepth-currentdepth-n-1 |
|
." _" stack stack-pointer 2@ type |
|
stack stack-number @ { stack# } |
|
combined prim-stacks-in stack# th @ assert( dup max-depth stack# th @ = ) |
|
current-depth stack# th @ - n - 1- |
|
0 .r ; |
|
|
|
: stack-access ( n stack -- ) |
|
\ print a stack access at index n of stack |
|
in-part @ if |
|
part-stack-access |
|
else |
|
normal-stack-access |
|
endif ; |
|
|
: item-in-index { item -- n } |
: item-in-index { item -- n } |
\ n is the index of item (in the in-effect) |
\ n is the index of item (in the in-effect) |
item item-stack @ dup >r stack-in @ ( in-size r:stack ) |
item item-stack @ dup >r stack-in @ ( in-size r:stack ) |
item r> stack-in-index-xt @ execute ; |
item r> stack-in-index-xt @ execute ; |
|
|
|
: item-stack-type-name ( item -- addr u ) |
|
item-stack @ stack-type @ type-c-name 2@ ; |
|
|
: fetch-single ( item -- ) |
: fetch-single ( item -- ) |
\ 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-type-name 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 -- ) |
\ fetch a double stack item from its stack |
\ fetch a double stack item from its stack |
>r |
>r |
." FETCH_DCELL(" |
." vm_two" |
|
r@ item-stack-type-name type ." 2" |
|
r@ item-type @ print-type-prefix ." (" |
r@ item-name 2@ type ." , " |
r@ item-name 2@ type ." , " |
r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access |
r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access |
." , " -1 under+ ." (Cell)" stack-access |
." , " -1 under+ ." (Cell)" stack-access |
Line 296 Variable function-number 0 function-numb
|
Line 334 Variable function-number 0 function-numb
|
|
|
: 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-type-name type ." (" |
|
r@ item-name 2@ type ." );" |
rdrop ; |
rdrop ; |
|
|
: store-single ( item -- ) |
: store-single ( item -- ) |
Line 318 Variable function-number 0 function-numb
|
Line 357 Variable function-number 0 function-numb
|
: store-double ( item -- ) |
: store-double ( item -- ) |
\ !! store optimization is not performed, because it is not yet needed |
\ !! store optimization is not performed, because it is not yet needed |
>r |
>r |
." STORE_DCELL(" r@ item-name 2@ type ." , " |
." vm_" |
|
r@ item-type @ print-type-prefix ." 2two" |
|
r@ item-stack-type-name type ." (" |
|
r@ item-name 2@ type ." , " |
r@ item-out-index r@ item-stack @ 2dup stack-access |
r@ item-out-index r@ item-stack @ 2dup stack-access |
." , " -1 under+ stack-access |
." , " -1 under+ stack-access |
." );" cr |
." );" cr |
Line 422 s" Cell" single 0 create-type cell-type
|
Line 464 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 530 s" IP" save-mem cell-type s" error don'
|
Line 572 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 |
Line 763 s" IP" save-mem cell-type s" error don'
|
Line 802 s" IP" save-mem cell-type s" error don'
|
\ spTOS = (Cell)_x_sp0; |
\ spTOS = (Cell)_x_sp0; |
\ NEXT_P2; |
\ NEXT_P2; |
|
|
1000 constant max-combined |
|
create combined-prims max-combined cells allot |
|
variable num-combined |
|
|
|
create current-depth max-stacks cells allot |
|
create max-depth max-stacks cells allot |
|
create min-depth max-stacks cells allot |
|
|
|
: init-combined ( -- ) |
: init-combined ( -- ) |
|
prim to combined |
0 num-combined ! |
0 num-combined ! |
current-depth max-stacks cells erase |
current-depth max-stacks cells erase |
max-depth max-stacks cells erase |
max-depth max-stacks cells erase |
Line 844 create min-depth max-stacks cells al
|
Line 876 create min-depth max-stacks cells al
|
|
|
: print-item { n stack -- } |
: print-item { n stack -- } |
\ print nth stack item name |
\ print nth stack item name |
." _" stack stack-type @ type-c-name 2@ type space |
stack stack-type @ type-c-name 2@ type space |
stack stack-pointer 2@ type n 0 .r ; |
." _" stack stack-pointer 2@ type n 0 .r ; |
|
|
: print-declarations-combined ( -- ) |
: print-declarations-combined ( -- ) |
max-stacks 0 ?do |
max-stacks 0 ?do |
Line 853 create min-depth max-stacks cells al
|
Line 885 create min-depth max-stacks cells al
|
i stacks j th @ print-item ." ;" cr |
i stacks j th @ print-item ." ;" cr |
loop |
loop |
loop ; |
loop ; |
|
|
|
: part-fetches ( -- ) |
|
fetches ; |
|
|
|
: part-output-c-tail ( -- ) |
|
output-c-tail ; |
|
|
|
: output-part ( p -- ) |
|
to prim |
|
." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr |
|
." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging |
|
." {" cr |
|
print-declarations |
|
part-fetches |
|
print-debug-args |
|
prim add-depths \ !! right place? |
|
." {" cr |
|
." #line " c-line @ . quote c-filename 2@ type quote cr |
|
prim prim-c-code 2@ type-c \ !! deal with TAIL |
|
." }" cr |
|
part-output-c-tail |
|
." }" cr ; |
|
|
: output-parts ( -- ) |
: output-parts ( -- ) |
prim >r |
prim >r in-part on |
|
current-depth max-stacks cells erase |
num-combined @ 0 +do |
num-combined @ 0 +do |
combined-prims i th @ to prim |
combined-prims i th @ output-part |
output-c |
|
loop |
loop |
|
in-part off |
r> to prim ; |
r> to prim ; |
|
|
: output-c-combined ( -- ) |
: output-c-combined ( -- ) |
Line 964 bl 1+ maxchar ..
|
Line 1019 bl 1+ maxchar ..
|
char " singleton eof-char over add-member complement charclass noquote |
char " singleton eof-char over add-member complement charclass noquote |
nl-char singleton charclass nl |
nl-char singleton charclass nl |
eof-char singleton charclass eof |
eof-char singleton charclass eof |
|
nl-char singleton eof-char over add-member charclass nleof |
|
|
(( letter (( letter || digit )) ** |
(( letter (( letter || digit )) ** |
)) <- c-ident ( -- ) |
)) <- c-ident ( -- ) |
Line 1010 Variable c-flag
|
Line 1065 Variable c-flag
|
|
|
(( (( eval-comment || forth-comment || c-comment || else-comment || if-comment )) ?? nonl ** )) <- comment-body |
(( (( eval-comment || forth-comment || c-comment || else-comment || if-comment )) ?? nonl ** )) <- comment-body |
|
|
(( ` \ comment-body nl )) <- comment ( -- ) |
(( ` \ comment-body nleof )) <- comment ( -- ) |
|
|
(( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) ** |
(( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) ** |
<- stack-items |
<- stack-items |
Line 1024 Variable c-flag
|
Line 1079 Variable c-flag
|
` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white ** |
` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white ** |
(( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white ** |
(( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white ** |
(( {{ start }} c-ident {{ end prim prim-c-name 2! }} )) ?? |
(( {{ start }} c-ident {{ end prim prim-c-name 2! }} )) ?? |
)) ?? nl |
)) ?? nleof |
(( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nl )) ?? |
(( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ?? |
{{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl ** nl white ** )) ** {{ end prim prim-c-code 2! skipsynclines on }} |
{{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl ** nleof white ** )) ** {{ end prim prim-c-code 2! skipsynclines on }} |
(( ` : white ** nl |
(( ` : white ** nleof |
{{ start }} (( nonl ++ nl white ** )) ++ {{ end prim prim-forth-code 2! }} |
{{ start }} (( nonl ++ nleof white ** )) ++ {{ end prim prim-forth-code 2! }} |
)) ?? {{ declarations compute-offsets printprim 1 function-number +! }} |
)) ?? {{ declarations compute-offsets printprim 1 function-number +! }} |
(( nl || eof )) |
nleof |
)) <- simple-primitive ( -- ) |
)) <- simple-primitive ( -- ) |
|
|
(( {{ init-combined }} |
(( {{ init-combined }} |
` = (( white ++ {{ start }} forth-ident {{ end add-prim }} )) ++ |
` = (( white ++ {{ start }} forth-ident {{ end add-prim }} )) ++ |
(( nl || eof )) {{ process-combined }} |
nleof {{ process-combined }} |
)) <- combined-primitive |
)) <- combined-primitive |
|
|
(( {{ make-prim to prim |
(( {{ make-prim to prim 0 to combined |
line @ name-line ! filename 2@ name-filename 2! |
line @ name-line ! filename 2@ name-filename 2! |
start }} forth-ident {{ end 2dup prim prim-name 2! prim prim-c-name 2! }} white ++ |
start }} forth-ident {{ end 2dup prim prim-name 2! prim prim-c-name 2! }} white ++ |
(( simple-primitive || combined-primitive )) |
(( simple-primitive || combined-primitive )) |