--- gforth/prims2x.fs 1998/05/31 19:29:23 1.31 +++ gforth/prims2x.fs 1999/05/17 13:13:27 1.44 @@ -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,14 +42,19 @@ warnings off -include search.fs -include extend.fs +[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 +[THEN] + +[IFUNDEF] environment? +include ./environ.fs +[THEN] -\ require interpretation.fs -\ require debugs.fs -[IFUNDEF] vocabulary include search.fs [THEN] -[IFUNDEF] environment? include environ.fs [THEN] -include gray.fs +include ./gray.fs 100 constant max-effect \ number of things on one side of a stack effect 255 constant maxchar @@ -57,11 +62,6 @@ maxchar 1+ constant eof-char #tab constant tab-char #lf constant nl-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 $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) variable cookedinput \ pointer to the next char to be parsed @@ -74,13 +74,6 @@ variable line \ line number of char poin 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 type 0 0 f-comment 2! THEN ; - : start ( -- addr ) cookedinput @ ; @@ -237,9 +230,40 @@ eof-char singleton charclass eof nowhite ++ <- name ( -- ) -(( {{ ?flush-comment start }} ` \ nonl ** nl {{ end - 2dup 2 min s" \+" compare 0= IF f-comment 2! ELSE 2drop THEN }} -)) <- comment ( -- ) +Variable forth-flag +Variable c-flag + +(( (( ` f || ` F )) {{ start }} nonl ** + {{ end forth-flag @ IF type cr ELSE 2drop THEN }} +)) <- forth-comment ( -- ) + +(( (( ` c || ` C )) {{ start }} nonl ** + {{ end c-flag @ IF type cr ELSE 2drop THEN }} +)) <- c-comment ( -- ) + +(( ` - nonl ** {{ + forth-flag @ IF ." [ELSE]" cr THEN + c-flag @ IF ." #else" cr THEN }} +)) <- else-comment + +(( ` + {{ start }} nonl ** {{ end + dup + IF c-flag @ + IF ." #ifdef HAS_" bounds ?DO I c@ toupper emit LOOP cr + THEN + forth-flag @ + IF ." has? " type ." [IF]" cr THEN + ELSE 2drop + c-flag @ + IF ." #endif" cr THEN + forth-flag @ + IF ." [THEN]" cr THEN + THEN }} +)) <- if-comment + +(( (( forth-comment || c-comment || else-comment || if-comment )) ?? nonl ** )) <- comment-body + +(( ` \ comment-body nl )) <- comment ( -- ) (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-in-end ! }} ` - ` - blank ** @@ -262,7 +286,7 @@ nowhite ++ (( nl || eof )) )) <- primitive ( -- ) -(( (( primitive {{ printprim }} )) ** eof )) +(( (( primitive {{ printprim }} )) ** eof )) parser primitives2something warnings @ [IF] .( parser generated ok ) cr @@ -272,9 +296,9 @@ warnings @ [IF] \ fileid is for the input file, xt ( -- ) is for the output word output ! here dup rawinput ! cookedinput ! - here swap read-whole-file - dup endrawinput ! - here - allot + here unused rot read-file throw + dup here + endrawinput ! + allot align checksyncline \ begin @@ -466,7 +490,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 @@ -586,7 +610,7 @@ set-current i item-name 2@ type space item-descr +loop ; -: output-c ( -- ) +: output-c ( -- ) ." 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 @@ -610,6 +634,14 @@ set-current cr ; +: dstack-used? + effect-in-size 2@ drop + effect-out-size 2@ drop max 0<> ; + +: fstack-used? + effect-in-size 2@ nip + effect-out-size 2@ nip max 0<> ; + : output-funclabel ( -- ) 1 function-number +! ." &I_" c-name 2@ type ." ," cr ; @@ -619,41 +651,41 @@ set-current '" emit forth-name 2@ type '" emit ." ," cr ; : output-c-func ( -- ) +\ used for word libraries 1 function-number +! - ." void I_" c-name 2@ type ." () /* " forth-name 2@ type + ." Cell * I_" c-name 2@ type ." (Cell *SP, Cell **FP) /* " 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 + dstack-used? IF ." Cell *sp=SP;" cr THEN + fstack-used? IF ." Cell *fp=*FP;" cr THEN flush-tos fetches stack-pointer-updates + fstack-used? IF ." *FP=fp;" cr THEN ." {" 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 + ." return (sp);" cr ." }" cr cr ; -: output-label ( -- ) - ." &&I_" c-name 2@ type ." ," cr ; - -: output-alias ( -- ) flush-comment on - ?flush-comment - primitive-number @ . ." alias " forth-name 2@ type cr - -1 primitive-number +! ; +: output-label ( -- ) + ." (Label)&&I_" c-name 2@ type ." ," cr + -1 primitive-number +! ; + +: output-alias ( -- ) + ( primitive-number @ . ." alias " ) ." Primitive " forth-name 2@ type cr + -1 primitive-number +! ; -: output-forth ( -- ) flush-comment on - ?flush-comment +: output-forth ( -- ) forth-code @ 0= IF \ output-alias \ this is bad for ec: an alias is compiled if tho word does not exist! @@ -706,4 +738,3 @@ set-current : process ( xt -- ) bl word count rot process-file ; -