Return to glocals.fs CVS log

Up to [gforth] / gforth

Major change!
hash and search does not rely on each other.
context and voclink are now present in kernel.
words and marker can now defined without loading hash or search
marker went to extend.fs
word went to kernel/tools.fs
table goes to seperate file (at the moment)
glocals.fs and kernel/toolsext.fs are changed because of the change in the
wordlist-map-struct...
Attention: You can't recompile the code without new kernel-files!!!
jens

    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: 
   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: 
   91: : compile-@local ( n -- ) \ gforth compile-fetch-local
   92:  case
   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
   97:    ( otherwise ) dup postpone @local# ,
   98:  endcase ;
   99: 
  100: : compile-f@local ( n -- ) \ gforth compile-f-fetch-local
  101:  case
  102:     0        of postpone f@local0 endof
  103:     1 floats of postpone f@local1 endof
  104:    ( otherwise ) dup postpone f@local# ,
  105:  endcase ;
  106: 
  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: 
  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: 
  129: slowvoc @
  130: slowvoc on \ we want a linked list for the vocabulary locals
  131: vocabulary locals \ this contains the local variables
  132: ' locals >body ' locals-list >body !
  133: slowvoc !
  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
  143:     aligned dup adjust-locals-size ;
  144: 
  145: : alignlp-f ( n1 -- n2 )
  146:     faligned dup adjust-locals-size ;
  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: 
  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: 
  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 -- )
  220:     -1 chars compile-lp+!
  221:     locals-size @ swap !
  222:     postpone lp@ postpone c! ;
  223: 
  224: : create-local ( " name" -- a-addr )
  225:     \ defines the local "name"; the offset of the local shall be
  226:     \ stored in a-addr
  227:     create
  228: 	immediate restrict
  229: 	here 0 , ( place for the offset ) ;
  230: 
  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: 
  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
  239:   lp-offset , ;
  240: 
  241: vocabulary locals-types \ this contains all the type specifyers, -- and }
  242: locals-types definitions
  243: 
  244: : W: ( "name" -- a-addr xt ) \ gforth w-colon
  245:     create-local
  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
  250: 	@ lp-offset compile-@local ;
  251: 
  252: : W^ ( "name" -- a-addr xt ) \ gforth w-caret
  253:     create-local
  254: 	['] compile-pushlocal-w
  255:     does> ( Compilation: -- ) ( Run-time: -- w )
  256: 	postpone laddr# @ lp-offset, ;
  257: 
  258: : F: ( "name" -- a-addr xt ) \ gforth f-colon
  259:     create-local
  260: 	['] compile-pushlocal-f
  261:     does> ( Compilation: -- ) ( Run-time: -- w )
  262: 	@ lp-offset compile-f@local ;
  263: 
  264: : F^ ( "name" -- a-addr xt ) \ gforth f-caret
  265:     create-local
  266: 	['] compile-pushlocal-f
  267:     does> ( Compilation: -- ) ( Run-time: -- w )
  268: 	postpone laddr# @ lp-offset, ;
  269: 
  270: : D: ( "name" -- a-addr xt ) \ gforth d-colon
  271:     create-local
  272: 	['] compile-pushlocal-d
  273:     does> ( Compilation: -- ) ( Run-time: -- w )
  274: 	postpone laddr# @ lp-offset, postpone 2@ ;
  275: 
  276: : D^ ( "name" -- a-addr xt ) \ gforth d-caret
  277:     create-local
  278: 	['] compile-pushlocal-d
  279:     does> ( Compilation: -- ) ( Run-time: -- w )
  280: 	postpone laddr# @ lp-offset, ;
  281: 
  282: : C: ( "name" -- a-addr xt ) \ gforth c-colon
  283:     create-local
  284: 	['] compile-pushlocal-c
  285:     does> ( Compilation: -- ) ( Run-time: -- w )
  286: 	postpone laddr# @ lp-offset, postpone c@ ;
  287: 
  288: : C^ ( "name" -- a-addr xt ) \ gforth c-caret
  289:     create-local
  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
  313:     drop nextname
  314:     ['] W: >name ;
  315: 
  316: previous
  317: 
  318: : new-locals-reveal ( -- )
  319:   true abort" this should not happen: new-locals-reveal" ;
  320: 
  321: create new-locals-map ( -- wordlist-map )
  322: ' new-locals-find A,
  323: ' new-locals-reveal A,
  324: ' drop A, \ rehash method
  325: ' drop A,
  326: 
  327: slowvoc @
  328: slowvoc on
  329: vocabulary new-locals
  330: slowvoc !
  331: new-locals-map ' new-locals >body cell+ A! \ !! use special access words
  332: 
  333: variable old-dpp
  334: 
  335: \ and now, finally, the user interface words
  336: : { ( -- lastxt wid 0 ) \ gforth open-brace
  337:     dp old-dpp !
  338:     locals-dp dpp !
  339:     lastxt get-current
  340:     also new-locals
  341:     also locals definitions locals-types
  342:     0 TO locals-wordlist
  343:     0 postpone [ ; immediate
  344: 
  345: locals-types definitions
  346: 
  347: : } ( lastxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace
  348:     \ ends locals definitions
  349:     ] old-dpp @ dpp !
  350:     begin
  351: 	dup
  352:     while
  353: 	execute
  354:     repeat
  355:     drop
  356:     locals-size @ alignlp-f locals-size ! \ the strictest alignment
  357:     previous previous
  358:     set-current lastcfa !
  359:     locals-list TO locals-wordlist ;
  360: 
  361: : -- ( addr wid 0 ... -- ) \ gforth dash-dash
  362:     }
  363:     [char] } parse 2drop ;
  364: 
  365: forth definitions
  366: 
  367: \ A few thoughts on automatic scopes for locals and how they can be
  368: \ implemented:
  369: 
  370: \ We have to combine locals with the control structures. My basic idea
  371: \ was to start the life of a local at the declaration point. The life
  372: \ would end at any control flow join (THEN, BEGIN etc.) where the local
  373: \ is lot live on both input flows (note that the local can still live in
  374: \ other, later parts of the control flow). This would make a local live
  375: \ as long as you expected and sometimes longer (e.g. a local declared in
  376: \ a BEGIN..UNTIL loop would still live after the UNTIL).
  377: 
  378: \ The following example illustrates the problems of this approach:
  379: 
  380: \ { z }
  381: \ if
  382: \   { x }
  383: \ begin
  384: \   { y }
  385: \ [ 1 cs-roll ] then
  386: \   ...
  387: \ until
  388: 
  389: \ x lives only until the BEGIN, but the compiler does not know this
  390: \ until it compiles the UNTIL (it can deduce it at the THEN, because at
  391: \ that point x lives in no thread, but that does not help much). This is
  392: \ solved by optimistically assuming at the BEGIN that x lives, but
  393: \ warning at the UNTIL that it does not. The user is then responsible
  394: \ for checking that x is only used where it lives.
  395: 
  396: \ The produced code might look like this (leaving out alignment code):
  397: 
  398: \ >l ( z )
  399: \ ?branch <then>
  400: \ >l ( x )
  401: \ <begin>:
  402: \ >l ( y )
  403: \ lp+!# 8 ( RIP: x,y )
  404: \ <then>:
  405: \ ...
  406: \ lp+!# -4 ( adjust lp to <begin> state )
  407: \ ?branch <begin>
  408: \ lp+!# 4 ( undo adjust )
  409: 
  410: \ The BEGIN problem also has another incarnation:
  411: 
  412: \ AHEAD
  413: \ BEGIN
  414: \   x
  415: \ [ 1 CS-ROLL ] THEN
  416: \   { x }
  417: \   ...
  418: \ UNTIL
  419: 
  420: \ should be legal: The BEGIN is not a control flow join in this case,
  421: \ since it cannot be entered from the top; therefore the definition of x
  422: \ dominates the use. But the compiler processes the use first, and since
  423: \ it does not look ahead to notice the definition, it will complain
  424: \ about it. Here's another variation of this problem:
  425: 
  426: \ IF
  427: \   { x }
  428: \ ELSE
  429: \   ...
  430: \ AHEAD
  431: \ BEGIN
  432: \   x
  433: \ [ 2 CS-ROLL ] THEN
  434: \   ...
  435: \ UNTIL
  436: 
  437: \ In this case x is defined before the use, and the definition dominates
  438: \ the use, but the compiler does not know this until it processes the
  439: \ UNTIL. So what should the compiler assume does live at the BEGIN, if
  440: \ the BEGIN is not a control flow join? The safest assumption would be
  441: \ the intersection of all locals lists on the control flow
  442: \ stack. However, our compiler assumes that the same variables are live
  443: \ as on the top of the control flow stack. This covers the following case:
  444: 
  445: \ { x }
  446: \ AHEAD
  447: \ BEGIN
  448: \   x
  449: \ [ 1 CS-ROLL ] THEN
  450: \   ...
  451: \ UNTIL
  452: 
  453: \ If this assumption is too optimistic, the compiler will warn the user.
  454: 
  455: \ Implementation:
  456: 
  457: \ explicit scoping
  458: 
  459: : scope ( compilation  -- scope ; run-time  -- ) \ gforth
  460:  cs-push-part scopestart ; immediate
  461: 
  462: : endscope ( compilation scope -- ; run-time  -- ) \ gforth
  463:  scope?
  464:  drop
  465:  locals-list @ common-list
  466:  dup list-size adjust-locals-size
  467:  locals-list ! ; immediate
  468: 
  469: \ adapt the hooks
  470: 
  471: : locals-:-hook ( sys -- sys addr xt n )
  472:     \ addr is the nfa of the defined word, xt its xt
  473:     DEFERS :-hook
  474:     last @ lastcfa @
  475:     clear-leave-stack
  476:     0 locals-size !
  477:     locals-buffer locals-dp !
  478:     0 locals-list !
  479:     dead-code off
  480:     defstart ;
  481: 
  482: : locals-;-hook ( sys addr xt sys -- sys )
  483:     def?
  484:     0 TO locals-wordlist
  485:     0 adjust-locals-size ( not every def ends with an exit )
  486:     lastcfa ! last !
  487:     DEFERS ;-hook ;
  488: 
  489: \ THEN (another control flow from before joins the current one):
  490: \ The new locals-list is the intersection of the current locals-list and
  491: \ the orig-local-list. The new locals-size is the (alignment-adjusted)
  492: \ size of the new locals-list. The following code is generated:
  493: \ lp+!# (current-locals-size - orig-locals-size)
  494: \ <then>:
  495: \ lp+!# (orig-locals-size - new-locals-size)
  496: 
  497: \ Of course "lp+!# 0" is not generated. Still this is admittedly a bit
  498: \ inefficient, e.g. if there is a locals declaration between IF and
  499: \ ELSE. However, if ELSE generates an appropriate "lp+!#" before the
  500: \ branch, there will be none after the target <then>.
  501: 
  502: : (then-like) ( orig -- )
  503:     dead-orig =
  504:     if
  505: 	>resolve drop
  506:     else
  507:         dead-code @
  508:         if
  509: 	    >resolve set-locals-size-list dead-code off
  510: 	else \ both live
  511: 	    over list-size adjust-locals-size
  512: 	    >resolve
  513: 	    locals-list @ common-list dup list-size adjust-locals-size
  514: 	    locals-list !
  515: 	then
  516:     then ;
  517: 
  518: : (begin-like) ( -- )
  519:     dead-code @ if
  520: 	\ set up an assumption of the locals visible here.  if the
  521: 	\ users want something to be visible, they have to declare
  522: 	\ that using ASSUME-LIVE
  523: 	backedge-locals @ set-locals-size-list
  524:     then
  525:     dead-code off ;
  526: 
  527: \ AGAIN (the current control flow joins another, earlier one):
  528: \ If the dest-locals-list is not a subset of the current locals-list,
  529: \ issue a warning (see below). The following code is generated:
  530: \ lp+!# (current-local-size - dest-locals-size)
  531: \ branch <begin>
  532: 
  533: : (again-like) ( dest -- addr )
  534:     over list-size adjust-locals-size
  535:     swap check-begin  POSTPONE unreachable ;
  536: 
  537: \ UNTIL (the current control flow may join an earlier one or continue):
  538: \ Similar to AGAIN. The new locals-list and locals-size are the current
  539: \ ones. The following code is generated:
  540: \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size)
  541: 
  542: : (until-like) ( list addr xt1 xt2 -- )
  543:     \ list and addr are a fragment of a cs-item
  544:     \ xt1 is the conditional branch without lp adjustment, xt2 is with
  545:     >r >r
  546:     locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment )
  547: 	r> drop r> compile,
  548: 	swap <resolve ( list adjustment ) ,
  549:     else ( list dest-addr adjustment )
  550: 	drop
  551: 	r> compile, <resolve
  552: 	r> drop
  553:     then ( list )
  554:     check-begin ;
  555: 
  556: : (exit-like) ( -- )
  557:     0 adjust-locals-size ;
  558: 
  559: ' locals-:-hook IS :-hook
  560: ' locals-;-hook IS ;-hook
  561: 
  562: ' (then-like)  IS then-like
  563: ' (begin-like) IS begin-like
  564: ' (again-like) IS again-like
  565: ' (until-like) IS until-like
  566: ' (exit-like)  IS exit-like
  567: 
  568: \ The words in the locals dictionary space are not deleted until the end
  569: \ of the current word. This is a bit too conservative, but very simple.
  570: 
  571: \ There are a few cases to consider: (see above)
  572: 
  573: \ after AGAIN, AHEAD, EXIT (the current control flow is dead):
  574: \ We have to special-case the above cases against that. In this case the
  575: \ things above are not control flow joins. Everything should be taken
  576: \ over from the live flow. No lp+!# is generated.
  577: 
  578: \ About warning against uses of dead locals. There are several options:
  579: 
  580: \ 1) Do not complain (After all, this is Forth;-)
  581: 
  582: \ 2) Additional restrictions can be imposed so that the situation cannot
  583: \ arise; the programmer would have to introduce explicit scoping
  584: \ declarations in cases like the above one. I.e., complain if there are
  585: \ locals that are live before the BEGIN but not before the corresponding
  586: \ AGAIN (replace DO etc. for BEGIN and UNTIL etc. for AGAIN).
  587: 
  588: \ 3) The real thing: i.e. complain, iff a local lives at a BEGIN, is
  589: \ used on a path starting at the BEGIN, and does not live at the
  590: \ corresponding AGAIN. This is somewhat hard to implement. a) How does
  591: \ the compiler know when it is working on a path starting at a BEGIN
  592: \ (consider "{ x } if begin [ 1 cs-roll ] else x endif again")? b) How
  593: \ is the usage info stored?
  594: 
  595: \ For now I'll resort to alternative 2. When it produces warnings they
  596: \ will often be spurious, but warnings should be rare. And better
  597: \ spurious warnings now and then than days of bug-searching.
  598: 
  599: \ Explicit scoping of locals is implemented by cs-pushing the current
  600: \ locals-list and -size (and an unused cell, to make the size equal to
  601: \ the other entries) at the start of the scope, and restoring them at
  602: \ the end of the scope to the intersection, like THEN does.
  603: 
  604: 
  605: \ And here's finally the ANS standard stuff
  606: 
  607: : (local) ( addr u -- ) \ local paren-local-paren
  608:     \ a little space-inefficient, but well deserved ;-)
  609:     \ In exchange, there are no restrictions whatsoever on using (local)
  610:     \ as long as you use it in a definition
  611:     dup
  612:     if
  613: 	nextname POSTPONE { [ also locals-types ] W: } [ previous ]
  614:     else
  615: 	2drop
  616:     endif ;
  617: 
  618: : >definer ( xt -- definer )
  619:     \ this gives a unique identifier for the way the xt was defined
  620:     \ words defined with different does>-codes have different definers
  621:     \ the definer can be used for comparison and in definer!
  622:     dup >does-code
  623:     ?dup-if
  624: 	nip 1 or
  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
  632: 	swap [ 1 invert ] literal and does-code!
  633:     else
  634: 	code-address!
  635:     then ;
  636: 
  637: :noname
  638:     ' dup >definer [ ' locals-wordlist ] literal >definer =
  639:     if
  640: 	>body !
  641:     else
  642: 	-&32 throw
  643:     endif ;
  644: :noname
  645:     0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
  646:     comp' drop dup >definer
  647:     case
  648: 	[ ' locals-wordlist ] literal >definer \ value
  649: 	OF >body POSTPONE Aliteral POSTPONE ! ENDOF
  650: 	[ comp' clocal drop ] literal >definer
  651: 	OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
  652: 	[ comp' wlocal drop ] literal >definer
  653: 	OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
  654: 	[ comp' dlocal drop ] literal >definer
  655: 	OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF
  656: 	[ comp' flocal drop ] literal >definer
  657: 	OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
  658: 	-&32 throw
  659:     endcase ;
  660: interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local
  661: 
  662: : locals|
  663:     \ don't use 'locals|'! use '{'! A portable and free '{'
  664:     \ implementation is compat/anslocals.fs
  665:     BEGIN
  666: 	name 2dup s" |" compare 0<>
  667:     WHILE
  668: 	(local)
  669:     REPEAT
  670:     drop 0 (local) ; immediate restrict