Annotation of gforth/glocals.fs, revision 1.52
1.15 anton 1: \ A powerful locals implementation
2:
1.52 ! anton 3: \ Copyright (C) 1995,1996,1997,1998,2000,2003 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
313:
314: \ the following gymnastics are for declaring locals without type specifier.
315: \ we exploit a feature of our dictionary: every wordlist
316: \ has it's own methods for finding words etc.
317: \ So we create a vocabulary new-locals, that creates a 'w:' local named x
318: \ when it is asked if it contains x.
319:
320: also locals-types
321:
322: : new-locals-find ( caddr u w -- nfa )
323: \ this is the find method of the new-locals vocabulary
324: \ make a new local with name caddr u; w is ignored
325: \ the returned nfa denotes a word that produces what W: produces
326: \ !! do the whole thing without nextname
1.3 anton 327: drop nextname
1.43 anton 328: ['] W: >head-noprim ;
1.1 anton 329:
330: previous
331:
332: : new-locals-reveal ( -- )
333: true abort" this should not happen: new-locals-reveal" ;
334:
1.22 anton 335: create new-locals-map ( -- wordlist-map )
1.29 anton 336: ' new-locals-find A,
337: ' new-locals-reveal A,
338: ' drop A, \ rehash method
1.34 jwilke 339: ' drop A,
1.1 anton 340:
1.41 jwilke 341: new-locals-map mappedwordlist Constant new-locals-wl
342:
343: \ slowvoc @
344: \ slowvoc on
345: \ vocabulary new-locals
346: \ slowvoc !
347: \ new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words
1.1 anton 348:
349: variable old-dpp
350:
351: \ and now, finally, the user interface words
1.32 anton 352: : { ( -- lastxt wid 0 ) \ gforth open-brace
1.1 anton 353: dp old-dpp !
354: locals-dp dpp !
1.32 anton 355: lastxt get-current
1.41 jwilke 356: get-order new-locals-wl swap 1+ set-order
1.32 anton 357: also locals definitions locals-types
1.1 anton 358: 0 TO locals-wordlist
359: 0 postpone [ ; immediate
360:
361: locals-types definitions
362:
1.32 anton 363: : } ( lastxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace
1.1 anton 364: \ ends locals definitions
365: ] old-dpp @ dpp !
366: begin
367: dup
368: while
369: execute
370: repeat
371: drop
372: locals-size @ alignlp-f locals-size ! \ the strictest alignment
373: previous previous
1.32 anton 374: set-current lastcfa !
1.37 pazsan 375: locals-list 0 wordlist-id - TO locals-wordlist ;
1.1 anton 376:
1.14 anton 377: : -- ( addr wid 0 ... -- ) \ gforth dash-dash
1.1 anton 378: }
1.9 anton 379: [char] } parse 2drop ;
1.1 anton 380:
381: forth definitions
382:
383: \ A few thoughts on automatic scopes for locals and how they can be
384: \ implemented:
385:
386: \ We have to combine locals with the control structures. My basic idea
387: \ was to start the life of a local at the declaration point. The life
388: \ would end at any control flow join (THEN, BEGIN etc.) where the local
389: \ is lot live on both input flows (note that the local can still live in
390: \ other, later parts of the control flow). This would make a local live
391: \ as long as you expected and sometimes longer (e.g. a local declared in
392: \ a BEGIN..UNTIL loop would still live after the UNTIL).
393:
394: \ The following example illustrates the problems of this approach:
395:
396: \ { z }
397: \ if
398: \ { x }
399: \ begin
400: \ { y }
401: \ [ 1 cs-roll ] then
402: \ ...
403: \ until
404:
405: \ x lives only until the BEGIN, but the compiler does not know this
406: \ until it compiles the UNTIL (it can deduce it at the THEN, because at
407: \ that point x lives in no thread, but that does not help much). This is
408: \ solved by optimistically assuming at the BEGIN that x lives, but
409: \ warning at the UNTIL that it does not. The user is then responsible
410: \ for checking that x is only used where it lives.
411:
412: \ The produced code might look like this (leaving out alignment code):
413:
414: \ >l ( z )
415: \ ?branch <then>
416: \ >l ( x )
417: \ <begin>:
418: \ >l ( y )
419: \ lp+!# 8 ( RIP: x,y )
420: \ <then>:
421: \ ...
422: \ lp+!# -4 ( adjust lp to <begin> state )
423: \ ?branch <begin>
424: \ lp+!# 4 ( undo adjust )
425:
426: \ The BEGIN problem also has another incarnation:
427:
428: \ AHEAD
429: \ BEGIN
430: \ x
431: \ [ 1 CS-ROLL ] THEN
432: \ { x }
433: \ ...
434: \ UNTIL
435:
436: \ should be legal: The BEGIN is not a control flow join in this case,
437: \ since it cannot be entered from the top; therefore the definition of x
438: \ dominates the use. But the compiler processes the use first, and since
439: \ it does not look ahead to notice the definition, it will complain
440: \ about it. Here's another variation of this problem:
441:
442: \ IF
443: \ { x }
444: \ ELSE
445: \ ...
446: \ AHEAD
447: \ BEGIN
448: \ x
449: \ [ 2 CS-ROLL ] THEN
450: \ ...
451: \ UNTIL
452:
453: \ In this case x is defined before the use, and the definition dominates
454: \ the use, but the compiler does not know this until it processes the
455: \ UNTIL. So what should the compiler assume does live at the BEGIN, if
456: \ the BEGIN is not a control flow join? The safest assumption would be
457: \ the intersection of all locals lists on the control flow
458: \ stack. However, our compiler assumes that the same variables are live
459: \ as on the top of the control flow stack. This covers the following case:
460:
461: \ { x }
462: \ AHEAD
463: \ BEGIN
464: \ x
465: \ [ 1 CS-ROLL ] THEN
466: \ ...
467: \ UNTIL
468:
469: \ If this assumption is too optimistic, the compiler will warn the user.
470:
1.28 anton 471: \ Implementation:
1.1 anton 472:
1.3 anton 473: \ explicit scoping
1.1 anton 474:
1.14 anton 475: : scope ( compilation -- scope ; run-time -- ) \ gforth
1.36 pazsan 476: cs-push-part scopestart ; immediate
477:
478: : adjust-locals-list ( wid -- )
1.37 pazsan 479: locals-list @ common-list
1.36 pazsan 480: dup list-size adjust-locals-size
1.37 pazsan 481: locals-list ! ;
1.3 anton 482:
1.14 anton 483: : endscope ( compilation scope -- ; run-time -- ) \ gforth
1.36 pazsan 484: scope?
485: drop adjust-locals-list ; immediate
1.1 anton 486:
1.3 anton 487: \ adapt the hooks
1.1 anton 488:
1.3 anton 489: : locals-:-hook ( sys -- sys addr xt n )
490: \ addr is the nfa of the defined word, xt its xt
1.1 anton 491: DEFERS :-hook
492: last @ lastcfa @
493: clear-leave-stack
494: 0 locals-size !
495: locals-buffer locals-dp !
1.37 pazsan 496: 0 locals-list !
1.3 anton 497: dead-code off
498: defstart ;
1.1 anton 499:
1.3 anton 500: : locals-;-hook ( sys addr xt sys -- sys )
501: def?
1.1 anton 502: 0 TO locals-wordlist
1.3 anton 503: 0 adjust-locals-size ( not every def ends with an exit )
1.1 anton 504: lastcfa ! last !
505: DEFERS ;-hook ;
506:
1.28 anton 507: \ THEN (another control flow from before joins the current one):
508: \ The new locals-list is the intersection of the current locals-list and
509: \ the orig-local-list. The new locals-size is the (alignment-adjusted)
510: \ size of the new locals-list. The following code is generated:
511: \ lp+!# (current-locals-size - orig-locals-size)
512: \ <then>:
513: \ lp+!# (orig-locals-size - new-locals-size)
514:
515: \ Of course "lp+!# 0" is not generated. Still this is admittedly a bit
516: \ inefficient, e.g. if there is a locals declaration between IF and
517: \ ELSE. However, if ELSE generates an appropriate "lp+!#" before the
518: \ branch, there will be none after the target <then>.
519:
1.30 anton 520: : (then-like) ( orig -- )
521: dead-orig =
1.27 pazsan 522: if
1.30 anton 523: >resolve drop
1.27 pazsan 524: else
525: dead-code @
526: if
1.30 anton 527: >resolve set-locals-size-list dead-code off
1.27 pazsan 528: else \ both live
1.30 anton 529: over list-size adjust-locals-size
530: >resolve
1.36 pazsan 531: adjust-locals-list
1.27 pazsan 532: then
533: then ;
534:
535: : (begin-like) ( -- )
536: dead-code @ if
537: \ set up an assumption of the locals visible here. if the
538: \ users want something to be visible, they have to declare
539: \ that using ASSUME-LIVE
540: backedge-locals @ set-locals-size-list
541: then
542: dead-code off ;
543:
544: \ AGAIN (the current control flow joins another, earlier one):
545: \ If the dest-locals-list is not a subset of the current locals-list,
546: \ issue a warning (see below). The following code is generated:
547: \ lp+!# (current-local-size - dest-locals-size)
548: \ branch <begin>
549:
550: : (again-like) ( dest -- addr )
551: over list-size adjust-locals-size
552: swap check-begin POSTPONE unreachable ;
553:
554: \ UNTIL (the current control flow may join an earlier one or continue):
555: \ Similar to AGAIN. The new locals-list and locals-size are the current
556: \ ones. The following code is generated:
557: \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size)
558:
559: : (until-like) ( list addr xt1 xt2 -- )
560: \ list and addr are a fragment of a cs-item
561: \ xt1 is the conditional branch without lp adjustment, xt2 is with
562: >r >r
563: locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment )
564: r> drop r> compile,
565: swap <resolve ( list adjustment ) ,
566: else ( list dest-addr adjustment )
567: drop
568: r> compile, <resolve
569: r> drop
570: then ( list )
571: check-begin ;
572:
573: : (exit-like) ( -- )
574: 0 adjust-locals-size ;
575:
1.1 anton 576: ' locals-:-hook IS :-hook
577: ' locals-;-hook IS ;-hook
1.27 pazsan 578:
579: ' (then-like) IS then-like
580: ' (begin-like) IS begin-like
581: ' (again-like) IS again-like
582: ' (until-like) IS until-like
583: ' (exit-like) IS exit-like
1.1 anton 584:
585: \ The words in the locals dictionary space are not deleted until the end
586: \ of the current word. This is a bit too conservative, but very simple.
587:
588: \ There are a few cases to consider: (see above)
589:
590: \ after AGAIN, AHEAD, EXIT (the current control flow is dead):
591: \ We have to special-case the above cases against that. In this case the
592: \ things above are not control flow joins. Everything should be taken
593: \ over from the live flow. No lp+!# is generated.
594:
595: \ About warning against uses of dead locals. There are several options:
596:
597: \ 1) Do not complain (After all, this is Forth;-)
598:
599: \ 2) Additional restrictions can be imposed so that the situation cannot
600: \ arise; the programmer would have to introduce explicit scoping
601: \ declarations in cases like the above one. I.e., complain if there are
602: \ locals that are live before the BEGIN but not before the corresponding
603: \ AGAIN (replace DO etc. for BEGIN and UNTIL etc. for AGAIN).
604:
605: \ 3) The real thing: i.e. complain, iff a local lives at a BEGIN, is
606: \ used on a path starting at the BEGIN, and does not live at the
607: \ corresponding AGAIN. This is somewhat hard to implement. a) How does
608: \ the compiler know when it is working on a path starting at a BEGIN
609: \ (consider "{ x } if begin [ 1 cs-roll ] else x endif again")? b) How
610: \ is the usage info stored?
611:
612: \ For now I'll resort to alternative 2. When it produces warnings they
613: \ will often be spurious, but warnings should be rare. And better
614: \ spurious warnings now and then than days of bug-searching.
615:
616: \ Explicit scoping of locals is implemented by cs-pushing the current
617: \ locals-list and -size (and an unused cell, to make the size equal to
618: \ the other entries) at the start of the scope, and restoring them at
619: \ the end of the scope to the intersection, like THEN does.
620:
621:
622: \ And here's finally the ANS standard stuff
623:
1.14 anton 624: : (local) ( addr u -- ) \ local paren-local-paren
1.3 anton 625: \ a little space-inefficient, but well deserved ;-)
626: \ In exchange, there are no restrictions whatsoever on using (local)
1.4 anton 627: \ as long as you use it in a definition
1.3 anton 628: dup
629: if
630: nextname POSTPONE { [ also locals-types ] W: } [ previous ]
631: else
632: 2drop
633: endif ;
1.1 anton 634:
1.4 anton 635: : >definer ( xt -- definer )
1.48 anton 636: \G @var{Definer} is a unique identifier for the way the @var{xt}
637: \G was defined. Words defined with different @code{does>}-codes
638: \G have different definers. The definer can be used for
639: \G comparison and in @code{definer!}.
1.30 anton 640: dup >does-code
641: ?dup-if
642: nip 1 or
1.4 anton 643: else
644: >code-address
645: then ;
646:
647: : definer! ( definer xt -- )
1.48 anton 648: \G The word represented by @var{xt} changes its behaviour to the
649: \G behaviour associated with @var{definer}.
1.4 anton 650: over 1 and if
1.13 anton 651: swap [ 1 invert ] literal and does-code!
1.4 anton 652: else
653: code-address!
654: then ;
655:
1.23 pazsan 656: :noname
1.31 anton 657: ' dup >definer [ ' locals-wordlist ] literal >definer =
1.23 pazsan 658: if
659: >body !
660: else
661: -&32 throw
662: endif ;
663: :noname
1.21 anton 664: 0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
1.28 anton 665: comp' drop dup >definer
1.21 anton 666: case
1.30 anton 667: [ ' locals-wordlist ] literal >definer \ value
1.21 anton 668: OF >body POSTPONE Aliteral POSTPONE ! ENDOF
1.35 anton 669: \ !! dependent on c: etc. being does>-defining words
670: \ this works, because >definer uses >does-code in this case,
671: \ which produces a relocatable address
672: [ comp' clocal drop >definer ] literal
1.21 anton 673: OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
1.35 anton 674: [ comp' wlocal drop >definer ] literal
1.21 anton 675: OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
1.35 anton 676: [ comp' dlocal drop >definer ] literal
1.21 anton 677: OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF
1.35 anton 678: [ comp' flocal drop >definer ] literal
1.21 anton 679: OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
680: -&32 throw
1.23 pazsan 681: endcase ;
1.24 anton 682: interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local
1.1 anton 683:
1.6 pazsan 684: : locals|
1.14 anton 685: \ don't use 'locals|'! use '{'! A portable and free '{'
1.21 anton 686: \ implementation is compat/anslocals.fs
1.8 anton 687: BEGIN
1.49 anton 688: name 2dup s" |" str= 0=
1.8 anton 689: WHILE
690: (local)
691: REPEAT
1.14 anton 692: drop 0 (local) ; immediate restrict
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>