--- gforth/glocals.fs 2004/12/31 13:23:57 1.55 +++ gforth/glocals.fs 2012/12/31 15:25:18 1.70 @@ -1,12 +1,12 @@ \ A powerful locals implementation -\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2007,2011,2012 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License -\ as published by the Free Software Foundation; either version 2 +\ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, @@ -15,8 +15,7 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. \ More documentation can be found in the manual and in @@ -80,11 +79,6 @@ \ 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 @@ -133,11 +127,22 @@ vocabulary locals \ this contains the lo ' locals >body wordlist-id ' locals-list >body ! slowvoc ! -create locals-buffer 1000 allot \ !! limited and unsafe - \ here the names of the local variables are stored - \ we would have problems storing them at the normal dp +variable locals-mem-list \ linked list of all locals name memory in +0 locals-mem-list ! \ the current (outer-level) definition -variable locals-dp \ so here's the special dp for locals. +: free-list ( addr -- ) + \ free all members of a linked list (link field is first) + begin + dup while + dup @ swap free throw + repeat + drop ; + +: prepend-list ( addr1 addr2 -- ) + \ addr1 is the address of a list element, addr2 is the address of + \ the cell containing the address of the first list element + 2dup @ swap ! \ store link to next element + ! ; \ store pointer to new first element : alignlp-w ( n1 -- n2 ) \ cell-align size and generate the corresponding code for aligning lp @@ -160,28 +165,62 @@ variable locals-dp \ so here's the speci \ 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 @@ -203,7 +242,7 @@ variable locals-dp \ so here's the speci \ 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 ; @@ -222,12 +261,45 @@ variable locals-dp \ so here's the speci locals-size @ swap ! postpone lp@ postpone c! ; +7 cells 32 + constant locals-name-size \ 32-char name + fields + wiggle room + +: create-local1 ( "name" -- a-addr ) + create + immediate restrict + here 0 , ( place for the offset ) ; + +variable dict-execute-dp \ the special dp for DICT-EXECUTE + +0 value dict-execute-ude \ USABLE-DICTIONARY-END during DICT-EXECUTE + +: dict-execute1 ( ... addr1 addr2 xt -- ... ) + \ execute xt with HERE set to addr1 and USABLE-DICTIONARY-END set to addr2 + dict-execute-dp @ dp 2>r + dict-execute-ude ['] usable-dictionary-end defer@ 2>r + swap to dict-execute-ude + ['] dict-execute-ude is usable-dictionary-end + swap to dict-execute-dp + dict-execute-dp dpp ! + catch + 2r> is usable-dictionary-end to dict-execute-ude + 2r> dpp ! dict-execute-dp ! + throw ; + +defer dict-execute ( ... addr1 addr2 xt -- ... ) + +:noname ( ... addr1 addr2 xt -- ... ) + \ first have a dummy routine, for SOME-CLOCAL etc. below + nip nip execute ; +is dict-execute + : create-local ( " name" -- a-addr ) \ defines the local "name"; the offset of the local shall be \ stored in a-addr - create - immediate restrict - here 0 , ( place for the offset ) ; + locals-name-size allocate throw + dup locals-mem-list prepend-list + locals-name-size cell /string over + ['] create-local1 dict-execute ; + +variable locals-dp \ so here's the special dp for locals. : lp-offset ( n1 -- n2 ) \ converts the offset from the frame start to an offset from lp and @@ -313,11 +385,12 @@ forth definitions also locals-types \ these "locals" are used for comparison in TO - c: some-clocal 2drop d: some-dlocal 2drop f: some-flocal 2drop w: some-wlocal 2drop + +' dict-execute1 is dict-execute \ now the real thing \ the following gymnastics are for declaring locals without type specifier. \ we exploit a feature of our dictionary: every wordlist @@ -352,12 +425,8 @@ new-locals-map mappedwordlist Constant n \ slowvoc ! \ new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words -variable old-dpp - \ and now, finally, the user interface words : { ( -- latestxt wid 0 ) \ gforth open-brace - dp old-dpp ! - locals-dp dpp ! latestxt get-current get-order new-locals-wl swap 1+ set-order also locals definitions locals-types @@ -368,7 +437,7 @@ locals-types definitions : } ( latestxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace \ ends locals definitions - ] old-dpp @ dpp ! + ] begin dup while @@ -498,11 +567,17 @@ forth definitions latest latestxt clear-leave-stack 0 locals-size ! - locals-buffer locals-dp ! 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 @@ -582,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 @@ -638,7 +714,7 @@ forth definitions 2drop endif ; -: >definer ( xt -- definer ) +: >definer ( xt -- definer ) \ gforth \G @var{Definer} is a unique identifier for the way the @var{xt} \G was defined. Words defined with different @code{does>}-codes \G have different definers. The definer can be used for @@ -650,7 +726,7 @@ forth definitions >code-address then ; -: definer! ( definer xt -- ) +: definer! ( definer xt -- ) \ gforth \G The word represented by @var{xt} changes its behaviour to the \G behaviour associated with @var{definer}. over 1 and if @@ -659,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 @@ -684,9 +763,14 @@ 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| +: locals| ( ... "name ..." -- ) \ local-ext locals-bar \ don't use 'locals|'! use '{'! A portable and free '{' \ implementation is compat/anslocals.fs BEGIN