File:  [gforth] / gforth / glocals.fs
Revision 1.2: download - view: text, annotated - select for diffs
Wed Jun 1 10:05:17 1994 UTC (29 years, 9 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
added an experimental hash table (search/order.fs)
allowed the user to select caps-stored names or even case-
sensitive search.
Made gforth.texi compilable.

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>