--- gforth/prims2x.fs 1996/05/09 18:13:02 1.21 +++ gforth/prims2x.fs 1997/09/13 12:04:59 1.28 @@ -42,8 +42,11 @@ warnings off -require debugging.fs -[IFUNDEF] vocabulary include search-order.fs [THEN] +include 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 +59,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 +68,18 @@ 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 type 0 0 f-comment 2! THEN ; + : start ( -- addr ) cookedinput @ ; @@ -164,7 +176,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 - save-string filename 2! + char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2! char+ endif dup c@ nl-char <> abort" sync line syntax" @@ -223,7 +235,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 ! }} @@ -594,13 +607,17 @@ set-current : output-label ( -- ) ." &&I_" c-name 2@ type ." ," cr ; -: output-alias ( -- ) +: output-alias ( -- ) flush-comment on + ?flush-comment primitive-number @ . ." alias " forth-name 2@ type cr -1 primitive-number +! ; -: output-forth ( -- ) +: output-forth ( -- ) flush-comment on + ?flush-comment forth-code @ 0= - IF output-alias + 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