Annotation of gforth/glocals.fs, revision 1.33
1.15 anton 1: \ A powerful locals implementation
2:
3: \ Copyright (C) 1995 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation; either version 2
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program; if not, write to the Free Software
19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20:
21:
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.1 anton 90:
1.14 anton 91: : compile-@local ( n -- ) \ gforth compile-fetch-local
1.3 anton 92: case
1.7 pazsan 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
1.3 anton 97: ( otherwise ) dup postpone @local# ,
98: endcase ;
99:
1.14 anton 100: : compile-f@local ( n -- ) \ gforth compile-f-fetch-local
1.3 anton 101: case
1.7 pazsan 102: 0 of postpone f@local0 endof
103: 1 floats of postpone f@local1 endof
1.3 anton 104: ( otherwise ) dup postpone f@local# ,
105: endcase ;
106:
1.27 pazsan 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:
1.1 anton 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:
1.5 anton 129: slowvoc @
130: slowvoc on \ we want a linked list for the vocabulary locals
1.1 anton 131: vocabulary locals \ this contains the local variables
1.3 anton 132: ' locals >body ' locals-list >body !
1.5 anton 133: slowvoc !
1.1 anton 134:
135: create locals-buffer 1000 allot \ !! limited and unsafe
136: \ here the names of the local variables are stored
137: \ we would have problems storing them at the normal dp
138:
139: variable locals-dp \ so here's the special dp for locals.
140:
141: : alignlp-w ( n1 -- n2 )
142: \ cell-align size and generate the corresponding code for aligning lp
1.3 anton 143: aligned dup adjust-locals-size ;
1.1 anton 144:
145: : alignlp-f ( n1 -- n2 )
1.3 anton 146: faligned dup adjust-locals-size ;
1.1 anton 147:
148: \ a local declaration group (the braces stuff) is compiled by calling
149: \ the appropriate compile-pushlocal for the locals, starting with the
150: \ righmost local; the names are already created earlier, the
151: \ compile-pushlocal just inserts the offsets from the frame base.
152:
153: : compile-pushlocal-w ( a-addr -- ) ( run-time: w -- )
154: \ compiles a push of a local variable, and adjusts locals-size
155: \ stores the offset of the local variable to a-addr
156: locals-size @ alignlp-w cell+ dup locals-size !
157: swap !
158: postpone >l ;
159:
1.27 pazsan 160: \ locals list operations
161:
162: : common-list ( list1 list2 -- list3 ) \ gforth-internal
163: \ list1 and list2 are lists, where the heads are at higher addresses than
164: \ the tail. list3 is the largest sublist of both lists.
165: begin
166: 2dup u<>
167: while
168: 2dup u>
169: if
170: swap
171: then
172: @
173: repeat
174: drop ;
175:
176: : sub-list? ( list1 list2 -- f ) \ gforth-internal
177: \ true iff list1 is a sublist of list2
178: begin
179: 2dup u<
180: while
181: @
182: repeat
183: = ;
184:
185: : list-size ( list -- u ) \ gforth-internal
186: \ size of the locals frame represented by list
187: 0 ( list n )
188: begin
189: over 0<>
190: while
191: over
192: ((name>)) >body @ max
193: swap @ swap ( get next )
194: repeat
195: faligned nip ;
196:
197: : set-locals-size-list ( list -- )
198: dup locals-list !
199: list-size locals-size ! ;
200:
201: : check-begin ( list -- )
202: \ warn if list is not a sublist of locals-list
203: locals-list @ sub-list? 0= if
204: \ !! print current position
205: ." compiler was overly optimistic about locals at a BEGIN" cr
206: \ !! print assumption and reality
207: then ;
208:
1.1 anton 209: : compile-pushlocal-f ( a-addr -- ) ( run-time: f -- )
210: locals-size @ alignlp-f float+ dup locals-size !
211: swap !
212: postpone f>l ;
213:
214: : compile-pushlocal-d ( a-addr -- ) ( run-time: w1 w2 -- )
215: locals-size @ alignlp-w cell+ cell+ dup locals-size !
216: swap !
217: postpone swap postpone >l postpone >l ;
218:
219: : compile-pushlocal-c ( a-addr -- ) ( run-time: w -- )
1.3 anton 220: -1 chars compile-lp+!
1.1 anton 221: locals-size @ swap !
222: postpone lp@ postpone c! ;
223:
224: : create-local ( " name" -- a-addr )
1.9 anton 225: \ defines the local "name"; the offset of the local shall be
226: \ stored in a-addr
1.1 anton 227: create
1.12 anton 228: immediate restrict
1.1 anton 229: here 0 , ( place for the offset ) ;
230:
1.3 anton 231: : lp-offset ( n1 -- n2 )
232: \ converts the offset from the frame start to an offset from lp and
233: \ i.e., the address of the local is lp+locals_size-offset
234: locals-size @ swap - ;
235:
1.1 anton 236: : lp-offset, ( n -- )
237: \ converts the offset from the frame start to an offset from lp and
238: \ adds it as inline argument to a preceding locals primitive
1.3 anton 239: lp-offset , ;
1.1 anton 240:
241: vocabulary locals-types \ this contains all the type specifyers, -- and }
242: locals-types definitions
243:
1.14 anton 244: : W: ( "name" -- a-addr xt ) \ gforth w-colon
245: create-local
1.1 anton 246: \ xt produces the appropriate locals pushing code when executed
247: ['] compile-pushlocal-w
248: does> ( Compilation: -- ) ( Run-time: -- w )
249: \ compiles a local variable access
1.3 anton 250: @ lp-offset compile-@local ;
1.1 anton 251:
1.14 anton 252: : W^ ( "name" -- a-addr xt ) \ gforth w-caret
253: create-local
1.1 anton 254: ['] compile-pushlocal-w
255: does> ( Compilation: -- ) ( Run-time: -- w )
256: postpone laddr# @ lp-offset, ;
257:
1.14 anton 258: : F: ( "name" -- a-addr xt ) \ gforth f-colon
259: create-local
1.1 anton 260: ['] compile-pushlocal-f
261: does> ( Compilation: -- ) ( Run-time: -- w )
1.3 anton 262: @ lp-offset compile-f@local ;
1.1 anton 263:
1.14 anton 264: : F^ ( "name" -- a-addr xt ) \ gforth f-caret
265: create-local
1.1 anton 266: ['] compile-pushlocal-f
267: does> ( Compilation: -- ) ( Run-time: -- w )
268: postpone laddr# @ lp-offset, ;
269:
1.14 anton 270: : D: ( "name" -- a-addr xt ) \ gforth d-colon
271: create-local
1.1 anton 272: ['] compile-pushlocal-d
273: does> ( Compilation: -- ) ( Run-time: -- w )
274: postpone laddr# @ lp-offset, postpone 2@ ;
275:
1.14 anton 276: : D^ ( "name" -- a-addr xt ) \ gforth d-caret
277: create-local
1.1 anton 278: ['] compile-pushlocal-d
279: does> ( Compilation: -- ) ( Run-time: -- w )
280: postpone laddr# @ lp-offset, ;
281:
1.14 anton 282: : C: ( "name" -- a-addr xt ) \ gforth c-colon
283: create-local
1.1 anton 284: ['] compile-pushlocal-c
285: does> ( Compilation: -- ) ( Run-time: -- w )
286: postpone laddr# @ lp-offset, postpone c@ ;
287:
1.14 anton 288: : C^ ( "name" -- a-addr xt ) \ gforth c-caret
289: create-local
1.1 anton 290: ['] compile-pushlocal-c
291: does> ( Compilation: -- ) ( Run-time: -- w )
292: postpone laddr# @ lp-offset, ;
293:
294: \ you may want to make comments in a locals definitions group:
295: ' \ alias \ immediate
296: ' ( alias ( immediate
297:
298: forth definitions
299:
300: \ the following gymnastics are for declaring locals without type specifier.
301: \ we exploit a feature of our dictionary: every wordlist
302: \ has it's own methods for finding words etc.
303: \ So we create a vocabulary new-locals, that creates a 'w:' local named x
304: \ when it is asked if it contains x.
305:
306: also locals-types
307:
308: : new-locals-find ( caddr u w -- nfa )
309: \ this is the find method of the new-locals vocabulary
310: \ make a new local with name caddr u; w is ignored
311: \ the returned nfa denotes a word that produces what W: produces
312: \ !! do the whole thing without nextname
1.3 anton 313: drop nextname
314: ['] W: >name ;
1.1 anton 315:
316: previous
317:
318: : new-locals-reveal ( -- )
319: true abort" this should not happen: new-locals-reveal" ;
320:
1.22 anton 321: create new-locals-map ( -- wordlist-map )
1.29 anton 322: ' new-locals-find A,
323: ' new-locals-reveal A,
324: ' drop A, \ rehash method
1.1 anton 325:
1.27 pazsan 326: slowvoc @
327: slowvoc on
1.1 anton 328: vocabulary new-locals
1.27 pazsan 329: slowvoc !
1.1 anton 330: new-locals-map ' new-locals >body cell+ A! \ !! use special access words
331:
332: variable old-dpp
333:
334: \ and now, finally, the user interface words
1.32 anton 335: : { ( -- lastxt wid 0 ) \ gforth open-brace
1.1 anton 336: dp old-dpp !
337: locals-dp dpp !
1.32 anton 338: lastxt get-current
1.1 anton 339: also new-locals
1.32 anton 340: also locals definitions locals-types
1.1 anton 341: 0 TO locals-wordlist
342: 0 postpone [ ; immediate
343:
344: locals-types definitions
345:
1.32 anton 346: : } ( lastxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace
1.1 anton 347: \ ends locals definitions
348: ] old-dpp @ dpp !
349: begin
350: dup
351: while
352: execute
353: repeat
354: drop
355: locals-size @ alignlp-f locals-size ! \ the strictest alignment
356: previous previous
1.32 anton 357: set-current lastcfa !
1.1 anton 358: locals-list TO locals-wordlist ;
359:
1.14 anton 360: : -- ( addr wid 0 ... -- ) \ gforth dash-dash
1.1 anton 361: }
1.9 anton 362: [char] } parse 2drop ;
1.1 anton 363:
364: forth definitions
365:
366: \ A few thoughts on automatic scopes for locals and how they can be
367: \ implemented:
368:
369: \ We have to combine locals with the control structures. My basic idea
370: \ was to start the life of a local at the declaration point. The life
371: \ would end at any control flow join (THEN, BEGIN etc.) where the local
372: \ is lot live on both input flows (note that the local can still live in
373: \ other, later parts of the control flow). This would make a local live
374: \ as long as you expected and sometimes longer (e.g. a local declared in
375: \ a BEGIN..UNTIL loop would still live after the UNTIL).
376:
377: \ The following example illustrates the problems of this approach:
378:
379: \ { z }
380: \ if
381: \ { x }
382: \ begin
383: \ { y }
384: \ [ 1 cs-roll ] then
385: \ ...
386: \ until
387:
388: \ x lives only until the BEGIN, but the compiler does not know this
389: \ until it compiles the UNTIL (it can deduce it at the THEN, because at
390: \ that point x lives in no thread, but that does not help much). This is
391: \ solved by optimistically assuming at the BEGIN that x lives, but
392: \ warning at the UNTIL that it does not. The user is then responsible
393: \ for checking that x is only used where it lives.
394:
395: \ The produced code might look like this (leaving out alignment code):
396:
397: \ >l ( z )
398: \ ?branch <then>
399: \ >l ( x )
400: \ <begin>:
401: \ >l ( y )
402: \ lp+!# 8 ( RIP: x,y )
403: \ <then>:
404: \ ...
405: \ lp+!# -4 ( adjust lp to <begin> state )
406: \ ?branch <begin>
407: \ lp+!# 4 ( undo adjust )
408:
409: \ The BEGIN problem also has another incarnation:
410:
411: \ AHEAD
412: \ BEGIN
413: \ x
414: \ [ 1 CS-ROLL ] THEN
415: \ { x }
416: \ ...
417: \ UNTIL
418:
419: \ should be legal: The BEGIN is not a control flow join in this case,
420: \ since it cannot be entered from the top; therefore the definition of x
421: \ dominates the use. But the compiler processes the use first, and since
422: \ it does not look ahead to notice the definition, it will complain
423: \ about it. Here's another variation of this problem:
424:
425: \ IF
426: \ { x }
427: \ ELSE
428: \ ...
429: \ AHEAD
430: \ BEGIN
431: \ x
432: \ [ 2 CS-ROLL ] THEN
433: \ ...
434: \ UNTIL
435:
436: \ In this case x is defined before the use, and the definition dominates
437: \ the use, but the compiler does not know this until it processes the
438: \ UNTIL. So what should the compiler assume does live at the BEGIN, if
439: \ the BEGIN is not a control flow join? The safest assumption would be
440: \ the intersection of all locals lists on the control flow
441: \ stack. However, our compiler assumes that the same variables are live
442: \ as on the top of the control flow stack. This covers the following case:
443:
444: \ { x }
445: \ AHEAD
446: \ BEGIN
447: \ x
448: \ [ 1 CS-ROLL ] THEN
449: \ ...
450: \ UNTIL
451:
452: \ If this assumption is too optimistic, the compiler will warn the user.
453:
1.28 anton 454: \ Implementation:
1.1 anton 455:
1.3 anton 456: \ explicit scoping
1.1 anton 457:
1.14 anton 458: : scope ( compilation -- scope ; run-time -- ) \ gforth
1.3 anton 459: cs-push-part scopestart ; immediate
460:
1.14 anton 461: : endscope ( compilation scope -- ; run-time -- ) \ gforth
1.3 anton 462: scope?
1.1 anton 463: drop
1.3 anton 464: locals-list @ common-list
465: dup list-size adjust-locals-size
466: locals-list ! ; immediate
1.1 anton 467:
1.3 anton 468: \ adapt the hooks
1.1 anton 469:
1.3 anton 470: : locals-:-hook ( sys -- sys addr xt n )
471: \ addr is the nfa of the defined word, xt its xt
1.1 anton 472: DEFERS :-hook
473: last @ lastcfa @
474: clear-leave-stack
475: 0 locals-size !
476: locals-buffer locals-dp !
1.3 anton 477: 0 locals-list !
478: dead-code off
479: defstart ;
1.1 anton 480:
1.3 anton 481: : locals-;-hook ( sys addr xt sys -- sys )
482: def?
1.1 anton 483: 0 TO locals-wordlist
1.3 anton 484: 0 adjust-locals-size ( not every def ends with an exit )
1.1 anton 485: lastcfa ! last !
486: DEFERS ;-hook ;
487:
1.28 anton 488: \ THEN (another control flow from before joins the current one):
489: \ The new locals-list is the intersection of the current locals-list and
490: \ the orig-local-list. The new locals-size is the (alignment-adjusted)
491: \ size of the new locals-list. The following code is generated:
492: \ lp+!# (current-locals-size - orig-locals-size)
493: \ <then>:
494: \ lp+!# (orig-locals-size - new-locals-size)
495:
496: \ Of course "lp+!# 0" is not generated. Still this is admittedly a bit
497: \ inefficient, e.g. if there is a locals declaration between IF and
498: \ ELSE. However, if ELSE generates an appropriate "lp+!#" before the
499: \ branch, there will be none after the target <then>.
500:
1.30 anton 501: : (then-like) ( orig -- )
502: dead-orig =
1.27 pazsan 503: if
1.30 anton 504: >resolve drop
1.27 pazsan 505: else
506: dead-code @
507: if
1.30 anton 508: >resolve set-locals-size-list dead-code off
1.27 pazsan 509: else \ both live
1.30 anton 510: over list-size adjust-locals-size
511: >resolve
1.27 pazsan 512: locals-list @ common-list dup list-size adjust-locals-size
513: locals-list !
514: then
515: then ;
516:
517: : (begin-like) ( -- )
518: dead-code @ if
519: \ set up an assumption of the locals visible here. if the
520: \ users want something to be visible, they have to declare
521: \ that using ASSUME-LIVE
522: backedge-locals @ set-locals-size-list
523: then
524: dead-code off ;
525:
526: \ AGAIN (the current control flow joins another, earlier one):
527: \ If the dest-locals-list is not a subset of the current locals-list,
528: \ issue a warning (see below). The following code is generated:
529: \ lp+!# (current-local-size - dest-locals-size)
530: \ branch <begin>
531:
532: : (again-like) ( dest -- addr )
533: over list-size adjust-locals-size
534: swap check-begin POSTPONE unreachable ;
535:
536: \ UNTIL (the current control flow may join an earlier one or continue):
537: \ Similar to AGAIN. The new locals-list and locals-size are the current
538: \ ones. The following code is generated:
539: \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size)
540:
541: : (until-like) ( list addr xt1 xt2 -- )
542: \ list and addr are a fragment of a cs-item
543: \ xt1 is the conditional branch without lp adjustment, xt2 is with
544: >r >r
545: locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment )
546: r> drop r> compile,
547: swap <resolve ( list adjustment ) ,
548: else ( list dest-addr adjustment )
549: drop
550: r> compile, <resolve
551: r> drop
552: then ( list )
553: check-begin ;
554:
555: : (exit-like) ( -- )
556: 0 adjust-locals-size ;
557:
1.1 anton 558: ' locals-:-hook IS :-hook
559: ' locals-;-hook IS ;-hook
1.27 pazsan 560:
561: ' (then-like) IS then-like
562: ' (begin-like) IS begin-like
563: ' (again-like) IS again-like
564: ' (until-like) IS until-like
565: ' (exit-like) IS exit-like
1.1 anton 566:
567: \ The words in the locals dictionary space are not deleted until the end
568: \ of the current word. This is a bit too conservative, but very simple.
569:
570: \ There are a few cases to consider: (see above)
571:
572: \ after AGAIN, AHEAD, EXIT (the current control flow is dead):
573: \ We have to special-case the above cases against that. In this case the
574: \ things above are not control flow joins. Everything should be taken
575: \ over from the live flow. No lp+!# is generated.
576:
577: \ About warning against uses of dead locals. There are several options:
578:
579: \ 1) Do not complain (After all, this is Forth;-)
580:
581: \ 2) Additional restrictions can be imposed so that the situation cannot
582: \ arise; the programmer would have to introduce explicit scoping
583: \ declarations in cases like the above one. I.e., complain if there are
584: \ locals that are live before the BEGIN but not before the corresponding
585: \ AGAIN (replace DO etc. for BEGIN and UNTIL etc. for AGAIN).
586:
587: \ 3) The real thing: i.e. complain, iff a local lives at a BEGIN, is
588: \ used on a path starting at the BEGIN, and does not live at the
589: \ corresponding AGAIN. This is somewhat hard to implement. a) How does
590: \ the compiler know when it is working on a path starting at a BEGIN
591: \ (consider "{ x } if begin [ 1 cs-roll ] else x endif again")? b) How
592: \ is the usage info stored?
593:
594: \ For now I'll resort to alternative 2. When it produces warnings they
595: \ will often be spurious, but warnings should be rare. And better
596: \ spurious warnings now and then than days of bug-searching.
597:
598: \ Explicit scoping of locals is implemented by cs-pushing the current
599: \ locals-list and -size (and an unused cell, to make the size equal to
600: \ the other entries) at the start of the scope, and restoring them at
601: \ the end of the scope to the intersection, like THEN does.
602:
603:
604: \ And here's finally the ANS standard stuff
605:
1.14 anton 606: : (local) ( addr u -- ) \ local paren-local-paren
1.3 anton 607: \ a little space-inefficient, but well deserved ;-)
608: \ In exchange, there are no restrictions whatsoever on using (local)
1.4 anton 609: \ as long as you use it in a definition
1.3 anton 610: dup
611: if
612: nextname POSTPONE { [ also locals-types ] W: } [ previous ]
613: else
614: 2drop
615: endif ;
1.1 anton 616:
1.4 anton 617: : >definer ( xt -- definer )
618: \ this gives a unique identifier for the way the xt was defined
619: \ words defined with different does>-codes have different definers
620: \ the definer can be used for comparison and in definer!
1.30 anton 621: dup >does-code
622: ?dup-if
623: nip 1 or
1.4 anton 624: else
625: >code-address
626: then ;
627:
628: : definer! ( definer xt -- )
629: \ gives the word represented by xt the behaviour associated with definer
630: over 1 and if
1.13 anton 631: swap [ 1 invert ] literal and does-code!
1.4 anton 632: else
633: code-address!
634: then ;
635:
1.23 pazsan 636: :noname
1.31 anton 637: ' dup >definer [ ' locals-wordlist ] literal >definer =
1.23 pazsan 638: if
639: >body !
640: else
641: -&32 throw
642: endif ;
643: :noname
1.21 anton 644: 0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
1.28 anton 645: comp' drop dup >definer
1.21 anton 646: case
1.30 anton 647: [ ' locals-wordlist ] literal >definer \ value
1.21 anton 648: OF >body POSTPONE Aliteral POSTPONE ! ENDOF
1.30 anton 649: [ comp' clocal drop ] literal >definer
1.21 anton 650: OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
1.30 anton 651: [ comp' wlocal drop ] literal >definer
1.21 anton 652: OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
1.30 anton 653: [ comp' dlocal drop ] literal >definer
1.21 anton 654: OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF
1.30 anton 655: [ comp' flocal drop ] literal >definer
1.21 anton 656: OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
657: -&32 throw
1.23 pazsan 658: endcase ;
1.24 anton 659: interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local
1.1 anton 660:
1.6 pazsan 661: : locals|
1.14 anton 662: \ don't use 'locals|'! use '{'! A portable and free '{'
1.21 anton 663: \ implementation is compat/anslocals.fs
1.8 anton 664: BEGIN
665: name 2dup s" |" compare 0<>
666: WHILE
667: (local)
668: REPEAT
1.14 anton 669: drop 0 (local) ; immediate restrict
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>