version 1.30, 1998/05/02 21:28:43
|
version 1.36, 1998/12/11 22:54:27
|
Line 1
|
Line 1
|
\ 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. |
|
|
Line 42
|
Line 42
|
|
|
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 |
Line 77 skipsynclines on
|
Line 77 skipsynclines on
|
Variable flush-comment flush-comment off |
Variable flush-comment flush-comment off |
|
|
: ?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 @ ; |
Line 262 nowhite ++
|
Line 276 nowhite ++
|
(( nl || eof )) |
(( nl || eof )) |
)) <- primitive ( -- ) |
)) <- primitive ( -- ) |
|
|
(( (( primitive {{ printprim }} )) ** eof )) |
(( (( primitive {{ printprim }} )) ** eof )) |
parser primitives2something |
parser primitives2something |
warnings @ [IF] |
warnings @ [IF] |
.( parser generated ok ) cr |
.( parser generated ok ) cr |
Line 353 constant type-description
|
Line 367 constant type-description
|
\ 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)" |
Line 363 constant type-description
|
Line 381 constant type-description
|
>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 |
Line 462 s" DFloat *" single-type starts-with df_
|
Line 480 s" DFloat *" single-type starts-with df_
|
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 |
|
|
Line 582 set-current
|
Line 600 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 |
Line 640 set-current
|
Line 659 set-current
|
." }" cr |
." }" cr |
cr ; |
cr ; |
|
|
: output-label ( -- ) |
: output-label ( -- ) 1 flush-comment ! |
." &&I_" c-name 2@ type ." ," cr ; |
?flush-comment |
|
." [" -2 primitive-number @ - 0 .r ." ] " |
|
." (Label)&&I_" c-name 2@ type ." ," cr |
|
-1 primitive-number +! ; |
|
|
: output-alias ( -- ) flush-comment on |
: output-alias ( -- ) flush-comment on |
?flush-comment |
?flush-comment |
primitive-number @ . ." alias " forth-name 2@ type cr |
primitive-number @ . ." alias " forth-name 2@ type cr |
-1 primitive-number +! ; |
-1 primitive-number +! ; |
|
|
: output-forth ( -- ) flush-comment on |
: output-forth ( -- ) flush-comment on |
?flush-comment |
?flush-comment |
Line 702 set-current
|
Line 724 set-current
|
: process ( xt -- ) |
: process ( xt -- ) |
bl word count rot |
bl word count rot |
process-file ; |
process-file ; |
|
|