Return to glocals.fs CVS log

Up to [gforth] / gforth

added answords.fs and strsignal.c
added checking of documenetation of ANS Forth words
Fixed many documentation errors and added some documentation
signal handling now uses strsignal and can handle signals not present on all machines

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