version 1.28, 1997/09/13 12:04:59
|
version 1.34, 1998/11/22 23:18:10
|
Line 42
|
Line 42
|
|
|
warnings off |
warnings off |
|
|
include extend.fs |
require search.fs |
|
require extend.fs |
|
|
\ require interpretation.fs |
\ require interpretation.fs |
\ require debugs.fs |
\ require debugs.fs |
Line 76 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 |
|
flush-comment @ 1 = |
|
IF ." #ifdef HAS_" bounds ?DO I c@ toupper emit LOOP |
|
ELSE ." has? " type ." [IF]" 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 128 variable name-line
|
Line 136 variable name-line
|
2variable last-name-filename |
2variable last-name-filename |
|
|
variable primitive-number -10 primitive-number ! |
variable primitive-number -10 primitive-number ! |
|
Variable function-number 0 function-number ! |
|
|
\ for several reasons stack items of a word are stored in a wordlist |
\ for several reasons stack items of a word are stored in a wordlist |
\ since neither forget nor marker are implemented yet, we make a new |
\ since neither forget nor marker are implemented yet, we make a new |
Line 351 constant type-description
|
Line 360 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 361 constant type-description
|
Line 374 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 460 s" DFloat *" single-type starts-with df_
|
Line 473 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 580 set-current
|
Line 593 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 604 set-current
|
Line 618 set-current
|
cr |
cr |
; |
; |
|
|
: output-label ( -- ) |
: output-funclabel ( -- ) |
." &&I_" c-name 2@ type ." ," cr ; |
1 function-number +! |
|
." &I_" c-name 2@ type ." ," cr ; |
|
|
|
: output-forthname ( -- ) |
|
1 function-number +! |
|
'" emit forth-name 2@ type '" emit ." ," cr ; |
|
|
|
: output-c-func ( -- ) |
|
1 function-number +! |
|
." void 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 |
|
." {" cr |
|
." DEF_CA" cr |
|
declarations |
|
compute-offsets \ for everything else |
|
." NEXT_P0;" cr |
|
flush-tos |
|
fetches |
|
stack-pointer-updates |
|
." {" 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 |
|
." }" cr |
|
cr ; |
|
|
|
: output-label ( -- ) 1 flush-comment ! |
|
?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 |
forth-code @ 0= |
forth-code @ 0= |
IF \ output-alias |
IF \ output-alias |
\ this is bad for ec: an alias is compiled if tho word does not exist! |
\ this is bad for ec: an alias is compiled if tho word does not exist! |
\ JAW |
\ JAW |
ELSE ." : " forth-name 2@ type ." ( " |
ELSE ." : " forth-name 2@ type ." ( " |
effect-in effect-in-end @ .stack-list ." -- " |
effect-in effect-in-end @ .stack-list ." -- " |
effect-out effect-out-end @ .stack-list ." )" cr |
effect-out effect-out-end @ .stack-list ." )" cr |
forth-code 2@ type cr |
forth-code 2@ type cr |
-1 primitive-number +! |
-1 primitive-number +! |
THEN ; |
THEN ; |
|
|
: output-tag-file ( -- ) |
: output-tag-file ( -- ) |
name-filename 2@ last-name-filename 2@ compare if |
name-filename 2@ last-name-filename 2@ compare if |
Line 657 set-current
|
Line 708 set-current
|
: process-file ( addr u xt -- ) |
: process-file ( addr u xt -- ) |
>r |
>r |
2dup filename 2! |
2dup filename 2! |
|
0 function-number ! |
r/o open-file abort" cannot open file" |
r/o open-file abort" cannot open file" |
warnings @ if |
warnings @ if |
." ------------ CUT HERE -------------" cr endif |
." ------------ CUT HERE -------------" cr endif |
r> primfilter ; |
r> primfilter ; |
|
|
|
: process ( xt -- ) |
|
bl word count rot |
|
process-file ; |
|
|