version 1.78, 2001/02/07 09:58:46
|
version 1.95, 2001/04/30 13:48:56
|
Line 40
|
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. |
|
|
|
\ 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 59 warnings off
|
\ different directory with the wordlibraries) |
\ different directory with the wordlibraries) |
include ./search.fs |
include ./search.fs |
include ./extend.fs |
include ./extend.fs |
[THEN] |
|
include ./stuff.fs |
include ./stuff.fs |
|
[THEN] |
|
|
[IFUNDEF] environment? |
[IFUNDEF] environment? |
include ./environ.fs |
include ./environ.fs |
Line 90 skipsynclines on
|
Line 100 skipsynclines on
|
loop |
loop |
drop ; |
drop ; |
|
|
|
: insert-wordlist { c-addr u wordlist xt -- } |
|
\ adds name "addr u" to wordlist using defining word xt |
|
\ xt may cause additional stack effects |
|
get-current >r wordlist set-current |
|
c-addr u nextname xt execute |
|
r> set-current ; |
|
|
: start ( -- addr ) |
: start ( -- addr ) |
cookedinput @ ; |
cookedinput @ ; |
|
|
Line 120 skipsynclines on
|
Line 137 skipsynclines on
|
variable output \ xt ( -- ) of output word for simple primitives |
variable output \ xt ( -- ) of output word for simple primitives |
variable output-combined \ xt ( -- ) of output word for combined primitives |
variable output-combined \ xt ( -- ) of output word for combined primitives |
|
|
: printprim ( -- ) |
|
output @ execute ; |
|
|
|
struct% |
struct% |
cell% field stack-number \ the number of this stack |
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% field stack-type \ name for default type of stack items |
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 ) |
end-struct stack% |
end-struct stack% |
|
|
Line 156 create stacks max-stacks cells allot \ a
|
Line 169 create stacks max-stacks cells allot \ a
|
: 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 type addr-cast u2 "stack-name" -- ) |
: make-stack ( addr-ptr u1 type "stack-name" -- ) |
|
next-stack-number @ max-stacks < s" too many stacks" ?print-error |
create stack% %allot >r |
create stack% %allot >r |
r@ stacks next-stack-number @ th ! |
r@ stacks next-stack-number @ th ! |
next-stack-number @ r@ stack-number ! 1 next-stack-number +! |
next-stack-number @ r@ stack-number ! |
save-mem r@ stack-cast 2! |
1 next-stack-number +! |
r@ stack-type ! |
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 ! ; |
|
|
|
: map-stacks { xt -- } |
|
\ perform xt for all stacks except inst-stream |
|
next-stack-number @ 1 +do |
|
stacks i th @ xt execute |
|
loop ; |
|
|
\ stack items |
\ stack items |
|
|
: init-item ( addr u addr1 -- ) |
: init-item ( addr u addr1 -- ) |
Line 194 struct%
|
Line 214 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-num \ ordinal number |
cell% field prim-items-wordlist \ unique items |
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 |
Line 208 end-struct prim%
|
Line 229 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 |
|
|
|
table constant combinations |
|
\ the keys are the sequences of pointers to primitives |
|
|
|
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 |
|
|
: create-prim ( prim -- ) |
: create-prim ( prim -- ) |
get-current >r |
dup prim-name 2@ primitives ['] constant insert-wordlist ; |
primitives set-current |
|
dup prim-name 2@ nextname constant |
|
r> set-current ; |
|
|
|
: stack-in ( stack -- addr ) |
: stack-in ( stack -- addr ) |
\ address of number of stack items in effect in |
\ address of number of stack items in effect in |
Line 242 Variable function-number 0 function-numb
|
Line 274 Variable function-number 0 function-numb
|
: 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 254 Variable function-number 0 function-numb
|
Line 285 Variable function-number 0 function-numb
|
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 ) |
Line 375 wordlist constant prefixes
|
Line 431 wordlist constant prefixes
|
rdrop ; |
rdrop ; |
|
|
: type-prefix ( xt1 xt2 n stack "prefix" -- ) |
: type-prefix ( xt1 xt2 n stack "prefix" -- ) |
create-type |
get-current >r prefixes set-current |
|
create-type r> set-current |
does> ( item -- ) |
does> ( item -- ) |
\ initialize item |
\ initialize item |
{ item typ } |
{ item typ } |
Line 401 does> ( item -- )
|
Line 458 does> ( item -- )
|
endif |
endif |
-1 s+loop |
-1 s+loop |
\ we did not find a type, abort |
\ we did not find a type, abort |
true abort" unknown prefix" ; |
false s" unknown prefix" ?print-error ; |
|
|
: declaration ( item -- ) |
: declaration ( item -- ) |
dup item-name 2@ execute-prefix ; |
dup item-name 2@ execute-prefix ; |
Line 425 does> ( item -- )
|
Line 482 does> ( item -- )
|
prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ; |
prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ; |
|
|
: stack-prefix ( stack "prefix" -- ) |
: stack-prefix ( stack "prefix" -- ) |
|
get-current >r prefixes set-current |
name tuck nextname create ( stack length ) 2, |
name tuck nextname create ( stack length ) 2, |
|
r> set-current |
does> ( item -- ) |
does> ( item -- ) |
2@ { item stack prefix-length } |
2@ { item stack prefix-length } |
item item-name 2@ prefix-length /string item item-name 2! |
item item-name 2@ prefix-length /string item item-name 2! |
Line 433 does> ( item -- )
|
Line 492 does> ( item -- )
|
item declaration ; |
item declaration ; |
|
|
\ types pointed to by stacks for use in combined prims |
\ types pointed to by stacks for use in combined prims |
s" Cell" single 0 create-type cell-type |
\ !! output-c-combined shouldn't use these names! |
s" Float" single 0 create-type float-type |
: stack-type-name ( addr u "name" -- ) |
|
single 0 create-type ; |
|
|
|
wordlist constant type-names \ this is here just to meet the requirement |
|
\ that a type be a word; it is never used for lookup |
|
|
|
: stack ( "name" "stack-pointer" "type" -- ) |
|
\ define stack |
|
name { d: stack-name } |
|
name { d: stack-pointer } |
|
name { d: stack-type } |
|
get-current type-names set-current |
|
stack-type 2dup nextname stack-type-name |
|
set-current |
|
stack-pointer lastxt >body stack-name nextname make-stack ; |
|
|
s" sp" save-mem cell-type s" (Cell)" make-stack data-stack |
stack inst-stream IP Cell |
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-in-index inst-stream stack-in-index-xt ! |
|
' inst-stream <is> inst-stream-f |
\ !! initialize stack-in and stack-out |
\ !! initialize stack-in and stack-out |
|
|
\ offset computation |
\ offset computation |
Line 463 s" IP" save-mem cell-type s" error don'
|
Line 534 s" IP" save-mem cell-type s" error don'
|
dup stack-in off stack-out off ; |
dup stack-in off stack-out off ; |
|
|
: compute-offsets ( -- ) |
: compute-offsets ( -- ) |
data-stack clear-stack fp-stack clear-stack return-stack clear-stack |
['] clear-stack map-stacks |
inst-stream clear-stack |
inst-stream clear-stack |
prim prim-effect-in prim prim-effect-in-end @ ['] compute-offset-in map-items |
prim prim-effect-in prim prim-effect-in-end @ ['] compute-offset-in map-items |
prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items |
prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items |
inst-stream stack-out @ 0<> abort" # can only be on the input side" ; |
inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ; |
|
|
|
: process-simple ( -- ) |
|
prim prim { W^ key } key cell |
|
combinations ['] constant insert-wordlist |
|
declarations compute-offsets |
|
output @ execute ; |
|
|
: flush-a-tos { stack -- } |
: flush-a-tos { stack -- } |
stack stack-out @ 0<> stack stack-in @ 0= and |
stack stack-out @ 0<> stack stack-in @ 0= and |
Line 477 s" IP" save-mem cell-type s" error don'
|
Line 554 s" IP" save-mem cell-type s" error don'
|
endif ; |
endif ; |
|
|
: flush-tos ( -- ) |
: flush-tos ( -- ) |
data-stack flush-a-tos |
['] flush-a-tos map-stacks ; |
fp-stack flush-a-tos |
|
return-stack flush-a-tos ; |
|
|
|
: fill-a-tos { stack -- } |
: fill-a-tos { stack -- } |
stack stack-out @ 0= stack stack-in @ 0<> and |
stack stack-out @ 0= stack stack-in @ 0<> and |
Line 490 s" IP" save-mem cell-type s" error don'
|
Line 565 s" IP" save-mem cell-type s" error don'
|
|
|
: fill-tos ( -- ) |
: fill-tos ( -- ) |
\ !! inst-stream for prefetching? |
\ !! inst-stream for prefetching? |
fp-stack fill-a-tos |
['] fill-a-tos map-stacks ; |
data-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 ; |
Line 514 s" IP" save-mem cell-type s" error don'
|
Line 587 s" IP" save-mem cell-type s" error don'
|
|
|
: stack-pointer-updates ( -- ) |
: stack-pointer-updates ( -- ) |
inst-pointer-update |
inst-pointer-update |
data-stack stack-pointer-update |
['] stack-pointer-update map-stacks ; |
fp-stack stack-pointer-update |
|
return-stack stack-pointer-update ; |
|
|
|
: store ( item -- ) |
: store ( item -- ) |
\ f is true if the item should be stored |
\ f is true if the item should be stored |
Line 526 s" IP" save-mem cell-type s" error don'
|
Line 597 s" IP" save-mem cell-type s" error don'
|
: stores ( -- ) |
: stores ( -- ) |
prim prim-effect-out prim prim-effect-out-end @ ['] store map-items ; |
prim prim-effect-out prim prim-effect-out-end @ ['] store map-items ; |
|
|
|
: print-debug-arg { item -- } |
|
." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); " |
|
." printarg_" item item-type @ print-type-prefix |
|
." (" item item-name 2@ type ." );" cr ; |
|
|
|
: print-debug-args ( -- ) |
|
." #ifdef VM_DEBUG" cr |
|
." if (vm_debug) {" cr |
|
prim prim-effect-in prim prim-effect-in-end @ ['] print-debug-arg map-items |
|
\ ." fputc('\n', vm_out);" cr |
|
." }" cr |
|
." #endif" cr ; |
|
|
|
: print-debug-result { item -- } |
|
item item-first @ if |
|
item print-debug-arg |
|
endif ; |
|
|
|
: print-debug-results ( -- ) |
|
cr |
|
." #ifdef VM_DEBUG" cr |
|
." if (vm_debug) {" cr |
|
." fputs(" quote ." -- " quote ." , vm_out); " |
|
prim prim-effect-out prim prim-effect-out-end @ ['] print-debug-result map-items |
|
." fputc('\n', vm_out);" cr |
|
." }" cr |
|
." #endif" cr ; |
|
|
|
: output-super-end ( -- ) |
|
prim prim-c-code 2@ s" SET_IP" search if |
|
." SUPER_END;" cr |
|
endif |
|
2drop ; |
|
|
: output-c-tail ( -- ) |
: output-c-tail ( -- ) |
\ the final part of the generated C code |
\ the final part of the generated C code |
|
output-super-end |
|
print-debug-results |
." NEXT_P1;" cr |
." NEXT_P1;" cr |
stores |
stores |
fill-tos |
fill-tos |
." NEXT_P2;" cr ; |
." NEXT_P2;" ; |
|
|
: type-c ( c-addr u -- ) |
: type-c-code ( c-addr u xt -- ) |
\ like TYPE, but replaces "TAIL;" with tail code |
\ like TYPE, but replaces "TAIL;" with tail code produced by xt |
|
{ xt } |
begin ( c-addr1 u1 ) |
begin ( c-addr1 u1 ) |
2dup s" TAIL;" search |
2dup s" TAIL;" search |
while ( c-addr1 u1 c-addr3 u3 ) |
while ( c-addr1 u1 c-addr3 u3 ) |
2dup 2>r drop nip over - type |
2dup 2>r drop nip over - type |
output-c-tail |
xt execute |
2r> 5 /string |
2r> 5 /string |
\ !! resync #line missing |
\ !! resync #line missing |
repeat |
repeat |
2drop type ; |
2drop type ; |
|
|
: print-debug-arg { item -- } |
|
." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); " |
|
." printarg_" item item-type @ print-type-prefix |
|
." (" item item-name 2@ type ." );" cr ; |
|
|
|
: print-debug-args ( -- ) |
|
." #ifdef VM_DEBUG" cr |
|
." if (vm_debug) {" cr |
|
prim prim-effect-in prim prim-effect-in-end @ ['] print-debug-arg map-items |
|
." fputc('\n', vm_out);" cr |
|
." }" cr |
|
." #endif" cr ; |
|
|
|
: print-entry ( -- ) |
: print-entry ( -- ) |
." I_" prim prim-c-name 2@ type ." :" ; |
." I_" prim prim-c-name 2@ type ." :" ; |
|
|
Line 575 s" IP" save-mem cell-type s" error don'
|
Line 670 s" IP" save-mem cell-type s" error don'
|
stack-pointer-updates |
stack-pointer-updates |
." {" cr |
." {" cr |
." #line " c-line @ . quote c-filename 2@ type quote cr |
." #line " c-line @ . quote c-filename 2@ type quote cr |
prim prim-c-code 2@ type-c |
prim prim-c-code 2@ ['] output-c-tail type-c-code |
." }" cr |
." }" cr |
output-c-tail |
output-c-tail |
." }" cr |
." }" cr |
Line 599 s" IP" save-mem cell-type s" error don'
|
Line 694 s" IP" save-mem cell-type s" error don'
|
." fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr |
." fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr |
disasm-args |
disasm-args |
." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr |
." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr |
." } else " ; |
." goto _endif_;" cr |
|
." }" cr ; |
|
|
|
: output-profile ( -- ) |
|
\ generate code for postprocessing the VM block profile stuff |
|
." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr |
|
." add_inst(b, " quote prim prim-name 2@ type quote ." );" cr |
|
." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr |
|
prim prim-c-code 2@ s" SET_IP" search nip nip |
|
prim prim-c-code 2@ s" SUPER_END" search nip nip or if |
|
." return;" cr |
|
else |
|
." goto _endif_;" cr |
|
endif |
|
." }" cr ; |
|
|
: gen-arg-parm { item -- } |
: gen-arg-parm { item -- } |
item item-stack @ inst-stream = if |
item item-stack @ inst-stream = if |
Line 636 s" IP" save-mem cell-type s" error don'
|
Line 745 s" IP" save-mem cell-type s" error don'
|
: output-forthname ( -- ) |
: output-forthname ( -- ) |
'" emit prim prim-name 2@ type '" emit ." ," cr ; |
'" emit prim prim-name 2@ type '" emit ." ," cr ; |
|
|
: output-c-func ( -- ) |
\ : output-c-func ( -- ) |
\ used for word libraries |
\ \ used for word libraries |
." Cell * I_" prim prim-c-name 2@ type ." (Cell *SP, Cell **FP) /* " prim prim-name 2@ type |
\ ." Cell * I_" prim prim-c-name 2@ type ." (Cell *SP, Cell **FP) /* " prim prim-name 2@ type |
." ( " prim prim-stack-string 2@ type ." ) */" cr |
\ ." ( " 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 |
\ ." NAME(" quote prim prim-name 2@ type quote ." )" cr |
\ debugging |
\ \ debugging |
." {" cr |
\ ." {" cr |
print-declarations |
\ print-declarations |
inst-stream stack-used? IF ." Cell *ip=IP;" cr THEN |
\ \ !! don't know what to do about that |
data-stack stack-used? IF ." Cell *sp=SP;" cr THEN |
\ inst-stream stack-used? IF ." Cell *ip=IP;" cr THEN |
fp-stack stack-used? IF ." Cell *fp=*FP;" cr THEN |
\ data-stack stack-used? IF ." Cell *sp=SP;" cr THEN |
return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN |
\ fp-stack stack-used? IF ." Cell *fp=*FP;" cr THEN |
flush-tos |
\ return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN |
fetches |
\ flush-tos |
stack-pointer-updates |
\ fetches |
fp-stack stack-used? IF ." *FP=fp;" cr THEN |
\ stack-pointer-updates |
." {" cr |
\ fp-stack stack-used? IF ." *FP=fp;" cr THEN |
." #line " c-line @ . quote c-filename 2@ type quote cr |
\ ." {" cr |
prim prim-c-code 2@ type |
\ ." #line " c-line @ . quote c-filename 2@ type quote cr |
." }" cr |
\ prim prim-c-code 2@ type |
stores |
\ ." }" cr |
fill-tos |
\ stores |
." return (sp);" cr |
\ fill-tos |
." }" cr |
\ ." return (sp);" cr |
cr ; |
\ ." }" cr |
|
\ cr ; |
|
|
: output-label ( -- ) |
: output-label ( -- ) |
." (Label)&&I_" prim prim-c-name 2@ type ." ," cr ; |
." (Label)&&I_" prim prim-c-name 2@ type ." ," cr ; |
Line 698 s" IP" save-mem cell-type s" error don'
|
Line 808 s" IP" save-mem cell-type s" error don'
|
|
|
[IFDEF] documentation |
[IFDEF] documentation |
: register-doc ( -- ) |
: register-doc ( -- ) |
get-current documentation set-current |
prim prim-name 2@ documentation ['] create insert-wordlist |
prim prim-name 2@ nextname create |
|
prim prim-name 2@ 2, |
prim prim-name 2@ 2, |
prim prim-stack-string 2@ condition-stack-effect 2, |
prim prim-stack-string 2@ condition-stack-effect 2, |
prim prim-wordset 2@ 2, |
prim prim-wordset 2@ 2, |
prim prim-c-name 2@ condition-pronounciation 2, |
prim prim-c-name 2@ condition-pronounciation 2, |
prim prim-doc 2@ 2, |
prim prim-doc 2@ 2, ; |
set-current ; |
|
[THEN] |
[THEN] |
|
|
|
|
Line 775 s" IP" save-mem cell-type s" error don'
|
Line 883 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 848 create min-depth max-stacks cells al
|
Line 949 create min-depth max-stacks cells al
|
loop ; |
loop ; |
|
|
: process-combined ( -- ) |
: process-combined ( -- ) |
|
combined combined-prims num-combined @ cells |
|
combinations ['] constant insert-wordlist |
|
combined-prims num-combined @ 1- th ( last-part ) |
|
@ prim-c-code 2@ prim prim-c-code 2! \ used by output-super-end |
prim compute-effects |
prim compute-effects |
prim init-effects |
prim init-effects |
output-combined perform ; |
output-combined perform ; |
Line 856 create min-depth max-stacks cells al
|
Line 961 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 970 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 ( -- ) |
|
print-debug-results |
|
stores ; |
|
|
|
: output-combined-tail ( -- ) |
|
part-output-c-tail |
|
prim >r combined to prim |
|
in-part @ >r in-part off |
|
output-c-tail |
|
r> in-part ! r> to prim ; |
|
|
|
: 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@ ['] output-combined-tail type-c-code |
|
." }" 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 891 create min-depth max-stacks cells al
|
Line 1027 create min-depth max-stacks cells al
|
cr ; |
cr ; |
|
|
: output-forth-combined ( -- ) |
: output-forth-combined ( -- ) |
; |
; |
|
|
|
|
|
\ peephole optimization rules |
|
|
|
\ in order for this to work as intended, shorter combinations for each |
|
\ length must be present, and the longer combinations must follow |
|
\ shorter ones (this restriction may go away in the future). |
|
|
|
: output-peephole ( -- ) |
|
combined-prims num-combined @ 1- cells combinations search-wordlist |
|
s" the prefix for this combination must be defined earlier" ?print-error |
|
." {" |
|
execute prim-num @ 5 .r ." ," |
|
combined-prims num-combined @ 1- th @ prim-num @ 5 .r ." ," |
|
combined prim-num @ 5 .r ." }, /* " |
|
combined prim-c-name 2@ type ." */" |
|
cr ; |
|
|
|
: output-forth-peephole ( -- ) |
|
combined-prims num-combined @ 1- cells combinations search-wordlist |
|
s" the prefix for this combination must be defined earlier" ?print-error |
|
execute prim-num @ 5 .r |
|
combined-prims num-combined @ 1- th @ prim-num @ 5 .r |
|
combined prim-num @ 5 .r ." prim, \ " |
|
combined prim-c-name 2@ type |
|
cr ; |
|
|
|
|
\ the parser |
\ the parser |
|
|
Line 926 print-token !
|
Line 1089 print-token !
|
endif |
endif |
0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr ) |
0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr ) |
dup c@ bl = if |
dup c@ bl = if |
char+ dup c@ [char] " <> abort" sync line syntax" |
char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error |
char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2! |
char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2! |
char+ |
char+ |
endif |
endif |
dup c@ nl-char <> abort" sync line syntax" |
dup c@ nl-char <> 0= s" sync line syntax" ?print-error |
skipsynclines @ if |
skipsynclines @ if |
dup char+ rawinput ! |
dup char+ rawinput ! |
rawinput @ c@ cookedinput @ c! |
rawinput @ c@ cookedinput @ c! |
Line 976 bl 1+ maxchar ..
|
Line 1139 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 1185 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 1199 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 +! }} |
)) ?? {{ process-simple }} |
(( 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 }} white ** )) ++ |
(( 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! |
|
function-number @ prim prim-num ! |
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 )) {{ 1 function-number +! }} |
)) <- primitive ( -- ) |
)) <- primitive ( -- ) |
|
|
(( (( comment || primitive || nl white ** )) ** eof )) |
(( (( comment || primitive || nl white ** )) ** eof )) |
Line 1062 warnings @ [IF]
|
Line 1226 warnings @ [IF]
|
.( parser generated ok ) cr |
.( parser generated ok ) cr |
[THEN] |
[THEN] |
|
|
|
|
|
\ run with out of box gforth 0.5.0 |
|
[IFUNDEF] slurp-file |
|
: slurp-file ( c-addr1 u1 -- c-addr2 u2 ) |
|
\ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents |
|
r/o bin open-file throw >r |
|
r@ file-size throw abort" file too large" |
|
dup allocate throw swap |
|
2dup r@ read-file throw over <> abort" could not read whole file" |
|
r> close-file throw ; |
|
[THEN] |
|
|
: primfilter ( addr u -- ) |
: primfilter ( addr u -- ) |
\ process the string at addr u |
\ process the string at addr u |
over dup rawinput ! dup line-start ! cookedinput ! |
over dup rawinput ! dup line-start ! cookedinput ! |