version 1.70, 2001/01/20 20:17:39
|
version 1.72, 2001/01/23 10:05:36
|
Line 19
|
Line 19
|
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
|
|
\ This is not very nice (hard limits, no checking, assumes 1 chars = 1) |
\ This is not very nice (hard limits, no checking, assumes 1 chars = 1). |
|
\ And it grew even worse when it aged. |
|
|
\ Optimizations: |
\ Optimizations: |
\ superfluous stores are removed. GCC removes the superfluous loads by itself |
\ superfluous stores are removed. GCC removes the superfluous loads by itself |
Line 59 include ./environ.fs
|
Line 60 include ./environ.fs
|
include ./gray.fs |
include ./gray.fs |
|
|
32 constant max-effect \ number of things on one side of a stack effect |
32 constant max-effect \ number of things on one side of a stack effect |
|
4 constant max-stacks \ the max. number of stacks (including inst-stream). |
255 constant maxchar |
255 constant maxchar |
maxchar 1+ constant eof-char |
maxchar 1+ constant eof-char |
#tab constant tab-char |
#tab constant tab-char |
Line 77 variable line-start \ pointer to start o
|
Line 79 variable line-start \ pointer to start o
|
variable skipsynclines \ are sync lines ("#line ...") invisible to the parser? |
variable skipsynclines \ are sync lines ("#line ...") invisible to the parser? |
skipsynclines on |
skipsynclines on |
|
|
|
: th ( addr1 n -- addr2 ) |
|
cells + ; |
|
|
|
: holds ( addr u -- ) |
|
\ like HOLD, but for a string |
|
tuck + swap 0 +do |
|
1- dup c@ hold |
|
loop |
|
drop ; |
|
|
: start ( -- addr ) |
: start ( -- addr ) |
cookedinput @ ; |
cookedinput @ ; |
|
|
: end ( addr -- addr u ) |
: end ( addr -- addr u ) |
cookedinput @ over - ; |
cookedinput @ over - ; |
|
|
|
: print-error-line ( -- ) |
|
\ print the current line and position |
|
line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end ) |
|
over - type cr |
|
line-start @ rawinput @ over - typewhite ." ^" cr ; |
|
|
|
: ?print-error { f addr u -- } |
|
f ?not? if |
|
outfile-id >r try |
|
stderr to outfile-id |
|
filename 2@ type ." :" line @ 0 .r ." : " addr u type cr |
|
print-error-line |
|
0 |
|
recover endtry |
|
r> to outfile-id throw |
|
abort |
|
endif ; |
|
|
: quote ( -- ) |
: quote ( -- ) |
[char] " emit ; |
[char] " emit ; |
|
|
variable output \ xt ( -- ) of output word |
variable output \ xt ( -- ) of output word for simple primitives |
|
variable output-combined \ xt ( -- ) of output word for combined primitives |
|
|
: printprim ( -- ) |
: printprim ( -- ) |
output @ execute ; |
output @ execute ; |
|
|
struct% |
struct% |
|
cell% field stack-number \ the number of this stack |
cell% 2* field stack-pointer \ stackpointer name |
cell% 2* field stack-pointer \ stackpointer name |
|
cell% 2* field stack-typename \ name for default type of stack items |
cell% 2* field stack-cast \ cast string for assignments to stack elements |
cell% 2* field stack-cast \ cast string for assignments to stack elements |
cell% field stack-in-index-xt \ ( in-size item -- in-index ) |
cell% field stack-in-index-xt \ ( in-size item -- in-index ) |
cell% field stack-in \ number of stack items in effect in |
|
cell% field stack-out \ number of stack items in effect out |
|
end-struct stack% |
end-struct stack% |
|
|
struct% |
struct% |
Line 115 struct%
|
Line 146 struct%
|
cell% field type-store \ xt of store code generator ( item -- ) |
cell% field type-store \ xt of store code generator ( item -- ) |
end-struct type% |
end-struct type% |
|
|
|
variable next-stack-number 0 next-stack-number ! |
|
create stacks max-stacks cells allot \ array of stacks |
|
|
: stack-in-index ( in-size item -- in-index ) |
: stack-in-index ( in-size item -- in-index ) |
item-offset @ - 1- ; |
item-offset @ - 1- ; |
|
|
: inst-in-index ( in-size item -- in-index ) |
: inst-in-index ( in-size item -- in-index ) |
nip dup item-offset @ swap item-type @ type-size @ + 1- ; |
nip dup item-offset @ swap item-type @ type-size @ + 1- ; |
|
|
: make-stack ( addr-ptr u1 addr-cast u2 "stack-name" -- ) |
: make-stack ( addr-ptr u1 addr-stack u2 addr-cast u3 "stack-name" -- ) |
create stack% %allot >r |
create stack% %allot >r |
|
r@ stacks next-stack-number @ th ! |
|
next-stack-number @ r@ stack-number ! 1 next-stack-number +! |
save-mem r@ stack-cast 2! |
save-mem r@ stack-cast 2! |
|
save-mem r@ stack-typename 2! |
save-mem r@ stack-pointer 2! |
save-mem r@ stack-pointer 2! |
['] stack-in-index r> stack-in-index-xt ! ; |
['] stack-in-index r> stack-in-index-xt ! ; |
|
|
s" sp" save-mem s" (Cell)" make-stack data-stack |
s" sp" save-mem s" Cell" save-mem s" (Cell)" make-stack data-stack |
s" fp" save-mem s" " make-stack fp-stack |
s" fp" save-mem s" Float" save-mem s" " make-stack fp-stack |
s" rp" save-mem s" (Cell)" make-stack return-stack |
s" rp" save-mem s" Cell" save-mem s" (Cell)" make-stack return-stack |
s" IP" save-mem s" error don't use # on results" make-stack inst-stream |
s" IP" save-mem s" Cell" save-mem 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 162 struct%
|
Line 199 struct%
|
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 |
cell% field prim-effect-out-end |
cell% field prim-effect-out-end |
|
cell% max-stacks * field prim-stacks-in \ number of in items per stack |
|
cell% max-stacks * field prim-stacks-out \ number of out items per stack |
end-struct prim% |
end-struct prim% |
|
|
: make-prim ( -- prim ) |
: make-prim ( -- prim ) |
Line 171 end-struct prim%
|
Line 210 end-struct prim%
|
|
|
0 value prim |
0 value prim |
|
|
|
wordlist constant primitives |
|
|
|
: create-prim ( prim -- ) |
|
get-current >r |
|
primitives set-current |
|
dup prim-name 2@ nextname constant |
|
r> set-current ; |
|
|
|
: stack-in ( stack -- addr ) |
|
\ address of number of stack items in effect in |
|
stack-number @ cells prim prim-stacks-in + ; |
|
|
|
: stack-out ( stack -- addr ) |
|
\ address of number of stack items in effect out |
|
stack-number @ cells prim prim-stacks-out + ; |
|
|
\ global vars |
\ global vars |
variable c-line |
variable c-line |
2variable c-filename |
2variable c-filename |
Line 423 does> ( item -- )
|
Line 478 does> ( item -- )
|
return-stack fill-a-tos ; |
return-stack fill-a-tos ; |
|
|
: fetch ( addr -- ) |
: fetch ( addr -- ) |
dup item-type @ type-fetch @ execute ; |
dup item-type @ type-fetch @ execute ; |
|
|
: fetches ( -- ) |
: fetches ( -- ) |
prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ; |
prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ; |
Line 488 does> ( item -- )
|
Line 543 does> ( item -- )
|
." fputc('\n', vm_out);" cr |
." fputc('\n', vm_out);" cr |
." }" cr |
." }" cr |
." #endif" cr ; |
." #endif" cr ; |
|
|
|
: print-entry ( -- ) |
|
." I_" prim prim-c-name 2@ type ." :" ; |
|
|
: output-c ( -- ) |
: output-c ( -- ) |
." I_" prim prim-c-name 2@ type ." : /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr |
print-entry ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr |
." /* " prim prim-doc 2@ type ." */" cr |
." /* " prim prim-doc 2@ type ." */" cr |
." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging |
." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging |
." {" cr |
." {" cr |
Line 703 does> ( item -- )
|
Line 761 does> ( item -- )
|
\ 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 ( -- ) |
|
0 num-combined ! |
|
current-depth max-stacks cells erase |
|
max-depth max-stacks cells erase |
|
min-depth max-stacks cells erase |
|
prim prim-effect-in prim prim-effect-in-end ! |
|
prim prim-effect-out prim prim-effect-out-end ! ; |
|
|
|
: max! ( n addr -- ) |
|
tuck @ max swap ! ; |
|
|
|
: min! ( n addr -- ) |
|
tuck @ min swap ! ; |
|
|
|
: add-depths { p -- } |
|
\ combine stack effect of p with *-depths |
|
max-stacks 0 ?do |
|
current-depth i th @ |
|
p prim-stacks-in i th @ + |
|
dup max-depth i th max! |
|
p prim-stacks-out i th @ - |
|
dup min-depth i th min! |
|
current-depth i th ! |
|
loop ; |
|
|
|
: add-prim ( addr u -- ) |
|
\ add primitive given by "addr u" to combined-prims |
|
primitives search-wordlist s" unknown primitive" ?print-error |
|
execute { p } |
|
p combined-prims num-combined @ th ! |
|
1 num-combined +! |
|
p add-depths ; |
|
|
|
: compute-effects { q -- } |
|
\ compute the stack effects of q from the depths |
|
max-stacks 0 ?do |
|
max-depth i th @ dup |
|
q prim-stacks-in i th ! |
|
current-depth i th @ - |
|
q prim-stacks-out i th ! |
|
loop ; |
|
|
|
: make-effect-items { stack# items effect-endp -- } |
|
\ effect-endp points to a pointer to the end of the current item-array |
|
\ and has to be updated |
|
stacks stack# th @ { stack } |
|
items 0 +do |
|
effect-endp @ { item } |
|
i 0 <# #s stack stack-pointer 2@ holds [char] _ hold #> save-mem |
|
item item-name 2! |
|
stack item item-stack ! |
|
0 item item-type ! |
|
i item item-offset ! |
|
item item-first on |
|
item% %size effect-endp +! |
|
loop ; |
|
|
|
: init-effects { q -- } |
|
\ initialize effects field for FETCHES and STORES |
|
max-stacks 0 ?do |
|
i q prim-stacks-in i th @ q prim-effect-in-end make-effect-items |
|
i q prim-stacks-out i th @ q prim-effect-out-end make-effect-items |
|
loop ; |
|
|
|
: process-combined ( -- ) |
|
prim compute-effects |
|
prim init-effects |
|
output-combined perform ; |
|
|
|
\ C output |
|
|
|
: print-item { n stack -- } |
|
\ print nth stack item name |
|
." _" stack stack-typename 2@ type space |
|
stack stack-pointer 2@ type n 0 .r ; |
|
|
|
: print-declarations-combined ( -- ) |
|
max-stacks 0 ?do |
|
max-depth i th @ min-depth i th @ - 0 +do |
|
i stacks j th @ print-item ." ;" cr |
|
loop |
|
loop ; |
|
|
|
: output-c-combined ( -- ) |
|
print-entry cr |
|
\ debugging messages just in constituents |
|
." {" cr |
|
." DEF_CA" cr |
|
print-declarations-combined |
|
." NEXT_P0;" cr |
|
flush-tos |
|
fetches |
|
; |
|
|
|
: output-forth-combined ( -- ) |
|
; |
|
|
\ the parser |
\ the parser |
|
|
Line 748 print-token !
|
Line 910 print-token !
|
endif |
endif |
drop ; |
drop ; |
|
|
: print-error-line ( -- ) |
|
\ print the current line and position |
|
line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end ) |
|
over - type cr |
|
line-start @ rawinput @ over - typewhite ." ^" cr ; |
|
|
|
: ?nextchar ( f -- ) |
: ?nextchar ( f -- ) |
?not? if |
s" syntax error, wrong char" ?print-error |
outfile-id >r try |
|
stderr to outfile-id |
|
filename 2@ type ." :" line @ 0 .r ." : syntax error, wrong char:" |
|
getinput . cr |
|
print-error-line |
|
0 |
|
recover endtry |
|
r> to outfile-id throw |
|
abort |
|
endif |
|
rawinput @ endrawinput @ <> if |
rawinput @ endrawinput @ <> if |
rawinput @ c@ |
rawinput @ c@ |
1 chars rawinput +! |
1 chars rawinput +! |
Line 859 Variable c-flag
|
Line 1005 Variable c-flag
|
{{ prim prim-effect-out }} stack-items {{ prim prim-effect-out-end ! }} |
{{ prim prim-effect-out }} stack-items {{ prim prim-effect-out-end ! }} |
)) <- stack-effect ( -- ) |
)) <- stack-effect ( -- ) |
|
|
(( |
(( {{ prim create-prim }} |
` ( 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! }} )) ?? |
Line 872 Variable c-flag
|
Line 1018 Variable c-flag
|
(( nl || eof )) |
(( nl || eof )) |
)) <- simple-primitive ( -- ) |
)) <- simple-primitive ( -- ) |
|
|
(( ` = (( white ++ forth-ident )) ++ (( nl || eof )) |
(( {{ init-combined }} |
|
` = (( white ++ {{ start }} forth-ident {{ end add-prim }} )) ++ |
|
(( nl || eof )) {{ process-combined }} |
)) <- combined-primitive |
)) <- combined-primitive |
|
|
(( {{ make-prim to prim |
(( {{ make-prim to prim |
Line 894 warnings @ [IF]
|
Line 1042 warnings @ [IF]
|
checksyncline |
checksyncline |
primitives2something ; |
primitives2something ; |
|
|
: process-file ( addr u xt -- ) |
: process-file ( addr u xt-simple x-combined -- ) |
output ! |
output-combined ! output ! |
save-mem 2dup filename 2! |
save-mem 2dup filename 2! |
slurp-file |
slurp-file |
warnings @ if |
warnings @ if |
." ------------ CUT HERE -------------" cr endif |
." ------------ CUT HERE -------------" cr endif |
primfilter ; |
primfilter ; |
|
|
: process ( xt -- ) |
\ : process ( xt -- ) |
bl word count rot |
\ bl word count rot |
process-file ; |
\ process-file ; |