1S" 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 17hide 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 , ; 23S" 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 351 constant local-is-double 362 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 109set-current 110 111S" 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 225previous 226[endif] 227