usr/src/common/ficl/softcore/jhlocal.fr

   1 S" FICL_WANT_LOCALS" ENVIRONMENT? drop [if]
   2 \ ** ficl/softwords/jhlocal.fr
   3 \ ** stack comment style local syntax...
   4 \ { a b c | cleared -- d e }
   5 \ variables before the "|" are initialized in reverse order
   6 \ from the stack. Those after the "|" are zero initialized.
   7 \ Anything between "--" and "}" is treated as comment
   8 \ Uses locals...
   9 \ locstate: 0 = looking for | or -- or }}
  10 \           1 = found |
  11 \           2 = found --
  12 \           3 = found }
  13 \           4 = end of line
  14 \
  15 \ revised 2 June 2000 - { | a -- } now works correctly
  16 .( loading Johns-Hopkins locals ) cr
  17 hide
  18
  19 \ What does this do?  It's equivalent to "postpone 0", but faster.
  20 \ "ficlInstruction0" is the FICL instruction for "push a 0 on the data stack".
  21 \ --lch
  22 : compiled-zero ficlInstruction0 , ;
  23 S" FICL_WANT_FLOAT" ENVIRONMENT? drop [if]
  24 \ And this is the instruction for a floating-point 0 (0.0e).
  25 : compiled-float-zero ficlInstructionF0 , ;
  26 [endif]
  27
  28 : ?--   ( c-addr u -- c-addr u flag )
  29     2dup s" --" compare 0= ;
  30 : ?}    ( c-addr u -- c-addr u flag )
  31     2dup s" }"  compare 0= ;
  32 : ?|    ( c-addr u -- c-addr u flag )
  33     2dup s" |"  compare 0= ;
  34
  35 1 constant local-is-double
  36 2 constant local-is-float
  37
  38 \ parse-local-prefix-flags
  39 \
  40 \ Parses single-letter prefix flags from the name of a local, and returns
  41 \ a bitfield of all flags (local-is-float | local-is-double) appropriate
  42 \ for the local.  Adjusts the "c-addr u" of the name to remove any prefix.
  43 \
  44 \ Handled single-letter prefix flags:
  45 \       1  single-cell
  46 \       2  double-cell
  47 \       d  double-cell
  48 \       f  floating-point (use floating stack)
  49 \       i  integer (use data stack)
  50 \       s  single-cell
  51 \ Specify as many as you like; later flags have precidence.
  52 \ Thus, "f2:foo" and "2is2f:foo" are both double-cell floats.
  53 \
  54 \ If you don't specify anything after the colon, like "f2:",
  55 \ there is no legal prefix, so "2f:" becomes the name of the
  56 \ (single-cell data stack) local.
  57 \
  58 \ For convention, the "f" is preferred first.
  59
  60 : parse-local-prefix-flags ( c-addr u -- c-addr u flags )
  61     0 0 0 locals| stop-loop colon-offset flags   u c-addr |
  62
  63     \ if the first character is a colon, remove the colon and return 0.
  64     c-addr c@ [char] : =
  65     if
  66         over over 0  exit
  67     endif
  68
  69     u 0 do
  70         c-addr i + c@
  71        case
  72            [char] 1 of  flags local-is-double invert and  to flags  endof
  73            [char] 2 of  flags local-is-double or          to flags  endof
  74            [char] d of  flags local-is-double or          to flags  endof
  75            [char] f of  flags local-is-float  or          to flags  endof
  76            [char] i of  flags local-is-float  invert and  to flags  endof
  77            [char] s of  flags local-is-double invert and  to flags  endof
  78            [char] : of  i 1+ to colon-offset   1 to stop-loop  endof
  79            1 to stop-loop
  80        endcase
  81     stop-loop  if leave  endif
  82     loop
  83
  84     colon-offset 0=
  85     colon-offset u =
  86     or
  87     if
  88 \        ." Returning variable name -- " c-addr u type ."  -- No flags." cr
  89         c-addr u 0 exit
  90     endif
  91
  92     c-addr colon-offset +
  93     u colon-offset -
  94 \    ." Returning variable name -- " 2dup type ."  -- Flags: " flags . cr
  95     flags
  96 ;
  97
  98 : ?delim   ( c-addr u -- state | c-addr u 0 )
  99     ?|  if  2drop 1 exit endif
 100     ?-- if  2drop 2 exit endif
 101     ?}  if  2drop 3 exit endif
 102     dup 0=
 103         if  2drop 4 exit endif
 104     0
 105 ;
 106
 107
 108
 109 set-current
 110
 111 S" FICL_WANT_FLOAT" ENVIRONMENT? drop [if]
 112 : {
 113     0 0 0 locals| flags local-state nLocals |
 114
 115     \ stack locals until we hit a delimiter
 116     begin
 117         parse-word ?delim  dup to local-state
 118     0= while
 119         nLocals 1+ to nLocals
 120     repeat
 121
 122     \ now unstack the locals
 123     nLocals 0 ?do
 124             parse-local-prefix-flags to flags
 125             flags local-is-double and if
 126                 flags local-is-float and if (f2local) else (2local) endif
 127             else
 128                 flags local-is-float and if (flocal) else (local) endif
 129             endif
 130         loop   \ ( )
 131
 132     \ zero locals until -- or }
 133     local-state 1 = if
 134         begin
 135             parse-word
 136             ?delim dup to local-state
 137         0= while
 138             parse-local-prefix-flags to flags
 139             flags local-is-double and if
 140                 flags local-is-float and if
 141                     compiled-float-zero compiled-float-zero (f2local)
 142                 else
 143                     compiled-zero compiled-zero (2local)
 144                 endif
 145             else
 146                 flags local-is-float and if
 147                     compiled-float-zero (flocal)
 148                 else
 149                     compiled-zero (local)
 150                 endif
 151             endif
 152         repeat
 153     endif
 154
 155     0 0 (local)
 156
 157     \ toss words until }
 158     \ (explicitly allow | and -- in the comment)
 159     local-state 2 = if
 160         begin
 161             parse-word
 162             ?delim dup  to local-state
 163         3 < while
 164             local-state 0=  if 2drop endif
 165         repeat
 166     endif
 167
 168     local-state 3 <> abort" syntax error in { } local line"
 169 ; immediate compile-only
 170
 171 [else]
 172
 173 : {
 174     0 0 0 locals| flags local-state nLocals |
 175
 176     \ stack locals until we hit a delimiter
 177     begin
 178         parse-word ?delim  dup to local-state
 179     0= while
 180         nLocals 1+ to nLocals
 181     repeat
 182
 183     \ now unstack the locals
 184     nLocals 0 ?do
 185             parse-local-prefix-flags to flags
 186             flags local-is-double and if
 187                 (2local)
 188             else
 189                 (local)
 190             endif
 191         loop   \ ( )
 192
 193     \ zero locals until -- or }
 194     local-state 1 = if
 195         begin
 196             parse-word
 197             ?delim dup to local-state
 198         0= while
 199             parse-local-prefix-flags to flags
 200             flags local-is-double and if
 201                 compiled-zero compiled-zero (2local)
 202             else
 203                 compiled-zero (local)
 204             endif
 205         repeat
 206     endif
 207
 208     0 0 (local)
 209
 210     \ toss words until }
 211     \ (explicitly allow | and -- in the comment)
 212     local-state 2 = if
 213         begin
 214             parse-word
 215             ?delim dup  to local-state
 216         3 < while
 217             local-state 0=  if 2drop endif
 218         repeat
 219     endif
 220
 221     local-state 3 <> abort" syntax error in { } local line"
 222 ; immediate compile-only
 223 [endif]
 224
 225 previous
 226 [endif]