version 1.70, 2001/01/20 20:17:39
|
version 1.80, 2001/02/09 20:15:31
|
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 39
|
Line 40
|
\ add the store optimization for doubles |
\ add the store optimization for doubles |
\ regarding problem 1 above: It would be better (for over) to implement |
\ regarding problem 1 above: It would be better (for over) to implement |
\ the alternative |
\ the alternative |
|
\ store optimization for combined instructions. |
|
\ eliminate stack-cast (no longer used) |
|
|
|
\ Design Uglyness: |
|
|
|
\ - global state (values, variables) in connection with combined instructions. |
|
|
|
\ - index computation is different for instruction-stream and the |
|
\ stacks; there are two mechanisms for dealing with that |
|
\ (stack-in-index-xt and a test for stack==instruction-stream); there |
|
\ should be only one. |
|
|
warnings off |
warnings off |
|
|
Line 49 warnings off
|
Line 61 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 59 include ./environ.fs
|
Line 72 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 91 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% field stack-type \ 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 158 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 type addr-cast u2 "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! |
|
r@ stack-type ! |
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" fp" save-mem s" " make-stack fp-stack |
|
s" rp" save-mem s" (Cell)" make-stack return-stack |
|
s" IP" save-mem s" error don't use # on results" make-stack inst-stream |
|
' inst-in-index inst-stream stack-in-index-xt ! |
|
\ !! initialize stack-in and stack-out |
|
|
|
\ stack items |
\ stack items |
|
|
: init-item ( addr u addr1 -- ) |
: init-item ( addr u addr1 -- ) |
Line 148 s" IP" save-mem s" error don't use # on
|
Line 190 s" IP" save-mem s" error don't use # on
|
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 158 struct%
|
Line 205 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 |
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 169 end-struct prim%
|
Line 219 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 |
|
|
|
: 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 |
Line 179 variable name-line
|
Line 256 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 items |
|
|
|
\ a few more set ops |
\ a few more set ops |
|
|
: bit-equivalent ( w1 w2 -- w3 ) |
: bit-equivalent ( w1 w2 -- w3 ) |
Line 192 variable items
|
Line 264 variable items
|
: complement ( set1 -- set2 ) |
: complement ( set1 -- set2 ) |
empty ['] bit-equivalent binary-set-operation ; |
empty ['] bit-equivalent binary-set-operation ; |
|
|
\ types |
\ stack access stuff |
|
|
: stack-access ( n stack -- ) |
: normal-stack-access ( n stack -- ) |
\ print a stack access at index n of stack |
|
stack-pointer 2@ type |
stack-pointer 2@ type |
dup |
dup |
if |
if |
Line 204 variable items
|
Line 275 variable items
|
drop ." TOS" |
drop ." TOS" |
endif ; |
endif ; |
|
|
|
\ forward declaration for inst-stream (breaks cycle in definitions) |
|
defer inst-stream-f ( -- stack ) |
|
|
|
: part-stack-access { n stack -- } |
|
\ print _<stack><x>, x=inst-stream? n : maxdepth-currentdepth-n-1 |
|
." _" stack stack-pointer 2@ type |
|
stack stack-number @ { stack# } |
|
current-depth stack# th @ n + { access-depth } |
|
stack inst-stream-f = if |
|
access-depth |
|
else |
|
combined prim-stacks-in stack# th @ |
|
assert( dup max-depth stack# th @ = ) |
|
access-depth - 1- |
|
endif |
|
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 232 variable items
|
Line 333 variable items
|
: same-as-in? ( item -- f ) |
: same-as-in? ( item -- f ) |
\ f is true iff the offset and stack of item is the same as on input |
\ f is true iff the offset and stack of item is the same as on input |
>r |
>r |
r@ item-name 2@ items @ search-wordlist 0= |
r@ item-first @ if |
abort" bug" |
rdrop false exit |
|
endif |
|
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 250 variable items
|
Line 353 variable items
|
|
|
: 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 272 variable items
|
Line 376 variable items
|
: 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 320 does> ( item -- )
|
Line 427 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@ items @ 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 349 does> ( item -- )
|
Line 456 does> ( item -- )
|
['] declaration map-items ; |
['] declaration map-items ; |
|
|
: declarations ( -- ) |
: declarations ( -- ) |
wordlist dup items ! 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 371 does> ( item -- )
|
Line 478 does> ( item -- )
|
stack item item-stack ! |
stack item item-stack ! |
item declaration ; |
item declaration ; |
|
|
|
\ types pointed to by stacks for use in combined prims |
|
s" Cell" single 0 create-type cell-type |
|
s" Float" single 0 create-type float-type |
|
|
|
s" sp" save-mem cell-type s" (Cell)" make-stack data-stack |
|
s" fp" save-mem float-type s" " make-stack fp-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 |
|
' inst-in-index inst-stream stack-in-index-xt ! |
|
' inst-stream <is> inst-stream-f |
|
\ !! initialize stack-in and stack-out |
|
|
\ offset computation |
\ offset computation |
\ the leftmost (i.e. deepest) item has offset 0 |
\ the leftmost (i.e. deepest) item has offset 0 |
\ the rightmost item has the highest offset |
\ the rightmost item has the highest offset |
Line 423 does> ( item -- )
|
Line 542 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 473 does> ( item -- )
|
Line 592 does> ( item -- )
|
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 488 does> ( item -- )
|
Line 604 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 822 does> ( item -- )
|
\ spTOS = (Cell)_x_sp0; |
\ spTOS = (Cell)_x_sp0; |
\ NEXT_P2; |
\ NEXT_P2; |
|
|
|
: init-combined ( -- ) |
|
prim to 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 ! |
|
stack stack-type @ 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-type @ type-c-name 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 ; |
|
|
|
: 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 ( -- ) |
|
prim >r in-part on |
|
current-depth max-stacks cells erase |
|
num-combined @ 0 +do |
|
combined-prims i th @ output-part |
|
loop |
|
in-part off |
|
r> to prim ; |
|
|
|
: output-c-combined ( -- ) |
|
print-entry cr |
|
\ debugging messages just in parts |
|
." {" cr |
|
." DEF_CA" cr |
|
print-declarations-combined |
|
." NEXT_P0;" cr |
|
flush-tos |
|
fetches |
|
\ print-debug-args |
|
stack-pointer-updates |
|
output-parts |
|
output-c-tail |
|
." }" cr |
|
cr ; |
|
|
|
: output-forth-combined ( -- ) |
|
; |
|
|
\ the parser |
\ the parser |
|
|
Line 748 print-token !
|
Line 1000 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 803 bl 1+ maxchar ..
|
Line 1039 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 849 Variable c-flag
|
Line 1085 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 859 Variable c-flag
|
Line 1095 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! }} )) ?? |
)) ?? 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 ( -- ) |
|
|
(( ` = (( white ++ forth-ident )) ++ (( nl || eof )) |
(( {{ init-combined }} |
|
` = (( white ++ {{ start }} forth-ident {{ end add-prim }} )) ++ |
|
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 )) |
Line 894 warnings @ [IF]
|
Line 1132 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 ; |