Annotation of gforth/glocals.fs, revision 1.67

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

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