File:  [gforth] / gforth / glocals.fs
Revision 1.56: download - view: text, annotated - select for diffs
Sun Oct 2 11:30:32 2005 UTC (18 years, 5 months ago) by anton
Branches: MAIN
CVS tags: HEAD
Documentation changes:
  added wordset info for many words, and pronounciation for a few
  added documentation about key names for EKEY
  worked around texinfo 4.7 restrictions (old assignment macros broken)
  Added "Explicit stack access" docs to vmgen docs

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

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