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