--- gforth/prims2x.fs 1995/12/26 17:35:37 1.18 +++ gforth/prims2x.fs 1998/12/11 22:54:27 1.36 @@ -1,6 +1,6 @@ \ converts primitives to, e.g., C code -\ Copyright (C) 1995 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -42,8 +42,12 @@ warnings off -require debugging.fs -[IFUNDEF] vocabulary include search-order.fs [THEN] +require search.fs +require extend.fs + +\ require interpretation.fs +\ require debugs.fs +[IFUNDEF] vocabulary include search.fs [THEN] [IFUNDEF] environment? include environ.fs [THEN] include gray.fs @@ -56,7 +60,7 @@ maxchar 1+ constant eof-char : read-whole-file ( c-addr1 file-id -- c-addr2 ) \ reads the contents of the file file-id puts it into memory at c-addr1 \ c-addr2 is the first address after the file block - >r dup -1 r> read-file throw + ; + >r dup $7fffffff r> read-file throw + ; variable rawinput \ pointer to next character to be scanned variable endrawinput \ pointer to the end of the input (the char after the last) @@ -65,9 +69,32 @@ variable line \ line number of char poin 1 line ! 2variable filename \ filename of original input file 0 0 filename 2! +2variable f-comment +0 0 f-comment 2! variable skipsynclines \ are sync lines ("#line ...") invisible to the parser? skipsynclines on +Variable flush-comment flush-comment off + +: ?flush-comment + flush-comment @ 0= ?EXIT + f-comment 2@ nip + IF cr f-comment 2@ 2 /string 1- + dup IF + 2dup s" -" compare 0= + IF + flush-comment @ 1 = + IF ." #else" + ELSE ." [ELSE]" THEN + ELSE + flush-comment @ 1 = + IF ." #ifdef HAS_" bounds ?DO I c@ toupper emit LOOP + ELSE ." has? " type ." [IF]" THEN + THEN cr + ELSE flush-comment @ 1 = IF ." #endif" ELSE ." [THEN]" THEN + cr THEN + 0 0 f-comment 2! THEN ; + : start ( -- addr ) cookedinput @ ; @@ -116,6 +143,7 @@ variable name-line 2variable last-name-filename variable primitive-number -10 primitive-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 @@ -164,7 +192,7 @@ print-token ! 0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr ) dup c@ bl = if char+ dup c@ [char] " <> abort" sync line syntax" - char+ dup 100 [char] " scan drop swap 2dup - filename 2! + char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2! char+ endif dup c@ nl-char <> abort" sync line syntax" @@ -203,7 +231,7 @@ print-token ! : ` ( -- terminal ) ( use: ` c ) ( creates anonymous terminal for the character c ) - [compile] ascii singleton ['] ?nextchar make-terminal ; + char singleton ['] ?nextchar make-terminal ; char a char z .. char A char Z .. union char _ singleton union charclass letter char 0 char 9 .. charclass digit @@ -223,7 +251,8 @@ eof-char singleton charclass eof nowhite ++ <- name ( -- ) -(( ` \ nonl ** nl +(( {{ ?flush-comment start }} ` \ nonl ** nl {{ end + 2dup 2 min s" \+" compare 0= IF f-comment 2! ELSE 2drop THEN }} )) <- comment ( -- ) (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-in-end ! }} @@ -247,7 +276,7 @@ nowhite ++ (( nl || eof )) )) <- primitive ( -- ) -(( (( primitive {{ printprim }} )) ** eof )) +(( (( primitive {{ printprim }} )) ** eof )) parser primitives2something warnings @ [IF] .( parser generated ok ) cr @@ -305,11 +334,11 @@ constant type-description : fetch-double ( item -- ) >r - r@ item-name 2@ type - ." = ({Double_Store _d; _d.cells.low = " + ." FETCH_DCELL(" + r@ item-name 2@ type ." , " r@ item-d-offset @ dup effect-in-size 2@ data-stack-access - ." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access - ." ; _d.dcell;});" cr + ." , " 1+ effect-in-size 2@ data-stack-access + ." );" cr rdrop ; : fetch-float ( item -- ) @@ -338,6 +367,10 @@ constant type-description \ true if item has the same offset as the input TOS item-d-offset @ 1+ effect-in-size 2@ drop = ; +: is-out-tos? ( item -- f ) +\ true if item has the same offset as the input TOS + item-d-offset @ 1+ effect-out-size 2@ drop = ; + : really-store-single ( item -- ) >r r@ item-d-offset @ effect-out-size 2@ data-stack-access ." = (Cell)" @@ -348,7 +381,7 @@ constant type-description >r r@ d-same-as-in? if - r@ is-in-tos? + r@ is-in-tos? r@ is-out-tos? xor if ." IF_TOS(" r@ really-store-single ." );" cr endif @@ -360,10 +393,10 @@ constant type-description : store-double ( item -- ) \ !! store optimization is not performed, because it is not yet needed >r - ." {Double_Store _d; _d.dcell = " r@ item-name 2@ type ." ; " - r@ item-d-offset @ dup effect-out-size 2@ data-stack-access - ." = _d.cells.low; " 1+ effect-out-size 2@ data-stack-access - ." = _d.cells.high;}" cr + ." STORE_DCELL(" r@ item-name 2@ type ." , " + r@ item-d-offset @ dup effect-out-size 2@ data-stack-access + ." , " 1+ effect-out-size 2@ data-stack-access + ." );" cr rdrop ; : f-same-as-in? ( item -- f ) @@ -447,7 +480,7 @@ s" DFloat *" single-type starts-with df_ s" SFloat *" single-type starts-with sf_ s" Xt" single-type starts-with xt s" WID" single-type starts-with wid -s" F83Name *" single-type starts-with f83name +s" struct F83Name *" single-type starts-with f83name set-current @@ -567,7 +600,8 @@ set-current i item-name 2@ type space item-descr +loop ; -: output-c ( -- ) +: output-c ( -- ) 1 flush-comment ! + ?flush-comment ." I_" c-name 2@ type ." : /* " forth-name 2@ type ." ( " stack-string 2@ type ." ) */" cr ." /* " doc 2@ type ." */" cr ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging @@ -591,22 +625,63 @@ set-current cr ; -: output-label ( -- ) - ." &&I_" c-name 2@ type ." ," cr ; - -: output-alias ( -- ) - primitive-number @ . ." alias " forth-name 2@ type cr - -1 primitive-number +! ; - -: output-forth ( -- ) - forth-code @ 0= - IF output-alias - ELSE ." : " forth-name 2@ type ." ( " - effect-in effect-in-end @ .stack-list ." -- " - effect-out effect-out-end @ .stack-list ." )" cr - forth-code 2@ type cr - -1 primitive-number +! - THEN ; +: output-funclabel ( -- ) + 1 function-number +! + ." &I_" c-name 2@ type ." ," cr ; + +: output-forthname ( -- ) + 1 function-number +! + '" emit forth-name 2@ type '" emit ." ," cr ; + +: output-c-func ( -- ) + 1 function-number +! + ." void I_" c-name 2@ type ." () /* " forth-name 2@ type + ." ( " stack-string 2@ type ." ) */" cr + ." /* " doc 2@ type ." */" cr + ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr + \ debugging + ." {" cr + ." DEF_CA" cr + declarations + compute-offsets \ for everything else + ." NEXT_P0;" cr + flush-tos + fetches + stack-pointer-updates + ." {" cr + ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr + c-code 2@ type + ." }" cr + ." NEXT_P1;" cr + stores + fill-tos + ." NEXT_P2;" cr + ." }" cr + cr ; + +: output-label ( -- ) 1 flush-comment ! + ?flush-comment + ." [" -2 primitive-number @ - 0 .r ." ] " + ." (Label)&&I_" c-name 2@ type ." ," cr + -1 primitive-number +! ; + +: output-alias ( -- ) flush-comment on + ?flush-comment + primitive-number @ . ." alias " forth-name 2@ type cr + -1 primitive-number +! ; + +: output-forth ( -- ) flush-comment on + ?flush-comment + forth-code @ 0= + IF \ output-alias + \ this is bad for ec: an alias is compiled if tho word does not exist! + \ JAW + ELSE ." : " forth-name 2@ type ." ( " + effect-in effect-in-end @ .stack-list ." -- " + effect-out effect-out-end @ .stack-list ." )" cr + forth-code 2@ type cr + -1 primitive-number +! + THEN ; : output-tag-file ( -- ) name-filename 2@ last-name-filename 2@ compare if @@ -640,8 +715,12 @@ set-current : process-file ( addr u xt -- ) >r 2dup filename 2! + 0 function-number ! r/o open-file abort" cannot open file" warnings @ if ." ------------ CUT HERE -------------" cr endif r> primfilter ; +: process ( xt -- ) + bl word count rot + process-file ;