Annotation of gforth/glocals.fs, revision 1.2

1.1       anton       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
1.2     ! pazsan     77: : locals-list! ( list -- )  locals-list ! locals-list rehash ;
1.1       anton      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
1.2     ! pazsan    416:  locals-list!
1.1       anton     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
1.2     ! pazsan    450:    locals-list!
1.1       anton     451:    locals-size !
                    452:  else
                    453:    locals-size @ 3 roll - compile-lp+!#
                    454:    >resolve
1.2     ! pazsan    455:    locals-list @ common-list locals-list!
1.1       anton     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
1.2     ! pazsan    465:  locals-list @ common-list locals-list!
1.1       anton     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 !
1.2     ! pazsan    626:     0 locals-list! ; ( clear locals vocabulary )
1.1       anton     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>