version 1.93, 2001/03/18 12:39:33
|
version 1.103, 2001/12/24 20:39:29
|
Line 53
|
Line 53
|
|
|
warnings off |
warnings off |
|
|
[IFUNDEF] vocabulary \ we are executed just with kernel image |
[IFUNDEF] try |
\ load the rest that is needed |
include startup.fs |
\ (require fails because this file is needed from a |
|
\ different directory with the wordlibraries) |
|
include ./search.fs |
|
include ./extend.fs |
|
include ./stuff.fs |
|
[THEN] |
|
|
|
[IFUNDEF] environment? |
|
include ./environ.fs |
|
[THEN] |
[THEN] |
|
|
: struct% struct ; \ struct is redefined in gray |
: struct% struct ; \ struct is redefined in gray |
|
|
|
warnings off |
|
|
include ./gray.fs |
include ./gray.fs |
|
|
32 constant max-effect \ number of things on one side of a stack effect |
32 constant max-effect \ number of things on one side of a stack effect |
Line 431 wordlist constant prefixes
|
Line 424 wordlist constant prefixes
|
rdrop ; |
rdrop ; |
|
|
: type-prefix ( xt1 xt2 n stack "prefix" -- ) |
: type-prefix ( xt1 xt2 n stack "prefix" -- ) |
create-type |
get-current >r prefixes set-current |
|
create-type r> set-current |
does> ( item -- ) |
does> ( item -- ) |
\ initialize item |
\ initialize item |
{ item typ } |
{ item typ } |
Line 481 does> ( item -- )
|
Line 475 does> ( item -- )
|
prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ; |
prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ; |
|
|
: stack-prefix ( stack "prefix" -- ) |
: stack-prefix ( stack "prefix" -- ) |
|
get-current >r prefixes set-current |
name tuck nextname create ( stack length ) 2, |
name tuck nextname create ( stack length ) 2, |
|
r> set-current |
does> ( item -- ) |
does> ( item -- ) |
2@ { item stack prefix-length } |
2@ { item stack prefix-length } |
item item-name 2@ prefix-length /string item item-name 2! |
item item-name 2@ prefix-length /string item item-name 2! |
Line 651 stack inst-stream IP Cell
|
Line 647 stack inst-stream IP Cell
|
2drop type ; |
2drop type ; |
|
|
: print-entry ( -- ) |
: print-entry ( -- ) |
." I_" prim prim-c-name 2@ type ." :" ; |
." LABEL(" prim prim-c-name 2@ type ." ):" ; |
|
|
: output-c ( -- ) |
: output-c ( -- ) |
print-entry ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr |
print-entry ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr |
Line 707 stack inst-stream IP Cell
|
Line 703 stack inst-stream IP Cell
|
endif |
endif |
." }" cr ; |
." }" cr ; |
|
|
|
: output-superend ( -- ) |
|
\ output flag specifying whether the current word ends a dynamic superinst |
|
prim prim-c-code 2@ s" SET_IP" search nip nip |
|
prim prim-c-code 2@ s" SUPER_END" search nip nip or 0<> |
|
prim prim-c-code 2@ s" SUPER_CONTINUE" search nip nip 0= and |
|
negate 0 .r ." , /* " prim prim-name 2@ type ." */" cr ; |
|
|
: gen-arg-parm { item -- } |
: gen-arg-parm { item -- } |
item item-stack @ inst-stream = if |
item item-stack @ inst-stream = if |
." , " item item-type @ type-c-name 2@ type space |
." , " item item-type @ type-c-name 2@ type space |
Line 771 stack inst-stream IP Cell
|
Line 774 stack inst-stream IP Cell
|
\ cr ; |
\ cr ; |
|
|
: output-label ( -- ) |
: output-label ( -- ) |
." (Label)&&I_" prim prim-c-name 2@ type ." ," cr ; |
." INST_ADDR(" prim prim-c-name 2@ type ." )," cr ; |
|
|
: output-alias ( -- ) |
: output-alias ( -- ) |
( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ; |
( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ; |
Line 803 stack inst-stream IP Cell
|
Line 806 stack inst-stream IP Cell
|
name-line @ 0 .r |
name-line @ 0 .r |
." ,0" cr ; |
." ,0" cr ; |
|
|
|
: output-vi-tag ( -- ) |
|
name-filename 2@ type #tab emit |
|
prim prim-name 2@ type #tab emit |
|
." /^" prim prim-name 2@ type ." *(/" cr ; |
|
|
[IFDEF] documentation |
[IFDEF] documentation |
: register-doc ( -- ) |
: register-doc ( -- ) |
prim prim-name 2@ documentation ['] create insert-wordlist |
prim prim-name 2@ documentation ['] create insert-wordlist |
Line 1180 Variable c-flag
|
Line 1188 Variable c-flag
|
THEN }} |
THEN }} |
)) <- if-comment |
)) <- if-comment |
|
|
(( (( eval-comment || forth-comment || c-comment || else-comment || if-comment )) ?? nonl ** )) <- comment-body |
(( (( ` g || ` G )) {{ start }} nonl ** |
|
{{ end |
|
forth-flag @ IF ." group " type cr THEN |
|
c-flag @ IF ." GROUP(" type ." )" cr THEN }} |
|
)) <- group-comment |
|
|
|
(( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body |
|
|
(( ` \ comment-body nleof )) <- comment ( -- ) |
(( ` \ comment-body nleof )) <- comment ( -- ) |
|
|
Line 1223 warnings @ [IF]
|
Line 1237 warnings @ [IF]
|
.( parser generated ok ) cr |
.( parser generated ok ) cr |
[THEN] |
[THEN] |
|
|
|
|
|
\ run with gforth-0.5.0 (slurp-file is missing) |
|
[IFUNDEF] slurp-file |
|
: slurp-file ( c-addr1 u1 -- c-addr2 u2 ) |
|
\ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents |
|
r/o bin open-file throw >r |
|
r@ file-size throw abort" file too large" |
|
dup allocate throw swap |
|
2dup r@ read-file throw over <> abort" could not read whole file" |
|
r> close-file throw ; |
|
[THEN] |
|
|
: primfilter ( addr u -- ) |
: primfilter ( addr u -- ) |
\ process the string at addr u |
\ process the string at addr u |
over dup rawinput ! dup line-start ! cookedinput ! |
over dup rawinput ! dup line-start ! cookedinput ! |