1: \ A powerful locals implementation
2:
3: \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2007,2011 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 3
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, see http://www.gnu.org/licenses/.
19:
20:
21: \ More documentation can be found in the manual and in
22: \ http://www.complang.tuwien.ac.at/papers/ertl94l.ps.gz
23:
24: \ Local variables are quite important for writing readable programs, but
25: \ IMO (anton) they are the worst part of the standard. There they are very
26: \ restricted and have an ugly interface.
27:
28: \ So, we implement the locals wordset, but do not recommend using
29: \ locals-ext (which is a really bad user interface for locals).
30:
31: \ We also have a nice and powerful user-interface for locals: locals are
32: \ defined with
33:
34: \ { local1 local2 ... }
35: \ or
36: \ { local1 local2 ... -- ... }
37: \ (anything after the -- is just a comment)
38:
39: \ Every local in this list consists of an optional type specification
40: \ and a name. If there is only the name, it stands for a cell-sized
41: \ value (i.e., you get the value of the local variable, not it's
42: \ address). The following type specifiers stand before the name:
43:
44: \ Specifier Type Access
45: \ W: Cell value
46: \ W^ Cell address
47: \ D: Double value
48: \ D^ Double address
49: \ F: Float value
50: \ F^ Float address
51: \ C: Char value
52: \ C^ Char address
53:
54: \ The local variables are initialized with values from the appropriate
55: \ stack. In contrast to the examples in the standard document our locals
56: \ take the arguments in the expected way: The last local gets the top of
57: \ stack, the second last gets the second stack item etc. An example:
58:
59: \ : CX* { F: Ar F: Ai F: Br F: Bi -- Cr Ci }
60: \ \ complex multiplication
61: \ Ar Br f* Ai Bi f* f-
62: \ Ar Bi f* Ai Br f* f+ ;
63:
64: \ There will also be a way to add user types, but it is not yet decided,
65: \ how. Ideas are welcome.
66:
67: \ Locals defined in this manner live until (!! see below).
68: \ Their names can be used during this time to get
69: \ their value or address; The addresses produced in this way become
70: \ invalid at the end of the lifetime.
71:
72: \ Values can be changed with TO, but this is not recomended (TO is a
73: \ kludge and words lose the single-assignment property, which makes them
74: \ harder to analyse).
75:
76: \ As for the internals, we use a special locals stack. This eliminates
77: \ the problems and restrictions of reusing the return stack and allows
78: \ to store floats as locals: the return stack is not guaranteed to be
79: \ aligned correctly, but our locals stack must be float-aligned between
80: \ words.
81:
82: \ Other things about the internals are pretty unclear now.
83:
84: \ Currently locals may only be
85: \ defined at the outer level and TO is not supported.
86:
87: require search.fs
88: require float.fs
89: require extend.fs \ for case
90:
91: : compile-@local ( n -- ) \ gforth compile-fetch-local
92: case
93: 0 of postpone @local0 endof
94: 1 cells of postpone @local1 endof
95: 2 cells of postpone @local2 endof
96: 3 cells of postpone @local3 endof
97: ( otherwise ) dup postpone @local# ,
98: endcase ;
99:
100: : compile-f@local ( n -- ) \ gforth compile-f-fetch-local
101: case
102: 0 of postpone f@local0 endof
103: 1 floats of postpone f@local1 endof
104: ( otherwise ) dup postpone f@local# ,
105: endcase ;
106:
107: \ locals stuff needed for control structures
108:
109: : compile-lp+! ( n -- ) \ gforth compile-l-p-plus-store
110: dup negate locals-size +!
111: 0 over = if
112: else -1 cells over = if postpone lp-
113: else 1 floats over = if postpone lp+
114: else 2 floats over = if postpone lp+2
115: else postpone lp+!# dup ,
116: then then then then drop ;
117:
118: : adjust-locals-size ( n -- ) \ gforth
119: \ sets locals-size to n and generates an appropriate lp+!
120: locals-size @ swap - compile-lp+! ;
121:
122: \ the locals stack grows downwards (see primitives)
123: \ of the local variables of a group (in braces) the leftmost is on top,
124: \ i.e. by going onto the locals stack the order is reversed.
125: \ there are alignment gaps if necessary.
126: \ lp must have the strictest alignment (usually float) across calls;
127: \ for simplicity we align it strictly for every group.
128:
129: slowvoc @
130: slowvoc on \ we want a linked list for the vocabulary locals
131: vocabulary locals \ this contains the local variables
132: ' locals >body wordlist-id ' locals-list >body !
133: slowvoc !
134:
135: variable locals-mem-list \ linked list of all locals name memory in
136: 0 locals-mem-list ! \ the current (outer-level) definition
137:
138: : free-list ( addr -- )
139: \ free all members of a linked list (link field is first)
140: begin
141: dup while
142: dup @ swap free throw
143: repeat
144: drop ;
145:
146: : prepend-list ( addr1 addr2 -- )
147: \ addr1 is the address of a list element, addr2 is the address of
148: \ the cell containing the address of the first list element
149: 2dup @ swap ! \ store link to next element
150: ! ; \ store pointer to new first element
151:
152: : alignlp-w ( n1 -- n2 )
153: \ cell-align size and generate the corresponding code for aligning lp
154: aligned dup adjust-locals-size ;
155:
156: : alignlp-f ( n1 -- n2 )
157: faligned dup adjust-locals-size ;
158:
159: \ a local declaration group (the braces stuff) is compiled by calling
160: \ the appropriate compile-pushlocal for the locals, starting with the
161: \ righmost local; the names are already created earlier, the
162: \ compile-pushlocal just inserts the offsets from the frame base.
163:
164: : compile-pushlocal-w ( a-addr -- ) ( run-time: w -- )
165: \ compiles a push of a local variable, and adjusts locals-size
166: \ stores the offset of the local variable to a-addr
167: locals-size @ alignlp-w cell+ dup locals-size !
168: swap !
169: postpone >l ;
170:
171: \ locals list operations
172:
173: : common-list ( list1 list2 -- list3 ) \ gforth-internal
174: \ list1 and list2 are lists, where the heads are at higher addresses than
175: \ the tail. list3 is the largest sublist of both lists.
176: begin
177: 2dup u<>
178: while
179: 2dup u>
180: if
181: swap
182: then
183: @
184: repeat
185: drop ;
186:
187: : sub-list? ( list1 list2 -- f ) \ gforth-internal
188: \ true iff list1 is a sublist of list2
189: begin
190: 2dup u<
191: while
192: @
193: repeat
194: = ;
195:
196: : list-size ( list -- u ) \ gforth-internal
197: \ size of the locals frame represented by list
198: 0 ( list n )
199: begin
200: over 0<>
201: while
202: over
203: ((name>)) >body @ max
204: swap @ swap ( get next )
205: repeat
206: faligned nip ;
207:
208: : set-locals-size-list ( list -- )
209: dup locals-list !
210: list-size locals-size ! ;
211:
212: : check-begin ( list -- )
213: \ warn if list is not a sublist of locals-list
214: locals-list @ sub-list? 0= if
215: \ !! print current position
216: >stderr ." compiler was overly optimistic about locals at a BEGIN" cr
217: \ !! print assumption and reality
218: then ;
219:
220: : compile-pushlocal-f ( a-addr -- ) ( run-time: f -- )
221: locals-size @ alignlp-f float+ dup locals-size !
222: swap !
223: postpone f>l ;
224:
225: : compile-pushlocal-d ( a-addr -- ) ( run-time: w1 w2 -- )
226: locals-size @ alignlp-w cell+ cell+ dup locals-size !
227: swap !
228: postpone swap postpone >l postpone >l ;
229:
230: : compile-pushlocal-c ( a-addr -- ) ( run-time: w -- )
231: -1 chars compile-lp+!
232: locals-size @ swap !
233: postpone lp@ postpone c! ;
234:
235: 7 cells 32 + constant locals-name-size \ 32-char name + fields + wiggle room
236:
237: : create-local1 ( "name" -- a-addr )
238: create
239: immediate restrict
240: here 0 , ( place for the offset ) ;
241:
242: variable dict-execute-dp \ the special dp for DICT-EXECUTE
243:
244: 0 value dict-execute-ude \ USABLE-DICTIONARY-END during DICT-EXECUTE
245:
246: : dict-execute1 ( ... addr1 addr2 xt -- ... )
247: \ execute xt with HERE set to addr1 and USABLE-DICTIONARY-END set to addr2
248: dict-execute-dp @ dp 2>r
249: dict-execute-ude ['] usable-dictionary-end defer@ 2>r
250: swap to dict-execute-ude
251: ['] dict-execute-ude is usable-dictionary-end
252: swap to dict-execute-dp
253: dict-execute-dp dpp !
254: catch
255: 2r> is usable-dictionary-end to dict-execute-ude
256: 2r> dpp ! dict-execute-dp !
257: throw ;
258:
259: defer dict-execute ( ... addr1 addr2 xt -- ... )
260:
261: :noname ( ... addr1 addr2 xt -- ... )
262: \ first have a dummy routine, for SOME-CLOCAL etc. below
263: nip nip execute ;
264: is dict-execute
265:
266: : create-local ( " name" -- a-addr )
267: \ defines the local "name"; the offset of the local shall be
268: \ stored in a-addr
269: locals-name-size allocate throw
270: dup locals-mem-list prepend-list
271: locals-name-size cell /string over + ['] create-local1 dict-execute ;
272:
273: variable locals-dp \ so here's the special dp for locals.
274:
275: : lp-offset ( n1 -- n2 )
276: \ converts the offset from the frame start to an offset from lp and
277: \ i.e., the address of the local is lp+locals_size-offset
278: locals-size @ swap - ;
279:
280: : lp-offset, ( n -- )
281: \ converts the offset from the frame start to an offset from lp and
282: \ adds it as inline argument to a preceding locals primitive
283: lp-offset , ;
284:
285: vocabulary locals-types \ this contains all the type specifyers, -- and }
286: locals-types definitions
287:
288: : W: ( "name" -- a-addr xt ) \ gforth w-colon
289: create-local
290: \ xt produces the appropriate locals pushing code when executed
291: ['] compile-pushlocal-w
292: does> ( Compilation: -- ) ( Run-time: -- w )
293: \ compiles a local variable access
294: @ lp-offset compile-@local ;
295:
296: : W^ ( "name" -- a-addr xt ) \ gforth w-caret
297: create-local
298: ['] compile-pushlocal-w
299: does> ( Compilation: -- ) ( Run-time: -- w )
300: postpone laddr# @ lp-offset, ;
301:
302: : F: ( "name" -- a-addr xt ) \ gforth f-colon
303: create-local
304: ['] compile-pushlocal-f
305: does> ( Compilation: -- ) ( Run-time: -- w )
306: @ lp-offset compile-f@local ;
307:
308: : F^ ( "name" -- a-addr xt ) \ gforth f-caret
309: create-local
310: ['] compile-pushlocal-f
311: does> ( Compilation: -- ) ( Run-time: -- w )
312: postpone laddr# @ lp-offset, ;
313:
314: : D: ( "name" -- a-addr xt ) \ gforth d-colon
315: create-local
316: ['] compile-pushlocal-d
317: does> ( Compilation: -- ) ( Run-time: -- w )
318: postpone laddr# @ lp-offset, postpone 2@ ;
319:
320: : D^ ( "name" -- a-addr xt ) \ gforth d-caret
321: create-local
322: ['] compile-pushlocal-d
323: does> ( Compilation: -- ) ( Run-time: -- w )
324: postpone laddr# @ lp-offset, ;
325:
326: : C: ( "name" -- a-addr xt ) \ gforth c-colon
327: create-local
328: ['] compile-pushlocal-c
329: does> ( Compilation: -- ) ( Run-time: -- w )
330: postpone laddr# @ lp-offset, postpone c@ ;
331:
332: : C^ ( "name" -- a-addr xt ) \ gforth c-caret
333: create-local
334: ['] compile-pushlocal-c
335: does> ( Compilation: -- ) ( Run-time: -- w )
336: postpone laddr# @ lp-offset, ;
337:
338: \ you may want to make comments in a locals definitions group:
339: ' \ alias \ ( compilation 'ccc<newline>' -- ; run-time -- ) \ core-ext,block-ext backslash
340: \G Comment till the end of the line if @code{BLK} contains 0 (i.e.,
341: \G while not loading a block), parse and discard the remainder of the
342: \G parse area. Otherwise, parse and discard all subsequent characters
343: \G in the parse area corresponding to the current line.
344: immediate
345:
346: ' ( alias ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren
347: \G Comment, usually till the next @code{)}: parse and discard all
348: \G subsequent characters in the parse area until ")" is
349: \G encountered. During interactive input, an end-of-line also acts as
350: \G a comment terminator. For file input, it does not; if the
351: \G end-of-file is encountered whilst parsing for the ")" delimiter,
352: \G Gforth will generate a warning.
353: immediate
354:
355: forth definitions
356: also locals-types
357:
358: \ these "locals" are used for comparison in TO
359: c: some-clocal 2drop
360: d: some-dlocal 2drop
361: f: some-flocal 2drop
362: w: some-wlocal 2drop
363:
364: ' dict-execute1 is dict-execute \ now the real thing
365:
366: \ the following gymnastics are for declaring locals without type specifier.
367: \ we exploit a feature of our dictionary: every wordlist
368: \ has it's own methods for finding words etc.
369: \ So we create a vocabulary new-locals, that creates a 'w:' local named x
370: \ when it is asked if it contains x.
371:
372: : new-locals-find ( caddr u w -- nfa )
373: \ this is the find method of the new-locals vocabulary
374: \ make a new local with name caddr u; w is ignored
375: \ the returned nfa denotes a word that produces what W: produces
376: \ !! do the whole thing without nextname
377: drop nextname
378: ['] W: >head-noprim ;
379:
380: previous
381:
382: : new-locals-reveal ( -- )
383: true abort" this should not happen: new-locals-reveal" ;
384:
385: create new-locals-map ( -- wordlist-map )
386: ' new-locals-find A,
387: ' new-locals-reveal A,
388: ' drop A, \ rehash method
389: ' drop A,
390:
391: new-locals-map mappedwordlist Constant new-locals-wl
392:
393: \ slowvoc @
394: \ slowvoc on
395: \ vocabulary new-locals
396: \ slowvoc !
397: \ new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words
398:
399: \ and now, finally, the user interface words
400: : { ( -- latestxt wid 0 ) \ gforth open-brace
401: latestxt get-current
402: get-order new-locals-wl swap 1+ set-order
403: also locals definitions locals-types
404: 0 TO locals-wordlist
405: 0 postpone [ ; immediate
406:
407: locals-types definitions
408:
409: : } ( latestxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace
410: \ ends locals definitions
411: ]
412: begin
413: dup
414: while
415: execute
416: repeat
417: drop
418: locals-size @ alignlp-f locals-size ! \ the strictest alignment
419: previous previous
420: set-current lastcfa !
421: locals-list 0 wordlist-id - TO locals-wordlist ;
422:
423: : -- ( addr wid 0 ... -- ) \ gforth dash-dash
424: }
425: [char] } parse 2drop ;
426:
427: forth definitions
428:
429: \ A few thoughts on automatic scopes for locals and how they can be
430: \ implemented:
431:
432: \ We have to combine locals with the control structures. My basic idea
433: \ was to start the life of a local at the declaration point. The life
434: \ would end at any control flow join (THEN, BEGIN etc.) where the local
435: \ is lot live on both input flows (note that the local can still live in
436: \ other, later parts of the control flow). This would make a local live
437: \ as long as you expected and sometimes longer (e.g. a local declared in
438: \ a BEGIN..UNTIL loop would still live after the UNTIL).
439:
440: \ The following example illustrates the problems of this approach:
441:
442: \ { z }
443: \ if
444: \ { x }
445: \ begin
446: \ { y }
447: \ [ 1 cs-roll ] then
448: \ ...
449: \ until
450:
451: \ x lives only until the BEGIN, but the compiler does not know this
452: \ until it compiles the UNTIL (it can deduce it at the THEN, because at
453: \ that point x lives in no thread, but that does not help much). This is
454: \ solved by optimistically assuming at the BEGIN that x lives, but
455: \ warning at the UNTIL that it does not. The user is then responsible
456: \ for checking that x is only used where it lives.
457:
458: \ The produced code might look like this (leaving out alignment code):
459:
460: \ >l ( z )
461: \ ?branch <then>
462: \ >l ( x )
463: \ <begin>:
464: \ >l ( y )
465: \ lp+!# 8 ( RIP: x,y )
466: \ <then>:
467: \ ...
468: \ lp+!# -4 ( adjust lp to <begin> state )
469: \ ?branch <begin>
470: \ lp+!# 4 ( undo adjust )
471:
472: \ The BEGIN problem also has another incarnation:
473:
474: \ AHEAD
475: \ BEGIN
476: \ x
477: \ [ 1 CS-ROLL ] THEN
478: \ { x }
479: \ ...
480: \ UNTIL
481:
482: \ should be legal: The BEGIN is not a control flow join in this case,
483: \ since it cannot be entered from the top; therefore the definition of x
484: \ dominates the use. But the compiler processes the use first, and since
485: \ it does not look ahead to notice the definition, it will complain
486: \ about it. Here's another variation of this problem:
487:
488: \ IF
489: \ { x }
490: \ ELSE
491: \ ...
492: \ AHEAD
493: \ BEGIN
494: \ x
495: \ [ 2 CS-ROLL ] THEN
496: \ ...
497: \ UNTIL
498:
499: \ In this case x is defined before the use, and the definition dominates
500: \ the use, but the compiler does not know this until it processes the
501: \ UNTIL. So what should the compiler assume does live at the BEGIN, if
502: \ the BEGIN is not a control flow join? The safest assumption would be
503: \ the intersection of all locals lists on the control flow
504: \ stack. However, our compiler assumes that the same variables are live
505: \ as on the top of the control flow stack. This covers the following case:
506:
507: \ { x }
508: \ AHEAD
509: \ BEGIN
510: \ x
511: \ [ 1 CS-ROLL ] THEN
512: \ ...
513: \ UNTIL
514:
515: \ If this assumption is too optimistic, the compiler will warn the user.
516:
517: \ Implementation:
518:
519: \ explicit scoping
520:
521: : scope ( compilation -- scope ; run-time -- ) \ gforth
522: cs-push-part scopestart ; immediate
523:
524: : adjust-locals-list ( wid -- )
525: locals-list @ common-list
526: dup list-size adjust-locals-size
527: locals-list ! ;
528:
529: : endscope ( compilation scope -- ; run-time -- ) \ gforth
530: scope?
531: drop adjust-locals-list ; immediate
532:
533: \ adapt the hooks
534:
535: : locals-:-hook ( sys -- sys addr xt n )
536: \ addr is the nfa of the defined word, xt its xt
537: DEFERS :-hook
538: latest latestxt
539: clear-leave-stack
540: 0 locals-size !
541: locals-mem-list @ free-list
542: 0 locals-mem-list !
543: 0 locals-list !
544: dead-code off
545: defstart ;
546:
547: : locals-;-hook ( sys addr xt sys -- sys )
548: def?
549: 0 TO locals-wordlist
550: 0 adjust-locals-size ( not every def ends with an exit )
551: lastcfa ! last !
552: DEFERS ;-hook ;
553:
554: \ THEN (another control flow from before joins the current one):
555: \ The new locals-list is the intersection of the current locals-list and
556: \ the orig-local-list. The new locals-size is the (alignment-adjusted)
557: \ size of the new locals-list. The following code is generated:
558: \ lp+!# (current-locals-size - orig-locals-size)
559: \ <then>:
560: \ lp+!# (orig-locals-size - new-locals-size)
561:
562: \ Of course "lp+!# 0" is not generated. Still this is admittedly a bit
563: \ inefficient, e.g. if there is a locals declaration between IF and
564: \ ELSE. However, if ELSE generates an appropriate "lp+!#" before the
565: \ branch, there will be none after the target <then>.
566:
567: : (then-like) ( orig -- )
568: dead-orig =
569: if
570: >resolve drop
571: else
572: dead-code @
573: if
574: >resolve set-locals-size-list dead-code off
575: else \ both live
576: over list-size adjust-locals-size
577: >resolve
578: adjust-locals-list
579: then
580: then ;
581:
582: : (begin-like) ( -- )
583: dead-code @ if
584: \ set up an assumption of the locals visible here. if the
585: \ users want something to be visible, they have to declare
586: \ that using ASSUME-LIVE
587: backedge-locals @ set-locals-size-list
588: then
589: dead-code off ;
590:
591: \ AGAIN (the current control flow joins another, earlier one):
592: \ If the dest-locals-list is not a subset of the current locals-list,
593: \ issue a warning (see below). The following code is generated:
594: \ lp+!# (current-local-size - dest-locals-size)
595: \ branch <begin>
596:
597: : (again-like) ( dest -- addr )
598: over list-size adjust-locals-size
599: swap check-begin POSTPONE unreachable ;
600:
601: \ UNTIL (the current control flow may join an earlier one or continue):
602: \ Similar to AGAIN. The new locals-list and locals-size are the current
603: \ ones. The following code is generated:
604: \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size)
605:
606: : (until-like) ( list addr xt1 xt2 -- )
607: \ list and addr are a fragment of a cs-item
608: \ xt1 is the conditional branch without lp adjustment, xt2 is with
609: >r >r
610: locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment )
611: r> drop r> compile,
612: swap <resolve ( list adjustment ) ,
613: else ( list dest-addr adjustment )
614: drop
615: r> compile, <resolve
616: r> drop
617: then ( list )
618: check-begin ;
619:
620: : (exit-like) ( -- )
621: 0 adjust-locals-size ;
622:
623: ' locals-:-hook IS :-hook
624: ' locals-;-hook IS ;-hook
625:
626: ' (then-like) IS then-like
627: ' (begin-like) IS begin-like
628: ' (again-like) IS again-like
629: ' (until-like) IS until-like
630: ' (exit-like) IS exit-like
631:
632: \ The words in the locals dictionary space are not deleted until the end
633: \ of the current word. This is a bit too conservative, but very simple.
634:
635: \ There are a few cases to consider: (see above)
636:
637: \ after AGAIN, AHEAD, EXIT (the current control flow is dead):
638: \ We have to special-case the above cases against that. In this case the
639: \ things above are not control flow joins. Everything should be taken
640: \ over from the live flow. No lp+!# is generated.
641:
642: \ About warning against uses of dead locals. There are several options:
643:
644: \ 1) Do not complain (After all, this is Forth;-)
645:
646: \ 2) Additional restrictions can be imposed so that the situation cannot
647: \ arise; the programmer would have to introduce explicit scoping
648: \ declarations in cases like the above one. I.e., complain if there are
649: \ locals that are live before the BEGIN but not before the corresponding
650: \ AGAIN (replace DO etc. for BEGIN and UNTIL etc. for AGAIN).
651:
652: \ 3) The real thing: i.e. complain, iff a local lives at a BEGIN, is
653: \ used on a path starting at the BEGIN, and does not live at the
654: \ corresponding AGAIN. This is somewhat hard to implement. a) How does
655: \ the compiler know when it is working on a path starting at a BEGIN
656: \ (consider "{ x } if begin [ 1 cs-roll ] else x endif again")? b) How
657: \ is the usage info stored?
658:
659: \ For now I'll resort to alternative 2. When it produces warnings they
660: \ will often be spurious, but warnings should be rare. And better
661: \ spurious warnings now and then than days of bug-searching.
662:
663: \ Explicit scoping of locals is implemented by cs-pushing the current
664: \ locals-list and -size (and an unused cell, to make the size equal to
665: \ the other entries) at the start of the scope, and restoring them at
666: \ the end of the scope to the intersection, like THEN does.
667:
668:
669: \ And here's finally the ANS standard stuff
670:
671: : (local) ( addr u -- ) \ local paren-local-paren
672: \ a little space-inefficient, but well deserved ;-)
673: \ In exchange, there are no restrictions whatsoever on using (local)
674: \ as long as you use it in a definition
675: dup
676: if
677: nextname POSTPONE { [ also locals-types ] W: } [ previous ]
678: else
679: 2drop
680: endif ;
681:
682: : >definer ( xt -- definer ) \ gforth
683: \G @var{Definer} is a unique identifier for the way the @var{xt}
684: \G was defined. Words defined with different @code{does>}-codes
685: \G have different definers. The definer can be used for
686: \G comparison and in @code{definer!}.
687: dup >does-code
688: ?dup-if
689: nip 1 or
690: else
691: >code-address
692: then ;
693:
694: : definer! ( definer xt -- ) \ gforth
695: \G The word represented by @var{xt} changes its behaviour to the
696: \G behaviour associated with @var{definer}.
697: over 1 and if
698: swap [ 1 invert ] literal and does-code!
699: else
700: code-address!
701: then ;
702:
703: :noname
704: ' dup >definer [ ' locals-wordlist ] literal >definer =
705: if
706: >body !
707: else
708: -&32 throw
709: endif ;
710: :noname
711: comp' drop dup >definer
712: case
713: [ ' locals-wordlist ] literal >definer \ value
714: OF >body POSTPONE Aliteral POSTPONE ! ENDOF
715: \ !! dependent on c: etc. being does>-defining words
716: \ this works, because >definer uses >does-code in this case,
717: \ which produces a relocatable address
718: [ comp' some-clocal drop ] literal >definer
719: OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
720: [ comp' some-wlocal drop ] literal >definer
721: OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
722: [ comp' some-dlocal drop ] literal >definer
723: OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF
724: [ comp' some-flocal drop ] literal >definer
725: OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
726: -&32 throw
727: endcase ;
728: interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local
729:
730: : locals| ( ... "name ..." -- ) \ local-ext locals-bar
731: \ don't use 'locals|'! use '{'! A portable and free '{'
732: \ implementation is compat/anslocals.fs
733: BEGIN
734: name 2dup s" |" str= 0=
735: WHILE
736: (local)
737: REPEAT
738: drop 0 (local) ; immediate restrict
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>