Annotation of gforth/glocals.fs, revision 1.27

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

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