math.c (9592B)
1 /* 01apr08abu 2 * (c) Software Lab. Alexander Burger 3 */ 4 5 #include "pico.h" 6 7 static void divErr(any ex) {err(ex,NULL,"Div/0");} 8 9 /* Number of bytes */ 10 int numBytes(any x) { 11 int n = 4; 12 word w = (word)x >> 2; 13 14 if ((w & 0xFF000000) == 0) { 15 --n; 16 if ((w & 0xFF0000) == 0) { 17 --n; 18 if ((w & 0xFF00) == 0) 19 --n; 20 } 21 } 22 return n; 23 } 24 25 /* Make number from symbol */ 26 any symToNum(any s, int scl, int sep, int ign) { 27 unsigned c; 28 int i; 29 word w; 30 bool sign, frac; 31 long n; 32 33 if (!(c = getByte1(&i, &w, &s))) 34 return NULL; 35 while (c <= ' ') /* Skip white space */ 36 if (!(c = getByte(&i, &w, &s))) 37 return NULL; 38 sign = NO; 39 if (c == '+' || c == '-' && (sign = YES)) 40 if (!(c = getByte(&i, &w, &s))) 41 return NULL; 42 if ((c -= '0') > 9) 43 return NULL; 44 frac = NO; 45 n = c; 46 while ((c = getByte(&i, &w, &s)) && (!frac || scl)) { 47 if ((int)c == sep) { 48 if (frac) 49 return NULL; 50 frac = YES; 51 } 52 else if ((int)c != ign) { 53 if ((c -= '0') > 9) 54 return NULL; 55 n = n * 10 + c; 56 if (frac) 57 --scl; 58 } 59 } 60 if (c) { 61 if ((c -= '0') > 9) 62 return NULL; 63 if (c >= 5) 64 n += 1; 65 while (c = getByte(&i, &w, &s)) { 66 if ((c -= '0') > 9) 67 return NULL; 68 } 69 } 70 if (frac) 71 while (--scl >= 0) 72 n *= 10; 73 return box(sign? -n : n); 74 } 75 76 /* Make symbol from number */ 77 any numToSym(any x, int scl, int sep, int ign) { 78 int i; 79 word w; 80 cell c1; 81 long n; 82 byte *p, buf[BITS/2]; 83 84 n = unBox(x); 85 putByte0(&i, &w, &x); 86 if (n < 0) { 87 n = -n; 88 putByte('-', &i, &w, &x, &c1); 89 } 90 for (p = buf;;) { 91 *p = n % 10; 92 if ((n /= 10) == 0) 93 break; 94 ++p; 95 } 96 if ((scl = p - buf - scl) < 0) { 97 putByte('0', &i, &w, &x, &c1); 98 putByte(sep, &i, &w, &x, &c1); 99 while (scl < -1) 100 putByte('0', &i, &w, &x, &c1), ++scl; 101 } 102 for (;;) { 103 putByte(*p + '0', &i, &w, &x, &c1); 104 if (--p < buf) 105 return popSym(i, w, x, &c1); 106 if (scl == 0) 107 putByte(sep, &i, &w, &x, &c1); 108 else if (ign && scl > 0 && scl % 3 == 0) 109 putByte(ign, &i, &w, &x, &c1); 110 --scl; 111 } 112 } 113 114 // (format 'num ['num ['sym1 ['sym2]]]) -> sym 115 // (format 'sym ['num ['sym1 ['sym2]]]) -> num 116 any doFormat(any ex) { 117 int scl, sep, ign; 118 any x, y; 119 cell c1; 120 121 x = cdr(ex), Push(c1, EVAL(car(x))); 122 NeedAtom(ex,data(c1)); 123 x = cdr(x), y = EVAL(car(x)); 124 scl = isNil(y)? 0 : xNum(ex, y); 125 sep = '.'; 126 ign = 0; 127 if (isCell(x = cdr(x))) { 128 y = EVAL(car(x)); 129 NeedSymb(ex,y); 130 sep = firstByte(y); 131 if (isCell(x = cdr(x))) { 132 y = EVAL(car(x)); 133 NeedSymb(ex,y); 134 ign = firstByte(y); 135 } 136 } 137 data(c1) = isNum(data(c1))? 138 numToSym(data(c1), scl, sep, ign) : 139 symToNum(name(data(c1)), scl, sep, ign) ?: Nil; 140 return Pop(c1); 141 } 142 143 // (+ 'num ..) -> num 144 any doAdd(any ex) { 145 any x, y; 146 long n; 147 148 x = cdr(ex); 149 if (isNil(y = EVAL(car(x)))) 150 return Nil; 151 NeedNum(ex,y); 152 n = unBox(y); 153 while (isCell(x = cdr(x))) { 154 if (isNil(y = EVAL(car(x)))) 155 return Nil; 156 NeedNum(ex,y); 157 n += unBox(y); 158 } 159 return box(n); 160 } 161 162 // (- 'num ..) -> num 163 any doSub(any ex) { 164 any x, y; 165 long n; 166 167 x = cdr(ex); 168 if (isNil(y = EVAL(car(x)))) 169 return Nil; 170 NeedNum(ex,y); 171 n = unBox(y); 172 if (!isCell(x = cdr(x))) 173 return box(-n); 174 do { 175 if (isNil(y = EVAL(car(x)))) 176 return Nil; 177 NeedNum(ex,y); 178 n -= unBox(y); 179 } while (isCell(x = cdr(x))); 180 return box(n); 181 } 182 183 // (inc 'num) -> num 184 // (inc 'var ['num]) -> num 185 any doInc(any ex) { 186 any x, y; 187 cell c1; 188 189 x = cdr(ex); 190 if (isNil(data(c1) = EVAL(car(x)))) 191 return Nil; 192 if (isNum(data(c1))) 193 return (any)(num(data(c1)) + 4); 194 CheckVar(ex,data(c1)); 195 if (!isCell(x = cdr(x))) { 196 if (isNil(val(data(c1)))) 197 return Nil; 198 NeedNum(ex,val(data(c1))); 199 val(data(c1)) = (any)(num(val(data(c1))) + 4); 200 } 201 else { 202 Save(c1); 203 y = EVAL(car(x)); 204 drop(c1); 205 if (isNil(val(data(c1))) || isNil(y)) 206 return Nil; 207 NeedNum(ex,val(data(c1))); 208 NeedNum(ex,y); 209 val(data(c1)) = box(unBox(val(data(c1))) + unBox(y)); 210 } 211 return val(data(c1)); 212 } 213 214 // (dec 'num) -> num 215 // (dec 'var ['num]) -> num 216 any doDec(any ex) { 217 any x, y; 218 cell c1; 219 220 x = cdr(ex); 221 if (isNil(data(c1) = EVAL(car(x)))) 222 return Nil; 223 if (isNum(data(c1))) 224 return (any)(num(data(c1)) - 4); 225 CheckVar(ex,data(c1)); 226 if (!isCell(x = cdr(x))) { 227 if (isNil(val(data(c1)))) 228 return Nil; 229 NeedNum(ex,val(data(c1))); 230 val(data(c1)) = (any)(num(val(data(c1))) - 4); 231 } 232 else { 233 Save(c1); 234 y = EVAL(car(x)); 235 drop(c1); 236 if (isNil(val(data(c1))) || isNil(y)) 237 return Nil; 238 NeedNum(ex,val(data(c1))); 239 NeedNum(ex,y); 240 val(data(c1)) = box(unBox(val(data(c1))) - unBox(y)); 241 } 242 return val(data(c1)); 243 } 244 245 // (* 'num ..) -> num 246 any doMul(any ex) { 247 any x, y; 248 long n; 249 250 x = cdr(ex); 251 if (isNil(y = EVAL(car(x)))) 252 return Nil; 253 NeedNum(ex,y); 254 n = unBox(y); 255 while (isCell(x = cdr(x))) { 256 if (isNil(y = EVAL(car(x)))) 257 return Nil; 258 NeedNum(ex,y); 259 n *= unBox(y); 260 } 261 return box(n); 262 } 263 264 // (*/ 'num1 ['num2 ..] 'num3) -> num 265 any doMulDiv(any ex) { 266 any x, y; 267 long long n; 268 269 x = cdr(ex); 270 if (isNil(y = EVAL(car(x)))) 271 return Nil; 272 NeedNum(ex,y); 273 n = unBox(y); 274 for (;;) { 275 x = cdr(x); 276 if (isNil(y = EVAL(car(x)))) 277 return Nil; 278 NeedNum(ex,y); 279 if (!isCell(cdr(x))) 280 break; 281 n *= unBox(y); 282 } 283 if (y == Zero) 284 divErr(ex); 285 return box((long)((n + unBox(y)/2) / unBox(y))); 286 } 287 288 // (/ 'num ..) -> num 289 any doDiv(any ex) { 290 any x, y; 291 long n; 292 293 x = cdr(ex); 294 if (isNil(y = EVAL(car(x)))) 295 return Nil; 296 NeedNum(ex,y); 297 n = unBox(y); 298 while (isCell(x = cdr(x))) { 299 if (isNil(y = EVAL(car(x)))) 300 return Nil; 301 NeedNum(ex,y); 302 if (y == Zero) 303 divErr(ex); 304 n /= unBox(y); 305 } 306 return box(n); 307 } 308 309 // (% 'num ..) -> num 310 any doRem(any ex) { 311 any x, y; 312 long n; 313 314 x = cdr(ex); 315 if (isNil(y = EVAL(car(x)))) 316 return Nil; 317 NeedNum(ex,y); 318 n = unBox(y); 319 while (isCell(x = cdr(x))) { 320 if (isNil(y = EVAL(car(x)))) 321 return Nil; 322 NeedNum(ex,y); 323 if (y == Zero) 324 divErr(ex); 325 n %= unBox(y); 326 } 327 return box(n); 328 } 329 330 // (>> 'num 'num) -> num 331 any doShift(any ex) { 332 any x, y; 333 long n; 334 335 x = cdr(ex), n = evNum(ex,x); 336 x = cdr(x); 337 if (isNil(y = EVAL(car(x)))) 338 return Nil; 339 NeedNum(ex,y); 340 if (n > 0) 341 return box(unBox(y) >> n); 342 return box(unBox(y) << -n); 343 } 344 345 // (lt0 'any) -> num | NIL 346 any doLt0(any x) { 347 x = cdr(x); 348 return isNum(x = EVAL(car(x))) && num(x)<0? x : Nil; 349 } 350 351 // (ge0 'any) -> num | NIL 352 any doGe0(any x) { 353 x = cdr(x); 354 return isNum(x = EVAL(car(x))) && num(x)>=0? x : Nil; 355 } 356 357 // (gt0 'any) -> num | NIL 358 any doGt0(any x) { 359 x = cdr(x); 360 return isNum(x = EVAL(car(x))) && num(x)>num(Zero)? x : Nil; 361 } 362 363 // (abs 'num) -> num 364 any doAbs(any ex) { 365 any x; 366 367 x = cdr(ex); 368 if (isNil(x = EVAL(car(x)))) 369 return Nil; 370 NeedNum(ex,x); 371 return num(x)<0? box(-unBox(x)) : x; 372 } 373 374 // (bit? 'num ..) -> num | NIL 375 any doBitQ(any ex) { 376 any x, y, z; 377 378 x = cdr(ex), y = EVAL(car(x)); 379 NeedNum(ex,y); 380 while (isCell(x = cdr(x))) { 381 if (isNil(z = EVAL(car(x)))) 382 return Nil; 383 NeedNum(ex,z); 384 if ((unBox(y) & unBox(z)) != unBox(y)) 385 return Nil; 386 } 387 return y; 388 } 389 390 // (& 'num ..) -> num 391 any doBitAnd(any ex) { 392 any x, y, z; 393 394 x = cdr(ex); 395 if (isNil(y = EVAL(car(x)))) 396 return Nil; 397 NeedNum(ex,y); 398 while (isCell(x = cdr(x))) { 399 if (isNil(z = EVAL(car(x)))) 400 return Nil; 401 NeedNum(ex,z); 402 y = box(unBox(y) & unBox(z)); 403 } 404 return y; 405 } 406 407 // (| 'num ..) -> num 408 any doBitOr(any ex) { 409 any x, y, z; 410 411 x = cdr(ex); 412 if (isNil(y = EVAL(car(x)))) 413 return Nil; 414 NeedNum(ex,y); 415 while (isCell(x = cdr(x))) { 416 if (isNil(z = EVAL(car(x)))) 417 return Nil; 418 NeedNum(ex,z); 419 y = box(unBox(y) | unBox(z)); 420 } 421 return y; 422 } 423 424 // (x| 'num ..) -> num 425 any doBitXor(any ex) { 426 any x, y, z; 427 428 x = cdr(ex); 429 if (isNil(y = EVAL(car(x)))) 430 return Nil; 431 NeedNum(ex,y); 432 while (isCell(x = cdr(x))) { 433 if (isNil(z = EVAL(car(x)))) 434 return Nil; 435 NeedNum(ex,z); 436 y = box(unBox(y) ^ unBox(z)); 437 } 438 return y; 439 } 440 441 // (sqrt 'num) -> num 442 any doSqrt(any ex) { 443 any x; 444 long a, b, n, r; 445 446 x = cdr(ex); 447 if (isNil(x = EVAL(car(x)))) 448 return Nil; 449 NeedNum(ex,x); 450 if ((n = unBox(x)) < 0) 451 err(ex, x, "Bad argument"); 452 r = 0; 453 a = 1L << 28; 454 do { 455 b = r + a; 456 r >>= 1; 457 if (b <= n) 458 n -= b, r += a; 459 } while (a >>= 2); 460 return box(r); 461 } 462 463 static u_int64_t Seed; 464 #define hi(t) (word)((t) >> 32) 465 466 // (seed 'num) -> num 467 any doSeed(any ex) { 468 return box(hi(Seed = evNum(ex,cdr(ex)) * 6364136223846793005LL + 1)); 469 } 470 471 // (rand ['num1 'num2] | ['T]) -> num | flg 472 any doRand(any ex) { 473 any x; 474 long n; 475 476 x = cdr(ex); 477 Seed = Seed * 6364136223846793005LL + 1; 478 if (isNil(x = EVAL(car(x)))) 479 return box(hi(Seed)); 480 if (x == T) 481 return hi(Seed) & 1 ? T : Nil; 482 n = xNum(ex,x); 483 return box(n + hi(Seed) % (evNum(ex,cddr(ex)) + 1 - n)); 484 }