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