| 0 line ! |
0 line ! |
| 2variable filename \ filename of original input file |
2variable filename \ filename of original input file |
| 0 0 filename 2! |
0 0 filename 2! |
| |
2variable out-filename \ filename of the output file (for sync lines) |
| |
0 0 out-filename 2! |
| 2variable f-comment |
2variable f-comment |
| 0 0 f-comment 2! |
0 0 f-comment 2! |
| variable skipsynclines \ are sync lines ("#line ...") invisible to the parser? |
variable skipsynclines \ are sync lines ("#line ...") invisible to the parser? |
| skipsynclines on |
skipsynclines on |
| |
variable out-nls \ newlines in output (for output sync lines) |
| |
0 out-nls ! |
| |
|
| : th ( addr1 n -- addr2 ) |
: th ( addr1 n -- addr2 ) |
| cells + ; |
cells + ; |
| 0 |
0 |
| recover endtry |
recover endtry |
| r> to outfile-id throw |
r> to outfile-id throw |
| abort |
1 (bye) \ abort |
| endif ; |
endif ; |
| |
|
| : quote ( -- ) |
: quote ( -- ) |
| [char] " emit ; |
[char] " emit ; |
| |
|
| |
\ count output lines to generate sync lines for output |
| |
|
| |
: count-nls ( addr u -- ) |
| |
bounds u+do |
| |
i c@ nl-char = negate out-nls +! |
| |
loop ; |
| |
|
| |
:noname ( addr u -- ) |
| |
2dup count-nls |
| |
defers type ; |
| |
is type |
| |
|
| variable output \ xt ( -- ) of output word for simple primitives |
variable output \ xt ( -- ) of output word for simple primitives |
| variable output-combined \ xt ( -- ) of output word for combined primitives |
variable output-combined \ xt ( -- ) of output word for combined primitives |
| |
|
| : type-c-code ( c-addr u xt -- ) |
: type-c-code ( c-addr u xt -- ) |
| \ like TYPE, but replaces "INST_TAIL;" with tail code produced by xt |
\ like TYPE, but replaces "INST_TAIL;" with tail code produced by xt |
| { xt } |
{ xt } |
| |
." {" cr |
| |
." #line " c-line @ . quote c-filename 2@ type quote cr |
| begin ( c-addr1 u1 ) |
begin ( c-addr1 u1 ) |
| 2dup s" INST_TAIL;" search |
2dup s" INST_TAIL;" search |
| while ( c-addr1 u1 c-addr3 u3 ) |
while ( c-addr1 u1 c-addr3 u3 ) |
| 2r> 10 /string |
2r> 10 /string |
| \ !! resync #line missing |
\ !! resync #line missing |
| repeat |
repeat |
| 2drop type ; |
2drop type |
| |
." #line " out-nls @ 2 + . quote out-filename 2@ type quote cr |
| |
." }" cr ; |
| |
|
| : print-entry ( -- ) |
: print-entry ( -- ) |
| ." LABEL(" prim prim-c-name 2@ type ." )" ; |
." LABEL(" prim prim-c-name 2@ type ." )" ; |
| fetches |
fetches |
| print-debug-args |
print-debug-args |
| stack-pointer-updates |
stack-pointer-updates |
| ." {" cr |
|
| ." #line " c-line @ . quote c-filename 2@ type quote cr |
|
| prim prim-c-code 2@ ['] output-c-tail type-c-code |
prim prim-c-code 2@ ['] output-c-tail type-c-code |
| ." }" cr |
|
| output-c-tail2 |
output-c-tail2 |
| ." }" cr |
." }" cr |
| cr |
cr |
| part-fetches |
part-fetches |
| print-debug-args |
print-debug-args |
| prim add-depths \ !! right place? |
prim add-depths \ !! right place? |
| ." {" cr |
|
| ." #line " c-line @ . quote c-filename 2@ type quote cr |
|
| prim prim-c-code 2@ ['] output-combined-tail type-c-code |
prim prim-c-code 2@ ['] output-combined-tail type-c-code |
| ." }" cr |
|
| part-output-c-tail |
part-output-c-tail |
| ." }" cr ; |
." }" cr ; |
| |
|
