File:  [gforth] / gforth / glocals.fs
Revision 1.4: download - view: text, annotated - select for diffs
Fri Jul 8 15:00:43 1994 UTC (29 years, 8 months ago) by anton
Branches: MAIN
CVS tags: HEAD
signals are now translated into THROWs
A number of bug fixes (make a diff of BUGS for details)
added assert.fs and debugging.fs
made .s nicer
keep names of included files (in loadfilename) and print them upon error

    1: \ Local variables are quite important for writing readable programs, but
    2: \ IMO (anton) they are the worst part of the standard. There they are very
    3: \ restricted and have an ugly interface.
    4: 
    5: \ So, we implement the locals wordset, but do not recommend using
    6: \ locals-ext (which is a really bad user interface for locals).
    7: 
    8: \ We also have a nice and powerful user-interface for locals: locals are
    9: \ defined with
   10: 
   11: \ { local1 local2 ... }
   12: \ or
   13: \ { local1 local2 ... -- ... }
   14: \ (anything after the -- is just a comment)
   15: 
   16: \ Every local in this list consists of an optional type specification
   17: \ and a name. If there is only the name, it stands for a cell-sized
   18: \ value (i.e., you get the value of the local variable, not it's
   19: \ address). The following type specifiers stand before the name:
   20: 
   21: \ Specifier	Type	Access
   22: \ W:		Cell	value
   23: \ W^		Cell	address
   24: \ D:		Double	value
   25: \ D^		Double	address
   26: \ F:		Float	value
   27: \ F^		Float	address
   28: \ C:		Char	value
   29: \ C^		Char	address
   30: 
   31: \ The local variables are initialized with values from the appropriate
   32: \ stack. In contrast to the examples in the standard document our locals
   33: \ take the arguments in the expected way: The last local gets the top of
   34: \ stack, the second last gets the second stack item etc. An example:
   35: 
   36: \ : CX* { F: Ar  F: Ai  F: Br  F: Bi -- Cr Ci }
   37: \ \ complex multiplication
   38: \  Ar Br f* Ai Bi f* f-
   39: \  Ar Bi f* Ai Br f* f+ ;
   40: 
   41: \ There will also be a way to add user types, but it is not yet decided,
   42: \ how. Ideas are welcome.
   43: 
   44: \ Locals defined in this manner live until (!! see below). 
   45: \ Their names can be used during this time to get
   46: \ their value or address; The addresses produced in this way become
   47: \ invalid at the end of the lifetime.
   48: 
   49: \ Values can be changed with TO, but this is not recomended (TO is a
   50: \ kludge and words lose the single-assignment property, which makes them
   51: \ harder to analyse).
   52: 
   53: \ As for the internals, we use a special locals stack. This eliminates
   54: \ the problems and restrictions of reusing the return stack and allows
   55: \ to store floats as locals: the return stack is not guaranteed to be
   56: \ aligned correctly, but our locals stack must be float-aligned between
   57: \ words.
   58: 
   59: \ Other things about the internals are pretty unclear now.
   60: 
   61: \ Currently locals may only be
   62: \ defined at the outer level and TO is not supported.
   63: 
   64: include float.fs
   65: include search-order.fs
   66: 
   67: : compile-@local ( n -- )
   68:  case
   69:     0 of postpone @local0 endof
   70:     4 of postpone @local4 endof
   71:     8 of postpone @local8 endof
   72:    12 of postpone @local12 endof
   73:    ( otherwise ) dup postpone @local# ,
   74:  endcase ;
   75: 
   76: : compile-f@local ( n -- )
   77:  case
   78:     0 of postpone f@local0 endof
   79:     8 of postpone f@local8 endof
   80:    ( otherwise ) dup postpone f@local# ,
   81:  endcase ;
   82: 
   83: \ the locals stack grows downwards (see primitives)
   84: \ of the local variables of a group (in braces) the leftmost is on top,
   85: \ i.e. by going onto the locals stack the order is reversed.
   86: \ there are alignment gaps if necessary.
   87: \ lp must have the strictest alignment (usually float) across calls;
   88: \ for simplicity we align it strictly for every group.
   89: 
   90: vocabulary locals \ this contains the local variables
   91: ' locals >body ' locals-list >body !
   92: 
   93: create locals-buffer 1000 allot \ !! limited and unsafe
   94:     \ here the names of the local variables are stored
   95:     \ we would have problems storing them at the normal dp
   96: 
   97: variable locals-dp \ so here's the special dp for locals.
   98: 
   99: : alignlp-w ( n1 -- n2 )
  100:     \ cell-align size and generate the corresponding code for aligning lp
  101:     aligned dup adjust-locals-size ;
  102: 
  103: : alignlp-f ( n1 -- n2 )
  104:     faligned dup adjust-locals-size ;
  105: 
  106: \ a local declaration group (the braces stuff) is compiled by calling
  107: \ the appropriate compile-pushlocal for the locals, starting with the
  108: \ righmost local; the names are already created earlier, the
  109: \ compile-pushlocal just inserts the offsets from the frame base.
  110: 
  111: : compile-pushlocal-w ( a-addr -- ) ( run-time: w -- )
  112: \ compiles a push of a local variable, and adjusts locals-size
  113: \ stores the offset of the local variable to a-addr
  114:     locals-size @ alignlp-w cell+ dup locals-size !
  115:     swap !
  116:     postpone >l ;
  117: 
  118: : compile-pushlocal-f ( a-addr -- ) ( run-time: f -- )
  119:     locals-size @ alignlp-f float+ dup locals-size !
  120:     swap !
  121:     postpone f>l ;
  122: 
  123: : compile-pushlocal-d ( a-addr -- ) ( run-time: w1 w2 -- )
  124:     locals-size @ alignlp-w cell+ cell+ dup locals-size !
  125:     swap !
  126:     postpone swap postpone >l postpone >l ;
  127: 
  128: : compile-pushlocal-c ( a-addr -- ) ( run-time: w -- )
  129:     -1 chars compile-lp+!
  130:     locals-size @ swap !
  131:     postpone lp@ postpone c! ;
  132: 
  133: : create-local ( " name" -- a-addr )
  134: 	\ defines the local "name"; the offset of the local shall be stored in a-addr
  135:     create
  136: 	immediate
  137: 	here 0 , ( place for the offset ) ;
  138: 
  139: : lp-offset ( n1 -- n2 )
  140: \ converts the offset from the frame start to an offset from lp and
  141: \ i.e., the address of the local is lp+locals_size-offset
  142:   locals-size @ swap - ;
  143: 
  144: : lp-offset, ( n -- )
  145: \ converts the offset from the frame start to an offset from lp and
  146: \ adds it as inline argument to a preceding locals primitive
  147:   lp-offset , ;
  148: 
  149: vocabulary locals-types \ this contains all the type specifyers, -- and }
  150: locals-types definitions
  151: 
  152: : W:
  153:     create-local ( "name" -- a-addr xt )
  154: 	\ xt produces the appropriate locals pushing code when executed
  155: 	['] compile-pushlocal-w
  156:     does> ( Compilation: -- ) ( Run-time: -- w )
  157:         \ compiles a local variable access
  158: 	@ lp-offset compile-@local ;
  159: 
  160: : W^
  161:     create-local ( "name" -- a-addr xt )
  162: 	['] compile-pushlocal-w
  163:     does> ( Compilation: -- ) ( Run-time: -- w )
  164: 	postpone laddr# @ lp-offset, ;
  165: 
  166: : F:
  167:     create-local ( "name" -- a-addr xt )
  168: 	['] compile-pushlocal-f
  169:     does> ( Compilation: -- ) ( Run-time: -- w )
  170: 	@ lp-offset compile-f@local ;
  171: 
  172: : F^
  173:     create-local ( "name" -- a-addr xt )
  174: 	['] compile-pushlocal-f
  175:     does> ( Compilation: -- ) ( Run-time: -- w )
  176: 	postpone laddr# @ lp-offset, ;
  177: 
  178: : D:
  179:     create-local ( "name" -- a-addr xt )
  180: 	['] compile-pushlocal-d
  181:     does> ( Compilation: -- ) ( Run-time: -- w )
  182: 	postpone laddr# @ lp-offset, postpone 2@ ;
  183: 
  184: : D^
  185:     create-local ( "name" -- a-addr xt )
  186: 	['] compile-pushlocal-d
  187:     does> ( Compilation: -- ) ( Run-time: -- w )
  188: 	postpone laddr# @ lp-offset, ;
  189: 
  190: : C:
  191:     create-local ( "name" -- a-addr xt )
  192: 	['] compile-pushlocal-c
  193:     does> ( Compilation: -- ) ( Run-time: -- w )
  194: 	postpone laddr# @ lp-offset, postpone c@ ;
  195: 
  196: : C^
  197:     create-local ( "name" -- a-addr xt )
  198: 	['] compile-pushlocal-c
  199:     does> ( Compilation: -- ) ( Run-time: -- w )
  200: 	postpone laddr# @ lp-offset, ;
  201: 
  202: \ you may want to make comments in a locals definitions group:
  203: ' \ alias \ immediate
  204: ' ( alias ( immediate
  205: 
  206: forth definitions
  207: 
  208: \ the following gymnastics are for declaring locals without type specifier.
  209: \ we exploit a feature of our dictionary: every wordlist
  210: \ has it's own methods for finding words etc.
  211: \ So we create a vocabulary new-locals, that creates a 'w:' local named x
  212: \ when it is asked if it contains x.
  213: 
  214: also locals-types
  215: 
  216: : new-locals-find ( caddr u w -- nfa )
  217: \ this is the find method of the new-locals vocabulary
  218: \ make a new local with name caddr u; w is ignored
  219: \ the returned nfa denotes a word that produces what W: produces
  220: \ !! do the whole thing without nextname
  221:     drop nextname
  222:     ['] W: >name ;
  223: 
  224: previous
  225: 
  226: : new-locals-reveal ( -- )
  227:   true abort" this should not happen: new-locals-reveal" ;
  228: 
  229: create new-locals-map ' new-locals-find A, ' new-locals-reveal A,
  230: 
  231: vocabulary new-locals
  232: new-locals-map ' new-locals >body cell+ A! \ !! use special access words
  233: 
  234: variable old-dpp
  235: 
  236: \ and now, finally, the user interface words
  237: : { ( -- addr wid 0 )
  238:     dp old-dpp !
  239:     locals-dp dpp !
  240:     also new-locals
  241:     also get-current locals definitions  locals-types
  242:     0 TO locals-wordlist
  243:     0 postpone [ ; immediate
  244: 
  245: locals-types definitions
  246: 
  247: : } ( addr wid 0 a-addr1 xt1 ... -- )
  248:     \ ends locals definitions
  249:     ] old-dpp @ dpp !
  250:     begin
  251: 	dup
  252:     while
  253: 	execute
  254:     repeat
  255:     drop
  256:     locals-size @ alignlp-f locals-size ! \ the strictest alignment
  257:     set-current
  258:     previous previous
  259:     locals-list TO locals-wordlist ;
  260: 
  261: : -- ( addr wid 0 ... -- )
  262:     }
  263:     [char] } word drop ;
  264: 
  265: forth definitions
  266: 
  267: \ A few thoughts on automatic scopes for locals and how they can be
  268: \ implemented:
  269: 
  270: \ We have to combine locals with the control structures. My basic idea
  271: \ was to start the life of a local at the declaration point. The life
  272: \ would end at any control flow join (THEN, BEGIN etc.) where the local
  273: \ is lot live on both input flows (note that the local can still live in
  274: \ other, later parts of the control flow). This would make a local live
  275: \ as long as you expected and sometimes longer (e.g. a local declared in
  276: \ a BEGIN..UNTIL loop would still live after the UNTIL).
  277: 
  278: \ The following example illustrates the problems of this approach:
  279: 
  280: \ { z }
  281: \ if
  282: \   { x }
  283: \ begin
  284: \   { y }
  285: \ [ 1 cs-roll ] then
  286: \   ...
  287: \ until
  288: 
  289: \ x lives only until the BEGIN, but the compiler does not know this
  290: \ until it compiles the UNTIL (it can deduce it at the THEN, because at
  291: \ that point x lives in no thread, but that does not help much). This is
  292: \ solved by optimistically assuming at the BEGIN that x lives, but
  293: \ warning at the UNTIL that it does not. The user is then responsible
  294: \ for checking that x is only used where it lives.
  295: 
  296: \ The produced code might look like this (leaving out alignment code):
  297: 
  298: \ >l ( z )
  299: \ ?branch <then>
  300: \ >l ( x )
  301: \ <begin>:
  302: \ >l ( y )
  303: \ lp+!# 8 ( RIP: x,y )
  304: \ <then>:
  305: \ ...
  306: \ lp+!# -4 ( adjust lp to <begin> state )
  307: \ ?branch <begin>
  308: \ lp+!# 4 ( undo adjust )
  309: 
  310: \ The BEGIN problem also has another incarnation:
  311: 
  312: \ AHEAD
  313: \ BEGIN
  314: \   x
  315: \ [ 1 CS-ROLL ] THEN
  316: \   { x }
  317: \   ...
  318: \ UNTIL
  319: 
  320: \ should be legal: The BEGIN is not a control flow join in this case,
  321: \ since it cannot be entered from the top; therefore the definition of x
  322: \ dominates the use. But the compiler processes the use first, and since
  323: \ it does not look ahead to notice the definition, it will complain
  324: \ about it. Here's another variation of this problem:
  325: 
  326: \ IF
  327: \   { x }
  328: \ ELSE
  329: \   ...
  330: \ AHEAD
  331: \ BEGIN
  332: \   x
  333: \ [ 2 CS-ROLL ] THEN
  334: \   ...
  335: \ UNTIL
  336: 
  337: \ In this case x is defined before the use, and the definition dominates
  338: \ the use, but the compiler does not know this until it processes the
  339: \ UNTIL. So what should the compiler assume does live at the BEGIN, if
  340: \ the BEGIN is not a control flow join? The safest assumption would be
  341: \ the intersection of all locals lists on the control flow
  342: \ stack. However, our compiler assumes that the same variables are live
  343: \ as on the top of the control flow stack. This covers the following case:
  344: 
  345: \ { x }
  346: \ AHEAD
  347: \ BEGIN
  348: \   x
  349: \ [ 1 CS-ROLL ] THEN
  350: \   ...
  351: \ UNTIL
  352: 
  353: \ If this assumption is too optimistic, the compiler will warn the user.
  354: 
  355: \ Implementation: migrated to kernal.fs
  356: 
  357: \ THEN (another control flow from before joins the current one):
  358: \ The new locals-list is the intersection of the current locals-list and
  359: \ the orig-local-list. The new locals-size is the (alignment-adjusted)
  360: \ size of the new locals-list. The following code is generated:
  361: \ lp+!# (current-locals-size - orig-locals-size)
  362: \ <then>:
  363: \ lp+!# (orig-locals-size - new-locals-size)
  364: 
  365: \ Of course "lp+!# 0" is not generated. Still this is admittedly a bit
  366: \ inefficient, e.g. if there is a locals declaration between IF and
  367: \ ELSE. However, if ELSE generates an appropriate "lp+!#" before the
  368: \ branch, there will be none after the target <then>.
  369: 
  370: \ explicit scoping
  371: 
  372: : scope ( -- scope )
  373:  cs-push-part scopestart ; immediate
  374: 
  375: : endscope ( scope -- )
  376:  scope?
  377:  drop
  378:  locals-list @ common-list
  379:  dup list-size adjust-locals-size
  380:  locals-list ! ; immediate
  381: 
  382: \ adapt the hooks
  383: 
  384: : locals-:-hook ( sys -- sys addr xt n )
  385:     \ addr is the nfa of the defined word, xt its xt
  386:     DEFERS :-hook
  387:     last @ lastcfa @
  388:     clear-leave-stack
  389:     0 locals-size !
  390:     locals-buffer locals-dp !
  391:     0 locals-list !
  392:     dead-code off
  393:     defstart ;
  394: 
  395: : locals-;-hook ( sys addr xt sys -- sys )
  396:     def?
  397:     0 TO locals-wordlist
  398:     0 adjust-locals-size ( not every def ends with an exit )
  399:     lastcfa ! last !
  400:     DEFERS ;-hook ;
  401: 
  402: ' locals-:-hook IS :-hook
  403: ' locals-;-hook IS ;-hook
  404: 
  405: \ The words in the locals dictionary space are not deleted until the end
  406: \ of the current word. This is a bit too conservative, but very simple.
  407: 
  408: \ There are a few cases to consider: (see above)
  409: 
  410: \ after AGAIN, AHEAD, EXIT (the current control flow is dead):
  411: \ We have to special-case the above cases against that. In this case the
  412: \ things above are not control flow joins. Everything should be taken
  413: \ over from the live flow. No lp+!# is generated.
  414: 
  415: \ !! The lp gymnastics for UNTIL are also a real problem: locals cannot be
  416: \ used in signal handlers (or anything else that may be called while
  417: \ locals live beyond the lp) without changing the locals stack.
  418: 
  419: \ About warning against uses of dead locals. There are several options:
  420: 
  421: \ 1) Do not complain (After all, this is Forth;-)
  422: 
  423: \ 2) Additional restrictions can be imposed so that the situation cannot
  424: \ arise; the programmer would have to introduce explicit scoping
  425: \ declarations in cases like the above one. I.e., complain if there are
  426: \ locals that are live before the BEGIN but not before the corresponding
  427: \ AGAIN (replace DO etc. for BEGIN and UNTIL etc. for AGAIN).
  428: 
  429: \ 3) The real thing: i.e. complain, iff a local lives at a BEGIN, is
  430: \ used on a path starting at the BEGIN, and does not live at the
  431: \ corresponding AGAIN. This is somewhat hard to implement. a) How does
  432: \ the compiler know when it is working on a path starting at a BEGIN
  433: \ (consider "{ x } if begin [ 1 cs-roll ] else x endif again")? b) How
  434: \ is the usage info stored?
  435: 
  436: \ For now I'll resort to alternative 2. When it produces warnings they
  437: \ will often be spurious, but warnings should be rare. And better
  438: \ spurious warnings now and then than days of bug-searching.
  439: 
  440: \ Explicit scoping of locals is implemented by cs-pushing the current
  441: \ locals-list and -size (and an unused cell, to make the size equal to
  442: \ the other entries) at the start of the scope, and restoring them at
  443: \ the end of the scope to the intersection, like THEN does.
  444: 
  445: 
  446: \ And here's finally the ANS standard stuff
  447: 
  448: : (local) ( addr u -- )
  449:     \ a little space-inefficient, but well deserved ;-)
  450:     \ In exchange, there are no restrictions whatsoever on using (local)
  451:     \ as long as you use it in a definition
  452:     dup
  453:     if
  454: 	nextname POSTPONE { [ also locals-types ] W: } [ previous ]
  455:     else
  456: 	2drop
  457:     endif ;
  458: 
  459: : >definer ( xt -- definer )
  460:     \ this gives a unique identifier for the way the xt was defined
  461:     \ words defined with different does>-codes have different definers
  462:     \ the definer can be used for comparison and in definer!
  463:     dup >code-address [ ' bits >code-address ] Literal =
  464:     \ !! this definition will not work on some implementations for `bits'
  465:     if  \ if >code-address delivers the same value for all does>-def'd words
  466: 	>does-code 1 or \ bit 0 marks special treatment for does codes
  467:     else
  468: 	>code-address
  469:     then ;
  470: 
  471: : definer! ( definer xt -- )
  472:     \ gives the word represented by xt the behaviour associated with definer
  473:     over 1 and if
  474: 	does-code!
  475:     else
  476: 	code-address!
  477:     then ;
  478: 
  479: \ !! untested
  480: : TO ( c|w|d|r "name" -- )
  481: \ !! state smart
  482:  0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
  483:  ' dup >definer
  484:  state @ 
  485:  if
  486:    case
  487:      [ ' locals-wordlist >definer ] literal \ value
  488:      OF >body POSTPONE Aliteral POSTPONE ! ENDOF
  489:      [ ' clocal >definer ] literal
  490:      OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
  491:      [ ' wlocal >definer ] literal
  492:      OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
  493:      [ ' dlocal >definer ] literal
  494:      OF POSTPONE laddr# >body @ lp-offset, POSTPONE d! ENDOF
  495:      [ ' flocal >definer ] literal
  496:      OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
  497:      abort" can only store TO value or local value"
  498:    endcase
  499:  else
  500:    [ ' locals-wordlist >definer ] literal =
  501:    if
  502:      >body !
  503:    else
  504:      abort" can only store TO value"
  505:    endif
  506:  endif ; immediate
  507: 
  508: \ : locals|
  509: \ !! should lie around somewhere

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