--- gforth/prims2x.fs 2000/12/26 19:24:18 1.56 +++ gforth/prims2x.fs 2001/01/06 19:29:14 1.62 @@ -125,7 +125,7 @@ end-struct type% 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 +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 @@ -315,22 +315,23 @@ Variable c-flag {{ effect-out }} stack-items {{ effect-out-end ! }} )) <- stack-effect ( -- ) -(( {{ s" " doc 2! s" " forth-code 2! }} +(( {{ s" " doc 2! s" " forth-code 2! s" " wordset 2! }} (( {{ line @ name-line ! filename 2@ name-filename 2! }} {{ start }} forth-ident {{ end 2dup forth-name 2! c-name 2! }} white ++ ` ( white ** {{ start }} stack-effect {{ end stack-string 2! }} ` ) white ** - {{ start }} forth-ident {{ end wordset 2! }} white ** - (( {{ start }} c-ident {{ end c-name 2! }} )) ?? nl + (( {{ start }} forth-ident {{ end wordset 2! }} white ** + (( {{ start }} c-ident {{ end c-name 2! }} )) ?? + )) ?? nl )) - (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ?? - {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl ** nl )) ** {{ end c-code 2! skipsynclines on }} - (( ` : nl - {{ start }} (( nonl ++ nl )) ++ {{ end forth-code 2! }} + (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " white ** nl )) ?? + {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl ** nl white ** )) ** {{ end c-code 2! skipsynclines on }} + (( ` : white ** nl + {{ start }} (( nonl ++ nl white ** )) ++ {{ end forth-code 2! }} )) ?? {{ printprim }} (( nl || eof )) )) <- primitive ( -- ) -(( (( comment || primitive || nl )) ** eof )) +(( (( comment || primitive || nl white ** )) ** eof )) parser primitives2something warnings @ [IF] .( parser generated ok ) cr @@ -382,8 +383,8 @@ warnings @ [IF] >r ." FETCH_DCELL(" r@ item-name 2@ type ." , " - r@ item-in-index r@ item-stack @ 2dup stack-access - ." , " -1 under+ stack-access + r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access + ." , " -1 under+ ." (Cell)" stack-access ." );" cr rdrop ; @@ -671,6 +672,42 @@ does> ( item -- ) ." } else " 1 function-number +! ; + + + +: gen-arg-parm { item -- } + item item-stack @ inst-stream = if + ." , " item item-type @ type-c-name 2@ type space + item item-name 2@ type + endif ; + +: gen-args-parm ( -- ) + effect-in-end @ effect-in ?do + i gen-arg-parm + item% %size +loop ; + +: gen-arg-gen { item -- } + item item-stack @ inst-stream = if + ." genarg_" item item-type @ print-type-prefix + ." (ctp, " item item-name 2@ type ." );" cr + endif ; + +: gen-args-gen ( -- ) + effect-in-end @ effect-in ?do + i gen-arg-gen + item% %size +loop ; + +: output-gen ( -- ) + \ generate C code for generating VM instructions + ." /* " declarations ." */" cr + compute-offsets + ." void gen_" c-name 2@ type ." (Inst **ctp" gen-args-parm ." )" cr + ." {" cr + ." gen_inst(ctp, vm_prim[" function-number @ 0 .r ." ]);" cr + gen-args-gen + ." }" cr + 1 function-number +! ; + : stack-used? { stack -- f } stack stack-in @ stack stack-out @ or 0<> ; @@ -761,7 +798,7 @@ does> ( item -- ) : process-file ( addr u xt -- ) >r - 2dup filename 2! + save-mem 2dup filename 2! 0 function-number ! r/o open-file abort" cannot open file" warnings @ if