--- gforth/glocals.fs	2011/12/31 15:29:25	1.63
+++ gforth/glocals.fs	2012/06/27 20:49:34	1.69
@@ -79,19 +79,10 @@
 \ aligned correctly, but our locals stack must be float-aligned between
 \ 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 float.fs
 require extend.fs \ for case
 
-: save-mem-dict ( addr1 u -- addr2 u )
-    here swap dup allot ( addr1 addr2 u )
-    2dup 2>r move 2r> ;
-
 : compile-@local ( n -- ) \ gforth compile-fetch-local
  case
     0       of postpone @local0 endof
@@ -174,28 +165,62 @@ variable locals-mem-list \ linked list o
 
 \ locals list operations
 
-: common-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 ;
-
-: sub-list? ( list1 list2 -- f ) \ gforth-internal
-\ true iff list1 is a sublist of list2
- begin
-   2dup u<
- while
-   @
- repeat
- = ;
+: list-length ( list -- u )
+    0 swap begin ( u1 list1 )
+	dup while
+	    @ swap 1+ swap
+    repeat
+    drop ;
+
+: /list ( list1 u -- list2 )
+    \ list2 is list1 with the first u elements removed
+    0 ?do
+	@
+    loop ;
+
+: common-list ( list1 list2 -- list3 )
+    \ list3 is the largest common tail of both lists.
+    over list-length over list-length - dup 0< if
+	negate >r swap r>
+    then ( long short u )
+    rot swap /list begin ( list3 list4 )
+	2dup u<> while
+	    @ 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
     \ size of the locals frame represented by list
@@ -217,7 +242,7 @@ variable locals-mem-list \ linked list o
 \ warn if list is not a sublist of locals-list
  locals-list @ sub-list? 0= if
    \ !! print current position
-   ." compiler was overly optimistic about locals at a BEGIN" cr
+     >stderr ." compiler was overly optimistic about locals at a BEGIN" cr
    \ !! print assumption and reality
  then ;
 
@@ -542,12 +567,17 @@ forth definitions
     latest latestxt
     clear-leave-stack
     0 locals-size !
-    locals-mem-list @ free-list
-    0 locals-mem-list !
     0 locals-list !
     dead-code off
     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 )
     def?
     0 TO locals-wordlist
@@ -627,6 +657,7 @@ forth definitions
 ' locals-:-hook IS :-hook
 ' locals-;-hook IS ;-hook
 
+
 ' (then-like)  IS then-like
 ' (begin-like) IS begin-like
 ' (again-like) IS again-like
@@ -704,18 +735,21 @@ forth definitions
 	code-address!
     then ;
 
-:noname
-    ' dup >definer [ ' locals-wordlist ] literal >definer =
-    if
-	>body !
-    else
+: (int-to) ( xt -- ) dup >definer
+    case
+	[ ' locals-wordlist ] literal >definer \ value
+	of  >body ! endof
+	[ ' parse-name ] literal >definer \ defer
+	of  defer! endof
 	-&32 throw
-    endif ;
-:noname
-    comp' drop dup >definer
+    endcase ;
+
+: (comp-to) ( xt -- ) dup >definer
     case
 	[ ' locals-wordlist ] literal >definer \ value
 	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
 	\ this works, because >definer uses >does-code in this case,
 	\ which produces a relocatable address
@@ -729,6 +763,11 @@ forth definitions
 	OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
 	-&32 throw
     endcase ;
+
+:noname
+    ' (int-to) ;
+:noname
+    comp' drop (comp-to) ;
 interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local
 
 : locals| ( ... "name ..." -- ) \ local-ext locals-bar