version 1.8, 1994/09/12 19:00:36
|
version 1.15, 1995/10/16 18:33:12
|
Line 21
|
Line 21
|
|
|
warnings off |
warnings off |
|
|
[IFUNDEF] vocabulary include search-order.fs [THEN] |
[IFUNDEF] vocabulary include search-order.fs [THEN] |
|
[IFUNDEF] environment? include environ.fs [THEN] |
include gray.fs |
include gray.fs |
|
|
100 constant max-effect \ number of things on one side of a stack effect |
100 constant max-effect \ number of things on one side of a stack effect |
Line 89 variable effect-out-end ( pointer )
|
Line 90 variable effect-out-end ( pointer )
|
2variable effect-in-size |
2variable effect-in-size |
2variable effect-out-size |
2variable effect-out-size |
|
|
variable primitive-number -9 primitive-number ! |
variable primitive-number -10 primitive-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 347 constant type-description
|
Line 348 constant type-description
|
endif |
endif |
rdrop ; |
rdrop ; |
|
|
: single-type ( -- xt n1 n2 ) |
: single-type ( -- xt1 xt2 n1 n2 ) |
['] fetch-single ['] store-single 1 0 ; |
['] fetch-single ['] store-single 1 0 ; |
|
|
: double-type ( -- xt n1 n2 ) |
: double-type ( -- xt1 xt2 n1 n2 ) |
['] fetch-double ['] store-double 2 0 ; |
['] fetch-double ['] store-double 2 0 ; |
|
|
: float-type ( -- xt n1 n2 ) |
: float-type ( -- xt1 xt2 n1 n2 ) |
['] fetch-float ['] store-float 0 1 ; |
['] fetch-float ['] store-float 0 1 ; |
|
|
: s, ( addr u -- ) |
: s, ( addr u -- ) |
Line 404 set-current
|
Line 405 set-current
|
execute nip |
execute nip |
UNLOOP EXIT |
UNLOOP EXIT |
endif |
endif |
-1 +loop |
-1 s+loop |
\ we did not find a type, abort |
\ we did not find a type, abort |
true abort" unknown type prefix" ; |
true abort" unknown type prefix" ; |
|
|
Line 514 set-current
|
Line 515 set-current
|
: output-c ( -- ) |
: output-c ( -- ) |
." 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 |
." {" cr |
." {" cr |
." DEF_CA" cr |
." DEF_CA" cr |
declarations |
declarations |
compute-offsets \ for everything else |
compute-offsets \ for everything else |
|
." NEXT_P0;" cr |
flush-tos |
flush-tos |
fetches |
fetches |
stack-pointer-updates cr |
stack-pointer-updates |
." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging |
|
." {" cr |
." {" cr |
c-code 2@ type |
c-code 2@ type |
." }" cr |
." }" cr |
." NEXT_P1;" cr |
." NEXT_P1;" cr |
stores |
stores |
fill-tos |
fill-tos |
." NEXT1_P2;" cr |
." NEXT_P2;" cr |
." }" cr |
." }" cr |
cr |
cr |
; |
; |
Line 548 set-current
|
Line 550 set-current
|
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 ; |
; |
|
|
[IFDEF] documentation |
|
: register-doc ( -- ) |
|
get-current documentation set-current |
|
forth-name 2@ nextname create |
|
forth-name 2@ 2, |
|
stack-string 2@ condition-stack-effect 2, |
|
wordset 2@ 2, |
|
c-name 2@ condition-pronounciation 2, |
|
doc 2@ 2, |
|
set-current ; |
|
[THEN] |
|
|
: process-file ( addr u xt -- ) |
: process-file ( addr u xt -- ) |
>r r/o open-file abort" cannot open file" |
>r r/o open-file abort" cannot open file" |