--- gforth/prims2x.fs 2001/03/18 18:52:55 1.94 +++ gforth/prims2x.fs 2002/06/02 15:46:16 1.106 @@ -53,21 +53,14 @@ warnings off -[IFUNDEF] vocabulary \ we are executed just with kernel image - \ load the rest that is needed - \ (require fails because this file is needed from a - \ different directory with the wordlibraries) -include ./search.fs -include ./extend.fs -include ./stuff.fs -[THEN] - -[IFUNDEF] environment? -include ./environ.fs +[IFUNDEF] try +include startup.fs [THEN] : struct% struct ; \ struct is redefined in gray +warnings off + include ./gray.fs 32 constant max-effect \ number of things on one side of a stack effect @@ -319,26 +312,26 @@ defer inst-stream-f ( -- stack ) item-stack @ stack-type @ type-c-name 2@ ; : fetch-single ( item -- ) - \ fetch a single stack item from its stack - >r - r@ item-name 2@ type - ." = vm_" r@ item-stack-type-name type - ." 2" r@ item-type @ print-type-prefix ." (" - r@ item-in-index r@ item-stack @ stack-access - ." );" cr - rdrop ; + \ fetch a single stack item from its stack + >r + ." vm_" r@ item-stack-type-name type + ." 2" r@ item-type @ print-type-prefix ." (" + r@ item-in-index r@ item-stack @ stack-access ." ," + r@ item-name 2@ type + ." );" cr + rdrop ; : fetch-double ( item -- ) - \ fetch a double stack item from its stack - >r - ." vm_two" - r@ item-stack-type-name type ." 2" - r@ item-type @ print-type-prefix ." (" - r@ item-name 2@ type ." , " - r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access - ." , " -1 under+ ." (Cell)" stack-access - ." );" cr - rdrop ; + \ fetch a double stack item from its stack + >r + ." vm_two" + r@ item-stack-type-name type ." 2" + r@ item-type @ print-type-prefix ." (" + r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access + ." , " -1 under+ ." (Cell)" stack-access + ." , " r@ item-name 2@ type + ." )" cr + rdrop ; : same-as-in? ( item -- f ) \ f is true iff the offset and stack of item is the same as on input @@ -362,12 +355,13 @@ defer inst-stream-f ( -- stack ) >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ; : really-store-single ( item -- ) - >r - r@ item-out-index r@ item-stack @ stack-access ." = vm_" - r@ item-type @ print-type-prefix ." 2" - r@ item-stack-type-name type ." (" - r@ item-name 2@ type ." );" - rdrop ; + >r + ." vm_" + r@ item-type @ print-type-prefix ." 2" + r@ item-stack-type-name type ." (" + r@ item-name 2@ type ." ," + r@ item-out-index r@ item-stack @ stack-access ." );" + rdrop ; : store-single ( item -- ) >r @@ -392,7 +386,7 @@ defer inst-stream-f ( -- stack ) r@ item-name 2@ type ." , " r@ item-out-index r@ item-stack @ 2dup stack-access ." , " -1 under+ stack-access - ." );" cr + ." )" cr rdrop ; : single ( -- xt1 xt2 n ) @@ -430,7 +424,7 @@ wordlist constant prefixes stack r@ type-stack ! rdrop ; -: type-prefix ( xt1 xt2 n stack "prefix" -- ) +: type-prefix ( addr u xt1 xt2 n stack "prefix" -- ) get-current >r prefixes set-current create-type r> set-current does> ( item -- ) @@ -654,7 +648,7 @@ stack inst-stream IP Cell 2drop type ; : print-entry ( -- ) - ." I_" prim prim-c-name 2@ type ." :" ; + ." LABEL(" prim prim-c-name 2@ type ." ):" ; : output-c ( -- ) print-entry ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr @@ -680,9 +674,11 @@ stack inst-stream IP Cell : disasm-arg { item -- } item item-stack @ inst-stream = if ." fputc(' ', vm_out); " - ." printarg_" item item-type @ print-type-prefix + \ !! change this to first convert args to the right type and + \ then print them + ." /* printarg_" item item-type @ print-type-prefix ." ((" item item-type @ type-c-name 2@ type ." )" - ." ip[" item item-offset @ 1+ 0 .r ." ]);" cr + ." ip[" item item-offset @ 1+ 0 .r ." ]); */" cr endif ; : disasm-args ( -- ) @@ -690,7 +686,7 @@ stack inst-stream IP Cell : output-disasm ( -- ) \ generate code for disassembling VM instructions - ." if (ip[0] == prim[" function-number @ 0 .r ." ]) {" cr + ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr ." fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr disasm-args ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr @@ -700,7 +696,7 @@ stack inst-stream IP Cell : 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 + ." 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 @@ -710,6 +706,30 @@ stack inst-stream IP Cell endif ." }" cr ; +: output-profile-combined ( -- ) + \ generate code for postprocessing the VM block profile stuff + ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr + num-combined @ 0 +do + ." add_inst(b, " quote + combined-prims i th @ prim-name 2@ type + quote ." );" cr + loop + ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr + combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SET_IP" search nip nip + combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SUPER_END" search nip nip or if + ." return;" cr + else + ." goto _endif_;" cr + endif + ." }" cr ; + +: output-superend ( -- ) + \ output flag specifying whether the current word ends a dynamic superinst + prim prim-c-code 2@ s" SET_IP" search nip nip + prim prim-c-code 2@ s" SUPER_END" search nip nip or 0<> + prim prim-c-code 2@ s" SUPER_CONTINUE" search nip nip 0= and + negate 0 .r ." , /* " prim prim-name 2@ type ." */" cr ; + : gen-arg-parm { item -- } item item-stack @ inst-stream = if ." , " item item-type @ type-c-name 2@ type space @@ -774,7 +794,7 @@ stack inst-stream IP Cell \ cr ; : output-label ( -- ) - ." (Label)&&I_" prim prim-c-name 2@ type ." ," cr ; + ." INST_ADDR(" prim prim-c-name 2@ type ." )," cr ; : output-alias ( -- ) ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ; @@ -806,6 +826,11 @@ stack inst-stream IP Cell name-line @ 0 .r ." ,0" cr ; +: output-vi-tag ( -- ) + name-filename 2@ type #tab emit + prim prim-name 2@ type #tab emit + ." /^" prim prim-name 2@ type ." *(/" cr ; + [IFDEF] documentation : register-doc ( -- ) prim prim-name 2@ documentation ['] create insert-wordlist @@ -1183,7 +1208,13 @@ Variable c-flag THEN }} )) <- if-comment -(( (( eval-comment || forth-comment || c-comment || else-comment || if-comment )) ?? nonl ** )) <- comment-body +(( (( ` g || ` G )) {{ start }} nonl ** + {{ end + forth-flag @ IF ." group " type cr THEN + c-flag @ IF ." GROUP(" type ." )" cr THEN }} +)) <- group-comment + +(( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body (( ` \ comment-body nleof )) <- comment ( -- ) @@ -1217,6 +1248,7 @@ Variable c-flag 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 ++ + (( ` / white ** {{ start }} c-ident {{ end prim prim-c-name 2! }} white ** )) ?? (( simple-primitive || combined-primitive )) {{ 1 function-number +! }} )) <- primitive ( -- ) @@ -1226,6 +1258,18 @@ warnings @ [IF] .( parser generated ok ) cr [THEN] + +\ run with gforth-0.5.0 (slurp-file is missing) +[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 -- ) \ process the string at addr u over dup rawinput ! dup line-start ! cookedinput !