|  | 
|  | 1 | +\       (C) Copyright 2005 IBM Corporation.  All Rights Reserved. | 
|  | 2 | +\       Licensed under the Common Public License (CPL) version 1.0 | 
|  | 3 | +\       for full details see: | 
|  | 4 | +\            http://www.opensource.org/licenses/cpl1.0.php | 
|  | 5 | +\ | 
|  | 6 | +\       Module Author:  David L. Paktor    [email protected] | 
|  | 7 | + | 
|  | 8 | +\  The support routines for Local Values in FCode. | 
|  | 9 | + | 
|  | 10 | +\  Function imported | 
|  | 11 | +\	_local-storage-size_	\  Size, in cells, of backing store for locals | 
|  | 12 | +\	\  A constant.  If not supplied, default value of d# 64 will be used. | 
|  | 13 | +\ | 
|  | 14 | +\  Functions exported: | 
|  | 15 | +\	{push-locals}  ( #ilocals #ulocals -- ) | 
|  | 16 | +\	{pop-locals}   ( #locals -- ) | 
|  | 17 | +\	_{local}       ( local-var# -- addr ) | 
|  | 18 | +\ | 
|  | 19 | +\  Additional overloaded function: | 
|  | 20 | +\      catch		\  Restore Locals after a  throw | 
|  | 21 | + | 
|  | 22 | +\  The user is responsible for declaring the maximum depth of the | 
|  | 23 | +\      run-time Locals stack, in storage units, by defining the | 
|  | 24 | +\      constant  _local-storage-size_  before floading this file. | 
|  | 25 | +\  The definition may be created either by defining it as a constant | 
|  | 26 | +\      in the startup-file that FLOADs this and other files in the | 
|  | 27 | +\      source program, or via a command-line user-symbol definition | 
|  | 28 | +\      of a form resembling:   -d '_local-storage-size_=d# 42' | 
|  | 29 | +\      (be sure to enclose it within quotes so that the shell treats | 
|  | 30 | +\      it as a single string, and, of course, replace the "42" with | 
|  | 31 | +\      the actual number you need...) | 
|  | 32 | +\  If both forms are present, the command-line user-symbol value will | 
|  | 33 | +\      be used to create a duplicate definition of the named constant, | 
|  | 34 | +\      which will prevail over the earlier definition, and will remain | 
|  | 35 | +\      available for examination during development and testing.  The | 
|  | 36 | +\      duplicate-name warning, which will not be suppressed, will also | 
|  | 37 | +\      act to alert the developer of this condition. | 
|  | 38 | +\  To measure the actual usage (in a test run), use the separate tool | 
|  | 39 | +\      found in the file  LocalValuesDevelSupport.fth . | 
|  | 40 | +\  If the user omits defining  _local-storage-size_  the following | 
|  | 41 | +\      ten-line sequence will supply a default: | 
|  | 42 | + | 
|  | 43 | +[ifdef] _local-storage-size_ | 
|  | 44 | +    f[  [defined] _local-storage-size_   true  ]f | 
|  | 45 | +[else] | 
|  | 46 | +    [ifexist] _local-storage-size_ | 
|  | 47 | +	f[  false  ]f | 
|  | 48 | +    [else] | 
|  | 49 | +	f[  d# 64   true  ]f | 
|  | 50 | +    [then] | 
|  | 51 | +[then]		( Compile-time:  size true | false ) | 
|  | 52 | +[if]   fliteral  constant  _local-storage-size_    [then] | 
|  | 53 | + | 
|  | 54 | +_local-storage-size_    \  The number of storage units to allocate | 
|  | 55 | +  cells                 \    Convert to address units | 
|  | 56 | +  dup                   \    Keep a copy around... | 
|  | 57 | + ( n )  instance buffer: locals-storage     \  Use one of the copies | 
|  | 58 | + | 
|  | 59 | +\  The Locals Pointer, added to the base address of  locals-storage | 
|  | 60 | +\      points to the base-address of the currently active set of Locals. | 
|  | 61 | +\      Locals will be accessed as a positive offset from there. | 
|  | 62 | +\  Start the Locals Pointer at end of the buffer. | 
|  | 63 | +\  A copy of ( N ), the number of address units that were allocated | 
|  | 64 | +\      for the buffer, is still on the stack.  Use it here. | 
|  | 65 | + ( n )  instance value locals-pointer | 
|  | 66 | +    | 
|  | 67 | +\  Support for  {push-locals} | 
|  | 68 | + | 
|  | 69 | +\  Error-check. | 
|  | 70 | +: not-enough-locals? ( #ilocals #ulocals -- error? ) | 
|  | 71 | +   + cells locals-pointer swap - 0<  | 
|  | 72 | +; | 
|  | 73 | + | 
|  | 74 | +\  Error message. | 
|  | 75 | +: .not-enough-locals ( -- ) | 
|  | 76 | +    cr ." FATAL ERROR:  Local Values Usage exceeds allocation." cr | 
|  | 77 | +; | 
|  | 78 | + | 
|  | 79 | +\  Detect, announce and handle error. | 
|  | 80 | +: check-enough-locals ( #ilocals #ulocals -- | <ABORT> ) | 
|  | 81 | +    not-enough-locals? if | 
|  | 82 | +        .not-enough-locals | 
|  | 83 | +        abort | 
|  | 84 | +    then | 
|  | 85 | +; | 
|  | 86 | + | 
|  | 87 | +\  The uninitialized locals can be allocated in a single batch | 
|  | 88 | +: push-uninitted-locals ( #ulocals -- ) | 
|  | 89 | +    cells locals-pointer swap - to locals-pointer | 
|  | 90 | +; | 
|  | 91 | + | 
|  | 92 | +\  The Initialized locals are initted from the items on top of the stack | 
|  | 93 | +\      at the start of the routine.  If we allocate them one at a time, | 
|  | 94 | +\      we get them into the right order.  I.e., the last-one named gets | 
|  | 95 | +\      the top item, the earlier ones get successively lower items. | 
|  | 96 | +: push-one-initted-local ( pstack-item -- ) | 
|  | 97 | +    locals-pointer 1 cells - | 
|  | 98 | +    dup to locals-pointer | 
|  | 99 | +    locals-storage  + ! | 
|  | 100 | +; | 
|  | 101 | + | 
|  | 102 | +\  Push all the Initialized locals. | 
|  | 103 | +: push-initted-locals ( N_#ilocals-1 ... N_0 #ilocals -- ) | 
|  | 104 | +    0 ?do push-one-initted-local loop | 
|  | 105 | +; | 
|  | 106 | + | 
|  | 107 | +: {push-locals}  ( N_#ilocals ... N_1 #ilocals #ulocals -- ) | 
|  | 108 | +    2dup check-enough-locals | 
|  | 109 | +    push-uninitted-locals		( ..... #i ) | 
|  | 110 | +    push-initted-locals			(  ) | 
|  | 111 | +; | 
|  | 112 | + | 
|  | 113 | +\  Pop all the locals. | 
|  | 114 | +\  The param is the number to pop. | 
|  | 115 | +: {pop-locals} ( total#locals -- ) | 
|  | 116 | +    cells locals-pointer + to locals-pointer | 
|  | 117 | +; | 
|  | 118 | + | 
|  | 119 | +\  The address from/to which values will be moved, given the local-var# | 
|  | 120 | +: _{local} ( local-var# -- addr ) | 
|  | 121 | +    cells locals-pointer + locals-storage  + | 
|  | 122 | +; | 
|  | 123 | + | 
|  | 124 | +\  We need to overload  catch  such that the state of the Locals Pointer | 
|  | 125 | +\  will be preserved and restored after a  throw . | 
|  | 126 | +overload  : catch ( ??? xt -- ???' false | ???'' throw-code ) | 
|  | 127 | +    locals-pointer >r   ( ???  xt )                       ( R: old-locals-ptr ) | 
|  | 128 | +    catch               ( ???' false | ???'' throw-code ) ( R: old-locals-ptr ) | 
|  | 129 | +    \  No need to inspect the throw-code. | 
|  | 130 | +    \  If  catch  returned a zero, the Locals Pointer | 
|  | 131 | +    \  is valid anyway, so restoring it is harmless. | 
|  | 132 | +    r>  to locals-pointer | 
|  | 133 | +; | 
0 commit comments