version 1.78, 2001/02/07 09:58:46
|
version 1.79, 2001/02/08 21:30:08
|
Line 208 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 244 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 254 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 ) |
Line 775 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 856 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 865 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 976 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 1022 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 1036 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 )) |