version 1.131, 2003/01/30 17:11:02
|
version 1.138, 2003/05/13 09:36:59
|
Line 1
|
Line 1
|
\ converts primitives to, e.g., C code |
\ converts primitives to, e.g., C code |
|
|
\ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 51
|
Line 51
|
\ (stack-in-index-xt and a test for stack==instruction-stream); there |
\ (stack-in-index-xt and a test for stack==instruction-stream); there |
\ should be only one. |
\ should be only one. |
|
|
|
\ for backwards compatibility, jaw |
|
require compat/strcomp.fs |
|
|
warnings off |
warnings off |
|
|
|
\ redefinitions of kernel words not present in gforth-0.6.1 |
|
: latestxt lastcfa @ ; |
|
: latest last @ ; |
|
|
[IFUNDEF] try |
[IFUNDEF] try |
include startup.fs |
include startup.fs |
[THEN] |
[THEN] |
Line 63 warnings off
|
Line 70 warnings off
|
\ warnings on |
\ warnings on |
|
|
include ./gray.fs |
include ./gray.fs |
32 constant max-effect \ number of things on one side of a stack effect |
128 constant max-effect \ number of things on one side of a stack effect |
4 constant max-stacks \ the max. number of stacks (including inst-stream). |
4 constant max-stacks \ the max. number of stacks (including inst-stream). |
255 constant maxchar |
255 constant maxchar |
maxchar 1+ constant eof-char |
maxchar 1+ constant eof-char |
Line 608 wordlist constant type-names \ this is h
|
Line 615 wordlist constant type-names \ this is h
|
get-current type-names set-current |
get-current type-names set-current |
stack-type 2dup nextname stack-type-name |
stack-type 2dup nextname stack-type-name |
set-current |
set-current |
stack-pointer lastxt >body stack-name nextname make-stack ; |
stack-pointer latestxt >body stack-name nextname make-stack ; |
|
|
stack inst-stream IP Cell |
stack inst-stream IP Cell |
' inst-in-index inst-stream stack-in-index-xt ! |
' inst-in-index inst-stream stack-in-index-xt ! |
Line 631 stack inst-stream IP Cell
|
Line 638 stack inst-stream IP Cell
|
: compute-offset-out ( addr1 addr2 -- ) |
: compute-offset-out ( addr1 addr2 -- ) |
['] stack-out compute-offset ; |
['] stack-out compute-offset ; |
|
|
: clear-stack ( stack -- ) |
|
dup stack-in off stack-out off ; |
|
|
|
: compute-offsets ( -- ) |
: compute-offsets ( -- ) |
['] clear-stack map-stacks |
prim prim-stacks-in max-stacks cells erase |
|
prim prim-stacks-out max-stacks cells erase |
prim prim-effect-in prim prim-effect-in-end @ ['] compute-offset-in map-items |
prim prim-effect-in prim prim-effect-in-end @ ['] compute-offset-in map-items |
prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items |
prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items |
inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ; |
inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ; |
Line 1266 variable tail-nextp2 \ xt to execute for
|
Line 1271 variable tail-nextp2 \ xt to execute for
|
\ int loads; /* number of stack loads */ |
\ int loads; /* number of stack loads */ |
\ int stores; /* number of stack stores */ |
\ int stores; /* number of stack stores */ |
\ int updates; /* number of stack pointer updates */ |
\ int updates; /* number of stack pointer updates */ |
|
\ int offset; /* offset into super2 table */ |
\ int length; /* number of components */ |
\ int length; /* number of components */ |
\ int *components; /* array of vm_prim indexes of components */ |
|
\ }; |
\ }; |
|
|
\ How do you know which primitive or combined instruction this |
\ How do you know which primitive or combined instruction this |
Line 1292 variable tail-nextp2 \ xt to execute for
|
Line 1297 variable tail-nextp2 \ xt to execute for
|
: output-num-part ( p -- ) |
: output-num-part ( p -- ) |
prim-num @ 4 .r ." ," ; |
prim-num @ 4 .r ." ," ; |
|
|
|
: super2-length ( -- n ) |
|
combined if |
|
num-combined @ |
|
else |
|
1 |
|
endif ; |
|
|
|
: output-name-comment ( -- ) |
|
." /* " prim prim-name 2@ type ." */" ; |
|
|
|
variable offset-super2 0 offset-super2 ! \ offset into the super2 table |
|
|
: output-costs ( -- ) |
: output-costs ( -- ) |
|
\ description of superinstructions and simple instructions |
." {" prim compute-costs |
." {" prim compute-costs |
rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ," |
rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ," |
|
offset-super2 @ 5 .r ." ," |
|
super2-length dup 2 .r ." }," offset-super2 +! |
|
output-name-comment |
|
cr ; |
|
|
|
: output-super2 ( -- ) |
|
\ table of superinstructions without requirement for existing prefixes |
combined if |
combined if |
num-combined @ 2 .r |
['] output-num-part map-combined |
." , ((int []){" ['] output-num-part map-combined ." })}, /* " |
|
else |
else |
." 1, ((int []){" prim prim-num @ 4 .r ." })}, /* " |
prim output-num-part |
endif |
endif |
prim prim-name 2@ type ." */" |
output-name-comment |
cr ; |
cr ; |
|
|
\ the parser |
\ the parser |
|
|
Line 1479 Variable c-flag
|
Line 1503 Variable c-flag
|
start }} [ifdef] vmgen c-ident [else] forth-ident [then] {{ end |
start }} [ifdef] vmgen c-ident [else] forth-ident [then] {{ end |
2dup prim prim-name 2! prim prim-c-name 2! }} white ** |
2dup prim prim-name 2! prim prim-c-name 2! }} white ** |
(( ` / white ** {{ start }} c-ident {{ end prim prim-c-name 2! }} white ** )) ?? |
(( ` / white ** {{ start }} c-ident {{ end prim prim-c-name 2! }} white ** )) ?? |
(( simple-primitive || combined-primitive )) {{ 1 function-number +! }} |
(( simple-primitive || combined-primitive )) |
|
{{ 1 function-number +! }} |
)) <- primitive ( -- ) |
)) <- primitive ( -- ) |
|
|
(( (( comment || primitive || nl white ** )) ** eof )) |
(( (( comment || primitive || nl white ** )) ** eof )) |