| \ converts primitives to, e.g., C code |
\ 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. |
\ This file is part of Gforth. |
| |
|
| |
|
| warnings off |
warnings off |
| |
|
| include search.fs |
require search.fs |
| include extend.fs |
require extend.fs |
| |
|
| \ require interpretation.fs |
\ require interpretation.fs |
| \ require debugs.fs |
\ require debugs.fs |
| : ?flush-comment |
: ?flush-comment |
| flush-comment @ 0= ?EXIT |
flush-comment @ 0= ?EXIT |
| f-comment 2@ nip |
f-comment 2@ nip |
| IF cr f-comment 2@ 2 /string type 0 0 f-comment 2! THEN ; |
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 ) |
: start ( -- addr ) |
| cookedinput @ ; |
cookedinput @ ; |
| \ true if item has the same offset as the input TOS |
\ true if item has the same offset as the input TOS |
| item-d-offset @ 1+ effect-in-size 2@ drop = ; |
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 -- ) |
: really-store-single ( item -- ) |
| >r |
>r |
| r@ item-d-offset @ effect-out-size 2@ data-stack-access ." = (Cell)" |
r@ item-d-offset @ effect-out-size 2@ data-stack-access ." = (Cell)" |
| >r |
>r |
| r@ d-same-as-in? |
r@ d-same-as-in? |
| if |
if |
| r@ is-in-tos? |
r@ is-in-tos? r@ is-out-tos? xor |
| if |
if |
| ." IF_TOS(" r@ really-store-single ." );" cr |
." IF_TOS(" r@ really-store-single ." );" cr |
| endif |
endif |
| s" SFloat *" single-type starts-with sf_ |
s" SFloat *" single-type starts-with sf_ |
| s" Xt" single-type starts-with xt |
s" Xt" single-type starts-with xt |
| s" WID" single-type starts-with wid |
s" WID" single-type starts-with wid |
| s" F83Name *" single-type starts-with f83name |
s" struct F83Name *" single-type starts-with f83name |
| |
|
| set-current |
set-current |
| |
|
| i item-name 2@ type space |
i item-name 2@ type space |
| item-descr +loop ; |
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 |
." I_" c-name 2@ type ." : /* " forth-name 2@ type ." ( " stack-string 2@ type ." ) */" cr |
| ." /* " doc 2@ type ." */" cr |
." /* " doc 2@ type ." */" cr |
| ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging |
." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging |
| ." }" cr |
." }" cr |
| cr ; |
cr ; |
| |
|
| : output-label ( -- ) |
: output-label ( -- ) 1 flush-comment ! |
| ." &&I_" c-name 2@ type ." ," cr ; |
?flush-comment |
| |
." (Label)&&I_" c-name 2@ type ." ," cr |
| |
-1 primitive-number +! ; |
| |
|
| : output-alias ( -- ) flush-comment on |
: output-alias ( -- ) flush-comment on |
| ?flush-comment |
?flush-comment |
| : process ( xt -- ) |
: process ( xt -- ) |
| bl word count rot |
bl word count rot |
| process-file ; |
process-file ; |
| |
|
