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