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:
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
