version 1.28, 1996/09/30 13:16:10
|
version 1.41, 1999/05/03 09:46:20
|
Line 1
|
Line 1
|
\ A powerful locals implementation |
\ A powerful locals implementation |
|
|
\ 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 85
|
Line 85
|
\ Currently locals may only be |
\ Currently locals may only be |
\ defined at the outer level and TO is not supported. |
\ defined at the outer level and TO is not supported. |
|
|
require search-order.fs |
require search.fs |
require float.fs |
require float.fs |
|
|
: compile-@local ( n -- ) \ gforth compile-fetch-local |
: compile-@local ( n -- ) \ gforth compile-fetch-local |
Line 129 require float.fs
|
Line 129 require float.fs
|
slowvoc @ |
slowvoc @ |
slowvoc on \ we want a linked list for the vocabulary locals |
slowvoc on \ we want a linked list for the vocabulary locals |
vocabulary locals \ this contains the local variables |
vocabulary locals \ this contains the local variables |
' locals >body ' locals-list >body ! |
' locals >body wordlist-id ' locals-list >body ! |
slowvoc ! |
slowvoc ! |
|
|
create locals-buffer 1000 allot \ !! limited and unsafe |
create locals-buffer 1000 allot \ !! limited and unsafe |
Line 183 variable locals-dp \ so here's the speci
|
Line 183 variable locals-dp \ so here's the speci
|
= ; |
= ; |
|
|
: list-size ( list -- u ) \ gforth-internal |
: list-size ( list -- u ) \ gforth-internal |
\ size of the locals frame represented by list |
\ size of the locals frame represented by list |
0 ( list n ) |
0 ( list n ) |
begin |
begin |
over 0<> |
over 0<> |
while |
while |
over |
over |
((name>)) >body @ max |
((name>)) >body @ max |
swap @ swap ( get next ) |
swap @ swap ( get next ) |
repeat |
repeat |
faligned nip ; |
faligned nip ; |
|
|
: set-locals-size-list ( list -- ) |
: set-locals-size-list ( list -- ) |
dup locals-list ! |
dup locals-list ! |
list-size locals-size ! ; |
list-size locals-size ! ; |
|
|
: check-begin ( list -- ) |
: check-begin ( list -- ) |
\ warn if list is not a sublist of locals-list |
\ warn if list is not a sublist of locals-list |
Line 292 locals-types definitions
|
Line 292 locals-types definitions
|
postpone laddr# @ lp-offset, ; |
postpone laddr# @ lp-offset, ; |
|
|
\ you may want to make comments in a locals definitions group: |
\ you may want to make comments in a locals definitions group: |
' \ alias \ immediate |
' \ alias \ ( -- ) \ core-ext,block-ext backslash |
' ( alias ( immediate |
\G Line comment: if @code{BLK} contains 0, parse and discard the remainder |
|
\G of the parse area. Otherwise, parse and discard all subsequent characters in the |
|
\G parse area corresponding to the current line. |
|
immediate |
|
|
|
' ( alias ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren |
|
\G Comment: parse and discard all subsequent characters in the parse |
|
\G area until ")" is encountered. During interactive input, an end-of-line |
|
\G also acts as a comment terminator. For file input, it does not; if the |
|
\G end-of-file is encountered whilst parsing for the ")" delimiter, Gforth |
|
\G will generate a warning. |
|
immediate |
|
|
forth definitions |
forth definitions |
|
|
Line 319 previous
|
Line 330 previous
|
true abort" this should not happen: new-locals-reveal" ; |
true abort" this should not happen: new-locals-reveal" ; |
|
|
create new-locals-map ( -- wordlist-map ) |
create new-locals-map ( -- wordlist-map ) |
' new-locals-find A, ' new-locals-reveal A, |
' new-locals-find A, |
|
' new-locals-reveal A, |
slowvoc @ |
' drop A, \ rehash method |
slowvoc on |
' drop A, |
vocabulary new-locals |
|
slowvoc ! |
new-locals-map mappedwordlist Constant new-locals-wl |
new-locals-map ' new-locals >body cell+ A! \ !! use special access words |
|
|
\ slowvoc @ |
|
\ slowvoc on |
|
\ vocabulary new-locals |
|
\ slowvoc ! |
|
\ new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words |
|
|
variable old-dpp |
variable old-dpp |
|
|
\ and now, finally, the user interface words |
\ and now, finally, the user interface words |
: { ( -- addr wid 0 ) \ gforth open-brace |
: { ( -- lastxt wid 0 ) \ gforth open-brace |
dp old-dpp ! |
dp old-dpp ! |
locals-dp dpp ! |
locals-dp dpp ! |
also new-locals |
lastxt get-current |
also get-current locals definitions locals-types |
get-order new-locals-wl swap 1+ set-order |
|
also locals definitions locals-types |
0 TO locals-wordlist |
0 TO locals-wordlist |
0 postpone [ ; immediate |
0 postpone [ ; immediate |
|
|
locals-types definitions |
locals-types definitions |
|
|
: } ( addr wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace |
: } ( lastxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace |
\ ends locals definitions |
\ ends locals definitions |
] old-dpp @ dpp ! |
] old-dpp @ dpp ! |
begin |
begin |
Line 350 locals-types definitions
|
Line 367 locals-types definitions
|
repeat |
repeat |
drop |
drop |
locals-size @ alignlp-f locals-size ! \ the strictest alignment |
locals-size @ alignlp-f locals-size ! \ the strictest alignment |
set-current |
|
previous previous |
previous previous |
locals-list TO locals-wordlist ; |
set-current lastcfa ! |
|
locals-list 0 wordlist-id - TO locals-wordlist ; |
|
|
: -- ( addr wid 0 ... -- ) \ gforth dash-dash |
: -- ( addr wid 0 ... -- ) \ gforth dash-dash |
} |
} |
Line 453 forth definitions
|
Line 470 forth definitions
|
\ explicit scoping |
\ explicit scoping |
|
|
: scope ( compilation -- scope ; run-time -- ) \ gforth |
: scope ( compilation -- scope ; run-time -- ) \ gforth |
cs-push-part scopestart ; immediate |
cs-push-part scopestart ; immediate |
|
|
|
: adjust-locals-list ( wid -- ) |
|
locals-list @ common-list |
|
dup list-size adjust-locals-size |
|
locals-list ! ; |
|
|
: endscope ( compilation scope -- ; run-time -- ) \ gforth |
: endscope ( compilation scope -- ; run-time -- ) \ gforth |
scope? |
scope? |
drop |
drop adjust-locals-list ; immediate |
locals-list @ common-list |
|
dup list-size adjust-locals-size |
|
locals-list ! ; immediate |
|
|
|
\ adapt the hooks |
\ adapt the hooks |
|
|
Line 495 forth definitions
|
Line 514 forth definitions
|
\ ELSE. However, if ELSE generates an appropriate "lp+!#" before the |
\ ELSE. However, if ELSE generates an appropriate "lp+!#" before the |
\ branch, there will be none after the target <then>. |
\ branch, there will be none after the target <then>. |
|
|
: (then-like) ( orig -- addr ) |
: (then-like) ( orig -- ) |
swap -rot dead-orig = |
dead-orig = |
if |
if |
drop |
>resolve drop |
else |
else |
dead-code @ |
dead-code @ |
if |
if |
set-locals-size-list dead-code off |
>resolve set-locals-size-list dead-code off |
else \ both live |
else \ both live |
dup list-size adjust-locals-size |
over list-size adjust-locals-size |
locals-list @ common-list dup list-size adjust-locals-size |
>resolve |
locals-list ! |
adjust-locals-list |
then |
then |
then ; |
then ; |
|
|
Line 614 forth definitions
|
Line 633 forth definitions
|
\ this gives a unique identifier for the way the xt was defined |
\ this gives a unique identifier for the way the xt was defined |
\ words defined with different does>-codes have different definers |
\ words defined with different does>-codes have different definers |
\ the definer can be used for comparison and in definer! |
\ the definer can be used for comparison and in definer! |
dup >code-address [ ' spaces >code-address ] Literal = |
dup >does-code |
\ !! this definition will not work on some implementations for `bits' |
?dup-if |
if \ if >code-address delivers the same value for all does>-def'd words |
nip 1 or |
>does-code 1 or \ bit 0 marks special treatment for does codes |
|
else |
else |
>code-address |
>code-address |
then ; |
then ; |
Line 631 forth definitions
|
Line 649 forth definitions
|
then ; |
then ; |
|
|
:noname |
:noname |
' dup >definer [ ' locals-wordlist >definer ] literal = |
' dup >definer [ ' locals-wordlist ] literal >definer = |
if |
if |
>body ! |
>body ! |
else |
else |
Line 641 forth definitions
|
Line 659 forth definitions
|
0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal } |
0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal } |
comp' drop dup >definer |
comp' drop dup >definer |
case |
case |
[ ' locals-wordlist >definer ] literal \ value |
[ ' locals-wordlist ] literal >definer \ value |
OF >body POSTPONE Aliteral POSTPONE ! ENDOF |
OF >body POSTPONE Aliteral POSTPONE ! ENDOF |
|
\ !! dependent on c: etc. being does>-defining words |
|
\ this works, because >definer uses >does-code in this case, |
|
\ which produces a relocatable address |
[ comp' clocal drop >definer ] literal |
[ comp' clocal drop >definer ] literal |
OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF |
OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF |
[ comp' wlocal drop >definer ] literal |
[ comp' wlocal drop >definer ] literal |