version 1.65, 2012/02/07 16:48:55
|
version 1.69, 2012/06/27 20:49:34
|
Line 79
|
Line 79
|
\ aligned correctly, but our locals stack must be float-aligned between |
\ aligned correctly, but our locals stack must be float-aligned between |
\ words. |
\ words. |
|
|
\ Other things about the internals are pretty unclear now. |
|
|
|
\ Currently locals may only be |
|
\ defined at the outer level and TO is not supported. |
|
|
|
require search.fs |
require search.fs |
require float.fs |
require float.fs |
require extend.fs \ for case |
require extend.fs \ for case |
Line 170 variable locals-mem-list \ linked list o
|
Line 165 variable locals-mem-list \ linked list o
|
|
|
\ locals list operations |
\ locals list operations |
|
|
: common-list ( list1 list2 -- list3 ) \ gforth-internal |
: list-length ( list -- u ) |
\ list1 and list2 are lists, where the heads are at higher addresses than |
0 swap begin ( u1 list1 ) |
\ the tail. list3 is the largest sublist of both lists. |
dup while |
begin |
@ swap 1+ swap |
2dup u<> |
repeat |
while |
drop ; |
2dup u> |
|
if |
: /list ( list1 u -- list2 ) |
swap |
\ list2 is list1 with the first u elements removed |
then |
0 ?do |
@ |
@ |
repeat |
loop ; |
drop ; |
|
|
: common-list ( list1 list2 -- list3 ) |
: sub-list? ( list1 list2 -- f ) \ gforth-internal |
\ list3 is the largest common tail of both lists. |
\ true iff list1 is a sublist of list2 |
over list-length over list-length - dup 0< if |
begin |
negate >r swap r> |
2dup u< |
then ( long short u ) |
while |
rot swap /list begin ( list3 list4 ) |
@ |
2dup u<> while |
repeat |
@ swap @ |
= ; |
repeat |
|
drop ; |
|
|
|
: sub-list? ( list1 list2 -- f ) |
|
\ true iff list1 is a sublist of list2 |
|
over list-length over list-length swap - 0 max /list = ; |
|
|
|
\ : ocommon-list ( list1 list2 -- list3 ) \ gforth-internal |
|
\ \ list1 and list2 are lists, where the heads are at higher addresses than |
|
\ \ the tail. list3 is the largest sublist of both lists. |
|
\ begin |
|
\ 2dup u<> |
|
\ while |
|
\ 2dup u> |
|
\ if |
|
\ swap |
|
\ then |
|
\ @ |
|
\ repeat |
|
\ drop ; |
|
|
|
\ : osub-list? ( list1 list2 -- f ) \ gforth-internal |
|
\ \ true iff list1 is a sublist of list2 |
|
\ begin |
|
\ 2dup u< |
|
\ while |
|
\ @ |
|
\ repeat |
|
\ = ; |
|
|
|
\ defer common-list |
|
\ defer sub-list? |
|
|
|
\ ' ocommon-list is common-list |
|
\ ' osub-list? is sub-list? |
|
|
: 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 |
Line 538 forth definitions
|
Line 567 forth definitions
|
latest latestxt |
latest latestxt |
clear-leave-stack |
clear-leave-stack |
0 locals-size ! |
0 locals-size ! |
locals-mem-list @ free-list |
|
0 locals-mem-list ! |
|
0 locals-list ! |
0 locals-list ! |
dead-code off |
dead-code off |
defstart ; |
defstart ; |
|
|
|
[IFDEF] free-old-local-names |
|
:noname ( -- ) |
|
locals-mem-list @ free-list |
|
0 locals-mem-list ! ; |
|
is free-old-local-names |
|
[THEN] |
|
|
: locals-;-hook ( sys addr xt sys -- sys ) |
: locals-;-hook ( sys addr xt sys -- sys ) |
def? |
def? |
0 TO locals-wordlist |
0 TO locals-wordlist |
Line 623 forth definitions
|
Line 657 forth definitions
|
' locals-:-hook IS :-hook |
' locals-:-hook IS :-hook |
' locals-;-hook IS ;-hook |
' locals-;-hook IS ;-hook |
|
|
|
|
' (then-like) IS then-like |
' (then-like) IS then-like |
' (begin-like) IS begin-like |
' (begin-like) IS begin-like |
' (again-like) IS again-like |
' (again-like) IS again-like |
Line 700 forth definitions
|
Line 735 forth definitions
|
code-address! |
code-address! |
then ; |
then ; |
|
|
:noname |
: (int-to) ( xt -- ) dup >definer |
' dup >definer [ ' locals-wordlist ] literal >definer = |
case |
if |
[ ' locals-wordlist ] literal >definer \ value |
>body ! |
of >body ! endof |
else |
[ ' parse-name ] literal >definer \ defer |
|
of defer! endof |
-&32 throw |
-&32 throw |
endif ; |
endcase ; |
:noname |
|
comp' drop dup >definer |
: (comp-to) ( xt -- ) dup >definer |
case |
case |
[ ' locals-wordlist ] literal >definer \ value |
[ ' locals-wordlist ] literal >definer \ value |
OF >body POSTPONE Aliteral POSTPONE ! ENDOF |
OF >body POSTPONE Aliteral POSTPONE ! ENDOF |
|
[ ' parse-name ] literal >definer \ defer |
|
OF POSTPONE Aliteral POSTPONE defer! ENDOF |
\ !! dependent on c: etc. being does>-defining words |
\ !! dependent on c: etc. being does>-defining words |
\ this works, because >definer uses >does-code in this case, |
\ this works, because >definer uses >does-code in this case, |
\ which produces a relocatable address |
\ which produces a relocatable address |
Line 725 forth definitions
|
Line 763 forth definitions
|
OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF |
OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF |
-&32 throw |
-&32 throw |
endcase ; |
endcase ; |
|
|
|
:noname |
|
' (int-to) ; |
|
:noname |
|
comp' drop (comp-to) ; |
interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local |
interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local |
|
|
: locals| ( ... "name ..." -- ) \ local-ext locals-bar |
: locals| ( ... "name ..." -- ) \ local-ext locals-bar |