picolisp

Unnamed repository; edit this file to name it for gitweb.
git clone https://logand.com/git/picolisp.git/
Log | Files | Refs | README | LICENSE

commit 0ea1bf30883483fe49c5d787c47ded55c6c36976
parent 5973190bb21a7deb3fafcdeb241156533fbeee0f
Author: Commit-Bot <unknown>
Date:   Sat, 19 Jun 2010 08:20:45 +0000

Automatic commit from picoLisp.tgz, From: Sat, 19 Jun 2010 08:20:45 GMT
Diffstat:
Mlib/math64.l | 30+++++++++++++++++++-----------
Mlib/tags | 34+++++++++++++++++-----------------
Msrc/big.c | 6+++++-
Msrc64/main.l | 18++++++++++++++----
Msrc64/version.l | 4++--
5 files changed, 57 insertions(+), 35 deletions(-)

diff --git a/lib/math64.l b/lib/math64.l @@ -1,4 +1,4 @@ -# 18may10abu +# 19jun10abu # (c) Software Lab. Alexander Burger (load "lib/native.l") @@ -20,44 +20,52 @@ #include <math.h> +static long mkNum(int scl, double d) { + if (isnan(d) || isinf(d) < 0) + return 0x8000000000000000; + if (isinf(d) > 0) + return 0x7FFFFFFFFFFFFFFF; + return round((double)scl * d); +} + long Pow(long x, long y, int scl) { - return round((double)scl * pow((double)x / (double)scl, (double)y / (double)scl)); + return mkNum(scl, pow((double)x / (double)scl, (double)y / (double)scl)); } long Exp(long x, int scl) { - return round((double)scl * exp((double)x / (double)scl)); + return mkNum(scl, exp((double)x / (double)scl)); } long Log(long x, int scl) { - return round((double)scl * log((double)x / (double)scl)); + return mkNum(scl, log((double)x / (double)scl)); } long Sin(long a, int scl) { - return round((double)scl * sin((double)a / (double)scl)); + return mkNum(scl, sin((double)a / (double)scl)); } long Cos(long a, int scl) { - return round((double)scl * cos((double)a / (double)scl)); + return mkNum(scl, cos((double)a / (double)scl)); } long Tan(long a, int scl) { - return round((double)scl * tan((double)a / (double)scl)); + return mkNum(scl, tan((double)a / (double)scl)); } long Asin(long a, int scl) { - return round((double)scl * asin((double)a / (double)scl)); + return mkNum(scl, asin((double)a / (double)scl)); } long Acos(long a, int scl) { - return round((double)scl * acos((double)a / (double)scl)); + return mkNum(scl, acos((double)a / (double)scl)); } long Atan(long a, int scl) { - return round((double)scl * atan((double)a / (double)scl)); + return mkNum(scl, atan((double)a / (double)scl)); } long Atan2(long x, long y, int scl) { - return round((double)scl * atan2((double)x / (double)scl, (double)y / (double)scl)); + return mkNum(scl, atan2((double)x / (double)scl, (double)y / (double)scl)); } /**/ diff --git a/lib/tags b/lib/tags @@ -32,9 +32,9 @@ and (1643 . "@src64/flow.l") any (3764 . "@src64/io.l") append (1329 . "@src64/subr.l") apply (597 . "@src64/apply.l") -arg (1989 . "@src64/main.l") -args (1965 . "@src64/main.l") -argv (2610 . "@src64/main.l") +arg (1999 . "@src64/main.l") +args (1975 . "@src64/main.l") +argv (2620 . "@src64/main.l") as (146 . "@src64/flow.l") asoq (2942 . "@src64/subr.l") assoc (2907 . "@src64/subr.l") @@ -65,7 +65,7 @@ call (3102 . "@src64/flow.l") car (5 . "@src64/subr.l") case (1984 . "@src64/flow.l") catch (2484 . "@src64/flow.l") -cd (2365 . "@src64/main.l") +cd (2375 . "@src64/main.l") cdaaar (464 . "@src64/subr.l") cdaadr (487 . "@src64/subr.l") cdaar (179 . "@src64/subr.l") @@ -87,7 +87,7 @@ chop (1093 . "@src64/sym.l") circ (816 . "@src64/subr.l") clip (1786 . "@src64/subr.l") close (4152 . "@src64/io.l") -cmd (2592 . "@src64/main.l") +cmd (2602 . "@src64/main.l") cnt (1297 . "@src64/apply.l") co (2566 . "@src64/flow.l") commit (1503 . "@src64/db.l") @@ -98,9 +98,9 @@ connect (201 . "@src64/net.l") cons (747 . "@src64/subr.l") copy (1216 . "@src64/subr.l") ctl (4092 . "@src64/io.l") -ctty (2390 . "@src64/main.l") +ctty (2400 . "@src64/main.l") cut (1797 . "@src64/sym.l") -date (2104 . "@src64/main.l") +date (2114 . "@src64/main.l") dbck (2092 . "@src64/db.l") de (549 . "@src64/flow.l") dec (2006 . "@src64/big.l") @@ -110,7 +110,7 @@ del (1852 . "@src64/sym.l") delete (1392 . "@src64/subr.l") delq (1443 . "@src64/subr.l") diff (2563 . "@src64/subr.l") -dir (2523 . "@src64/main.l") +dir (2533 . "@src64/main.l") dm (561 . "@src64/flow.l") do (2158 . "@src64/flow.l") e (2932 . "@src64/flow.l") @@ -126,7 +126,7 @@ extern (900 . "@src64/sym.l") extra (1284 . "@src64/flow.l") extract (1102 . "@src64/apply.l") fifo (1963 . "@src64/sym.l") -file (2470 . "@src64/main.l") +file (2480 . "@src64/main.l") fill (3177 . "@src64/subr.l") filter (1045 . "@src64/apply.l") fin (2020 . "@src64/subr.l") @@ -163,7 +163,7 @@ ifn (1884 . "@src64/flow.l") in (3988 . "@src64/io.l") inc (1939 . "@src64/big.l") index (2611 . "@src64/subr.l") -info (2427 . "@src64/main.l") +info (2437 . "@src64/main.l") intern (875 . "@src64/sym.l") ipid (3214 . "@src64/flow.l") isa (978 . "@src64/flow.l") @@ -220,7 +220,7 @@ nand (1678 . "@src64/flow.l") native (1324 . "@src64/main.l") need (918 . "@src64/subr.l") new (852 . "@src64/flow.l") -next (1972 . "@src64/main.l") +next (1982 . "@src64/main.l") nil (1761 . "@src64/flow.l") nond (1961 . "@src64/flow.l") nor (1699 . "@src64/flow.l") @@ -234,7 +234,7 @@ onOff (1613 . "@src64/sym.l") one (1646 . "@src64/sym.l") open (4114 . "@src64/io.l") opid (3230 . "@src64/flow.l") -opt (2713 . "@src64/main.l") +opt (2723 . "@src64/main.l") or (1659 . "@src64/flow.l") out (4008 . "@src64/io.l") pack (1144 . "@src64/sym.l") @@ -267,7 +267,7 @@ push (1688 . "@src64/sym.l") push1 (1724 . "@src64/sym.l") put (2698 . "@src64/sym.l") putl (2950 . "@src64/sym.l") -pwd (2354 . "@src64/main.l") +pwd (2364 . "@src64/main.l") queue (1920 . "@src64/sym.l") quit (1033 . "@src64/main.l") quote (141 . "@src64/flow.l") @@ -278,7 +278,7 @@ raw (461 . "@src64/main.l") rd (4891 . "@src64/io.l") read (2502 . "@src64/io.l") replace (1490 . "@src64/subr.l") -rest (2018 . "@src64/main.l") +rest (2028 . "@src64/main.l") reverse (1665 . "@src64/subr.l") rewind (4857 . "@src64/io.l") rollback (1885 . "@src64/db.l") @@ -319,7 +319,7 @@ text (1272 . "@src64/sym.l") throw (2510 . "@src64/flow.l") tick (3182 . "@src64/flow.l") till (3409 . "@src64/io.l") -time (2237 . "@src64/main.l") +time (2247 . "@src64/main.l") touch (1049 . "@src64/sym.l") trim (1746 . "@src64/subr.l") try (1191 . "@src64/flow.l") @@ -332,9 +332,9 @@ up (708 . "@src64/main.l") upp? (3232 . "@src64/sym.l") uppc (3296 . "@src64/sym.l") use (1592 . "@src64/flow.l") -usec (2342 . "@src64/main.l") +usec (2352 . "@src64/main.l") val (1463 . "@src64/sym.l") -version (2727 . "@src64/main.l") +version (2737 . "@src64/main.l") wait (2988 . "@src64/io.l") when (1903 . "@src64/flow.l") while (2080 . "@src64/flow.l") diff --git a/src/big.c b/src/big.c @@ -1,4 +1,4 @@ -/* 30apr10abu +/* 19jun10abu * (c) Software Lab. Alexander Burger */ @@ -536,6 +536,10 @@ any doubleToNum(double d) { any x; cell c1; + if (isnan(d) || isinf(d) < 0) + return Nil; + if (isinf(d) > 0) + return T; sign = NO; if (d < 0.0) sign = YES, d = -d; diff --git a/src64/main.l b/src64/main.l @@ -1,4 +1,4 @@ -# 12jun10abu +# 19jun10abu # (c) Software Lab. Alexander Burger ### Global return labels ### @@ -1566,7 +1566,12 @@ shl E 4 # Make short number or E CNT else - call boxNumE_E # Make bignum + cmp E (hex "7FFFFFFFFFFFFFFF") # Infinity? + if eq # Yes + ld E TSym # Return T + else + call boxNumE_E # Make bignum + end end else neg E # Negate @@ -1575,8 +1580,13 @@ shl E 4 # Make negative short number or E (| SIGN CNT) else - call boxNumE_E # Make bignum - or E SIGN # Set negative + cmp E (hex "8000000000000000") # NaN or negative infinity? + if eq # Yes + ld E Nil # Return NIL + else + call boxNumE_E # Make bignum + or E SIGN # Set negative + end end end else diff --git a/src64/version.l b/src64/version.l @@ -1,6 +1,6 @@ -# 18jun10abu +# 19jun10abu # (c) Software Lab. Alexander Burger -(de *Version 3 0 2 31) +(de *Version 3 0 2 32) # vi:et:ts=3:sw=3