1: \ A powerful locals implementation
2:
3: \ Copyright (C) 1995 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation; either version 2
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program; if not, write to the Free Software
19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20:
21:
22: \ Local variables are quite important for writing readable programs, but
23: \ IMO (anton) they are the worst part of the standard. There they are very
24: \ restricted and have an ugly interface.
25:
26: \ So, we implement the locals wordset, but do not recommend using
27: \ locals-ext (which is a really bad user interface for locals).
28:
29: \ We also have a nice and powerful user-interface for locals: locals are
30: \ defined with
31:
32: \ { local1 local2 ... }
33: \ or
34: \ { local1 local2 ... -- ... }
35: \ (anything after the -- is just a comment)
36:
37: \ Every local in this list consists of an optional type specification
38: \ and a name. If there is only the name, it stands for a cell-sized
39: \ value (i.e., you get the value of the local variable, not it's
40: \ address). The following type specifiers stand before the name:
41:
42: \ Specifier Type Access
43: \ W: Cell value
44: \ W^ Cell address
45: \ D: Double value
46: \ D^ Double address
47: \ F: Float value
48: \ F^ Float address
49: \ C: Char value
50: \ C^ Char address
51:
52: \ The local variables are initialized with values from the appropriate
53: \ stack. In contrast to the examples in the standard document our locals
54: \ take the arguments in the expected way: The last local gets the top of
55: \ stack, the second last gets the second stack item etc. An example:
56:
57: \ : CX* { F: Ar F: Ai F: Br F: Bi -- Cr Ci }
58: \ \ complex multiplication
59: \ Ar Br f* Ai Bi f* f-
60: \ Ar Bi f* Ai Br f* f+ ;
61:
62: \ There will also be a way to add user types, but it is not yet decided,
63: \ how. Ideas are welcome.
64:
65: \ Locals defined in this manner live until (!! see below).
66: \ Their names can be used during this time to get
67: \ their value or address; The addresses produced in this way become
68: \ invalid at the end of the lifetime.
69:
70: \ Values can be changed with TO, but this is not recomended (TO is a
71: \ kludge and words lose the single-assignment property, which makes them
72: \ harder to analyse).
73:
74: \ As for the internals, we use a special locals stack. This eliminates
75: \ the problems and restrictions of reusing the return stack and allows
76: \ to store floats as locals: the return stack is not guaranteed to be
77: \ aligned correctly, but our locals stack must be float-aligned between
78: \ words.
79:
80: \ Other things about the internals are pretty unclear now.
81:
82: \ Currently locals may only be
83: \ defined at the outer level and TO is not supported.
84:
85: require search-order.fs
86: require float.fs
87:
88: : compile-@local ( n -- ) \ gforth compile-fetch-local
89: case
90: 0 of postpone @local0 endof
91: 1 cells of postpone @local1 endof
92: 2 cells of postpone @local2 endof
93: 3 cells of postpone @local3 endof
94: ( otherwise ) dup postpone @local# ,
95: endcase ;
96:
97: : compile-f@local ( n -- ) \ gforth compile-f-fetch-local
98: case
99: 0 of postpone f@local0 endof
100: 1 floats of postpone f@local1 endof
101: ( otherwise ) dup postpone f@local# ,
102: endcase ;
103:
104: \ the locals stack grows downwards (see primitives)
105: \ of the local variables of a group (in braces) the leftmost is on top,
106: \ i.e. by going onto the locals stack the order is reversed.
107: \ there are alignment gaps if necessary.
108: \ lp must have the strictest alignment (usually float) across calls;
109: \ for simplicity we align it strictly for every group.
110:
111: slowvoc @
112: slowvoc on \ we want a linked list for the vocabulary locals
113: vocabulary locals \ this contains the local variables
114: ' locals >body ' locals-list >body !
115: slowvoc !
116:
117: create locals-buffer 1000 allot \ !! limited and unsafe
118: \ here the names of the local variables are stored
119: \ we would have problems storing them at the normal dp
120:
121: variable locals-dp \ so here's the special dp for locals.
122:
123: : alignlp-w ( n1 -- n2 )
124: \ cell-align size and generate the corresponding code for aligning lp
125: aligned dup adjust-locals-size ;
126:
127: : alignlp-f ( n1 -- n2 )
128: faligned dup adjust-locals-size ;
129:
130: \ a local declaration group (the braces stuff) is compiled by calling
131: \ the appropriate compile-pushlocal for the locals, starting with the
132: \ righmost local; the names are already created earlier, the
133: \ compile-pushlocal just inserts the offsets from the frame base.
134:
135: : compile-pushlocal-w ( a-addr -- ) ( run-time: w -- )
136: \ compiles a push of a local variable, and adjusts locals-size
137: \ stores the offset of the local variable to a-addr
138: locals-size @ alignlp-w cell+ dup locals-size !
139: swap !
140: postpone >l ;
141:
142: : compile-pushlocal-f ( a-addr -- ) ( run-time: f -- )
143: locals-size @ alignlp-f float+ dup locals-size !
144: swap !
145: postpone f>l ;
146:
147: : compile-pushlocal-d ( a-addr -- ) ( run-time: w1 w2 -- )
148: locals-size @ alignlp-w cell+ cell+ dup locals-size !
149: swap !
150: postpone swap postpone >l postpone >l ;
151:
152: : compile-pushlocal-c ( a-addr -- ) ( run-time: w -- )
153: -1 chars compile-lp+!
154: locals-size @ swap !
155: postpone lp@ postpone c! ;
156:
157: : create-local ( " name" -- a-addr )
158: \ defines the local "name"; the offset of the local shall be
159: \ stored in a-addr
160: create
161: immediate restrict
162: here 0 , ( place for the offset ) ;
163:
164: : lp-offset ( n1 -- n2 )
165: \ converts the offset from the frame start to an offset from lp and
166: \ i.e., the address of the local is lp+locals_size-offset
167: locals-size @ swap - ;
168:
169: : lp-offset, ( n -- )
170: \ converts the offset from the frame start to an offset from lp and
171: \ adds it as inline argument to a preceding locals primitive
172: lp-offset , ;
173:
174: vocabulary locals-types \ this contains all the type specifyers, -- and }
175: locals-types definitions
176:
177: : W: ( "name" -- a-addr xt ) \ gforth w-colon
178: create-local
179: \ xt produces the appropriate locals pushing code when executed
180: ['] compile-pushlocal-w
181: does> ( Compilation: -- ) ( Run-time: -- w )
182: \ compiles a local variable access
183: @ lp-offset compile-@local ;
184:
185: : W^ ( "name" -- a-addr xt ) \ gforth w-caret
186: create-local
187: ['] compile-pushlocal-w
188: does> ( Compilation: -- ) ( Run-time: -- w )
189: postpone laddr# @ lp-offset, ;
190:
191: : F: ( "name" -- a-addr xt ) \ gforth f-colon
192: create-local
193: ['] compile-pushlocal-f
194: does> ( Compilation: -- ) ( Run-time: -- w )
195: @ lp-offset compile-f@local ;
196:
197: : F^ ( "name" -- a-addr xt ) \ gforth f-caret
198: create-local
199: ['] compile-pushlocal-f
200: does> ( Compilation: -- ) ( Run-time: -- w )
201: postpone laddr# @ lp-offset, ;
202:
203: : D: ( "name" -- a-addr xt ) \ gforth d-colon
204: create-local
205: ['] compile-pushlocal-d
206: does> ( Compilation: -- ) ( Run-time: -- w )
207: postpone laddr# @ lp-offset, postpone 2@ ;
208:
209: : D^ ( "name" -- a-addr xt ) \ gforth d-caret
210: create-local
211: ['] compile-pushlocal-d
212: does> ( Compilation: -- ) ( Run-time: -- w )
213: postpone laddr# @ lp-offset, ;
214:
215: : C: ( "name" -- a-addr xt ) \ gforth c-colon
216: create-local
217: ['] compile-pushlocal-c
218: does> ( Compilation: -- ) ( Run-time: -- w )
219: postpone laddr# @ lp-offset, postpone c@ ;
220:
221: : C^ ( "name" -- a-addr xt ) \ gforth c-caret
222: create-local
223: ['] compile-pushlocal-c
224: does> ( Compilation: -- ) ( Run-time: -- w )
225: postpone laddr# @ lp-offset, ;
226:
227: \ you may want to make comments in a locals definitions group:
228: ' \ alias \ immediate
229: ' ( alias ( immediate
230:
231: forth definitions
232:
233: \ the following gymnastics are for declaring locals without type specifier.
234: \ we exploit a feature of our dictionary: every wordlist
235: \ has it's own methods for finding words etc.
236: \ So we create a vocabulary new-locals, that creates a 'w:' local named x
237: \ when it is asked if it contains x.
238:
239: also locals-types
240:
241: : new-locals-find ( caddr u w -- nfa )
242: \ this is the find method of the new-locals vocabulary
243: \ make a new local with name caddr u; w is ignored
244: \ the returned nfa denotes a word that produces what W: produces
245: \ !! do the whole thing without nextname
246: drop nextname
247: ['] W: >name ;
248:
249: previous
250:
251: : new-locals-reveal ( -- )
252: true abort" this should not happen: new-locals-reveal" ;
253:
254: create new-locals-map ' new-locals-find A, ' new-locals-reveal A,
255:
256: vocabulary new-locals
257: new-locals-map ' new-locals >body cell+ A! \ !! use special access words
258:
259: variable old-dpp
260:
261: \ and now, finally, the user interface words
262: : { ( -- addr wid 0 ) \ gforth open-brace
263: dp old-dpp !
264: locals-dp dpp !
265: also new-locals
266: also get-current locals definitions locals-types
267: 0 TO locals-wordlist
268: 0 postpone [ ; immediate
269:
270: locals-types definitions
271:
272: : } ( addr wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace
273: \ ends locals definitions
274: ] old-dpp @ dpp !
275: begin
276: dup
277: while
278: execute
279: repeat
280: drop
281: locals-size @ alignlp-f locals-size ! \ the strictest alignment
282: set-current
283: previous previous
284: locals-list TO locals-wordlist ;
285:
286: : -- ( addr wid 0 ... -- ) \ gforth dash-dash
287: }
288: [char] } parse 2drop ;
289:
290: forth definitions
291:
292: \ A few thoughts on automatic scopes for locals and how they can be
293: \ implemented:
294:
295: \ We have to combine locals with the control structures. My basic idea
296: \ was to start the life of a local at the declaration point. The life
297: \ would end at any control flow join (THEN, BEGIN etc.) where the local
298: \ is lot live on both input flows (note that the local can still live in
299: \ other, later parts of the control flow). This would make a local live
300: \ as long as you expected and sometimes longer (e.g. a local declared in
301: \ a BEGIN..UNTIL loop would still live after the UNTIL).
302:
303: \ The following example illustrates the problems of this approach:
304:
305: \ { z }
306: \ if
307: \ { x }
308: \ begin
309: \ { y }
310: \ [ 1 cs-roll ] then
311: \ ...
312: \ until
313:
314: \ x lives only until the BEGIN, but the compiler does not know this
315: \ until it compiles the UNTIL (it can deduce it at the THEN, because at
316: \ that point x lives in no thread, but that does not help much). This is
317: \ solved by optimistically assuming at the BEGIN that x lives, but
318: \ warning at the UNTIL that it does not. The user is then responsible
319: \ for checking that x is only used where it lives.
320:
321: \ The produced code might look like this (leaving out alignment code):
322:
323: \ >l ( z )
324: \ ?branch <then>
325: \ >l ( x )
326: \ <begin>:
327: \ >l ( y )
328: \ lp+!# 8 ( RIP: x,y )
329: \ <then>:
330: \ ...
331: \ lp+!# -4 ( adjust lp to <begin> state )
332: \ ?branch <begin>
333: \ lp+!# 4 ( undo adjust )
334:
335: \ The BEGIN problem also has another incarnation:
336:
337: \ AHEAD
338: \ BEGIN
339: \ x
340: \ [ 1 CS-ROLL ] THEN
341: \ { x }
342: \ ...
343: \ UNTIL
344:
345: \ should be legal: The BEGIN is not a control flow join in this case,
346: \ since it cannot be entered from the top; therefore the definition of x
347: \ dominates the use. But the compiler processes the use first, and since
348: \ it does not look ahead to notice the definition, it will complain
349: \ about it. Here's another variation of this problem:
350:
351: \ IF
352: \ { x }
353: \ ELSE
354: \ ...
355: \ AHEAD
356: \ BEGIN
357: \ x
358: \ [ 2 CS-ROLL ] THEN
359: \ ...
360: \ UNTIL
361:
362: \ In this case x is defined before the use, and the definition dominates
363: \ the use, but the compiler does not know this until it processes the
364: \ UNTIL. So what should the compiler assume does live at the BEGIN, if
365: \ the BEGIN is not a control flow join? The safest assumption would be
366: \ the intersection of all locals lists on the control flow
367: \ stack. However, our compiler assumes that the same variables are live
368: \ as on the top of the control flow stack. This covers the following case:
369:
370: \ { x }
371: \ AHEAD
372: \ BEGIN
373: \ x
374: \ [ 1 CS-ROLL ] THEN
375: \ ...
376: \ UNTIL
377:
378: \ If this assumption is too optimistic, the compiler will warn the user.
379:
380: \ Implementation: migrated to kernal.fs
381:
382: \ THEN (another control flow from before joins the current one):
383: \ The new locals-list is the intersection of the current locals-list and
384: \ the orig-local-list. The new locals-size is the (alignment-adjusted)
385: \ size of the new locals-list. The following code is generated:
386: \ lp+!# (current-locals-size - orig-locals-size)
387: \ <then>:
388: \ lp+!# (orig-locals-size - new-locals-size)
389:
390: \ Of course "lp+!# 0" is not generated. Still this is admittedly a bit
391: \ inefficient, e.g. if there is a locals declaration between IF and
392: \ ELSE. However, if ELSE generates an appropriate "lp+!#" before the
393: \ branch, there will be none after the target <then>.
394:
395: \ explicit scoping
396:
397: : scope ( compilation -- scope ; run-time -- ) \ gforth
398: cs-push-part scopestart ; immediate
399:
400: : endscope ( compilation scope -- ; run-time -- ) \ gforth
401: scope?
402: drop
403: locals-list @ common-list
404: dup list-size adjust-locals-size
405: locals-list ! ; immediate
406:
407: \ adapt the hooks
408:
409: : locals-:-hook ( sys -- sys addr xt n )
410: \ addr is the nfa of the defined word, xt its xt
411: DEFERS :-hook
412: last @ lastcfa @
413: clear-leave-stack
414: 0 locals-size !
415: locals-buffer locals-dp !
416: 0 locals-list !
417: dead-code off
418: defstart ;
419:
420: : locals-;-hook ( sys addr xt sys -- sys )
421: def?
422: 0 TO locals-wordlist
423: 0 adjust-locals-size ( not every def ends with an exit )
424: lastcfa ! last !
425: DEFERS ;-hook ;
426:
427: ' locals-:-hook IS :-hook
428: ' locals-;-hook IS ;-hook
429:
430: \ The words in the locals dictionary space are not deleted until the end
431: \ of the current word. This is a bit too conservative, but very simple.
432:
433: \ There are a few cases to consider: (see above)
434:
435: \ after AGAIN, AHEAD, EXIT (the current control flow is dead):
436: \ We have to special-case the above cases against that. In this case the
437: \ things above are not control flow joins. Everything should be taken
438: \ over from the live flow. No lp+!# is generated.
439:
440: \ !! The lp gymnastics for UNTIL are also a real problem: locals cannot be
441: \ used in signal handlers (or anything else that may be called while
442: \ locals live beyond the lp) without changing the locals stack.
443:
444: \ About warning against uses of dead locals. There are several options:
445:
446: \ 1) Do not complain (After all, this is Forth;-)
447:
448: \ 2) Additional restrictions can be imposed so that the situation cannot
449: \ arise; the programmer would have to introduce explicit scoping
450: \ declarations in cases like the above one. I.e., complain if there are
451: \ locals that are live before the BEGIN but not before the corresponding
452: \ AGAIN (replace DO etc. for BEGIN and UNTIL etc. for AGAIN).
453:
454: \ 3) The real thing: i.e. complain, iff a local lives at a BEGIN, is
455: \ used on a path starting at the BEGIN, and does not live at the
456: \ corresponding AGAIN. This is somewhat hard to implement. a) How does
457: \ the compiler know when it is working on a path starting at a BEGIN
458: \ (consider "{ x } if begin [ 1 cs-roll ] else x endif again")? b) How
459: \ is the usage info stored?
460:
461: \ For now I'll resort to alternative 2. When it produces warnings they
462: \ will often be spurious, but warnings should be rare. And better
463: \ spurious warnings now and then than days of bug-searching.
464:
465: \ Explicit scoping of locals is implemented by cs-pushing the current
466: \ locals-list and -size (and an unused cell, to make the size equal to
467: \ the other entries) at the start of the scope, and restoring them at
468: \ the end of the scope to the intersection, like THEN does.
469:
470:
471: \ And here's finally the ANS standard stuff
472:
473: : (local) ( addr u -- ) \ local paren-local-paren
474: \ a little space-inefficient, but well deserved ;-)
475: \ In exchange, there are no restrictions whatsoever on using (local)
476: \ as long as you use it in a definition
477: dup
478: if
479: nextname POSTPONE { [ also locals-types ] W: } [ previous ]
480: else
481: 2drop
482: endif ;
483:
484: : >definer ( xt -- definer )
485: \ this gives a unique identifier for the way the xt was defined
486: \ words defined with different does>-codes have different definers
487: \ the definer can be used for comparison and in definer!
488: dup >code-address [ ' bits >code-address ] Literal =
489: \ !! this definition will not work on some implementations for `bits'
490: if \ if >code-address delivers the same value for all does>-def'd words
491: >does-code 1 or \ bit 0 marks special treatment for does codes
492: else
493: >code-address
494: then ;
495:
496: : definer! ( definer xt -- )
497: \ gives the word represented by xt the behaviour associated with definer
498: over 1 and if
499: swap [ 1 invert ] literal and does-code!
500: else
501: code-address!
502: then ;
503:
504: \ !! untested
505: : TO ( c|w|d|r "name" -- ) \ core-ext,local
506: \ !! state smart
507: 0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
508: ' dup >definer
509: state @
510: if
511: case
512: [ ' locals-wordlist >definer ] literal \ value
513: OF >body POSTPONE Aliteral POSTPONE ! ENDOF
514: [ ' clocal >definer ] literal
515: OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
516: [ ' wlocal >definer ] literal
517: OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
518: [ ' dlocal >definer ] literal
519: OF POSTPONE laddr# >body @ lp-offset, POSTPONE d! ENDOF
520: [ ' flocal >definer ] literal
521: OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
522: -&32 throw
523: endcase
524: else
525: [ ' locals-wordlist >definer ] literal =
526: if
527: >body !
528: else
529: -&32 throw
530: endif
531: endif ; immediate
532:
533: : locals|
534: \ don't use 'locals|'! use '{'! A portable and free '{'
535: \ implementation is anslocals.fs
536: BEGIN
537: name 2dup s" |" compare 0<>
538: WHILE
539: (local)
540: REPEAT
541: drop 0 (local) ; immediate restrict
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to glocals.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth