andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: Prepare for M2-Planet: math.c. 

* src/math.c: Rewrite C constructs not supported by M2-Planet.
This commit is contained in:
Jan Nieuwenhuizen 2019-10-21 19:46:55 +02:00
parent ba83a177d2
commit 5d4976ccfb
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
1 changed files with 28 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
src/math.c
View File

@ -38,7 +38,7 @@ assert_number (char const *name, SCM x)
} }
SCM SCM
greater_p (SCM x) ///((name . ">") (arity . n)) greater_p (SCM x) /*:((name . ">") (arity . n)) */
{ {
if (x == cell_nil) if (x == cell_nil)
return cell_t; return cell_t;
@ -57,7 +57,7 @@ greater_p (SCM x) ///((name . ">") (arity . n))
} }
SCM SCM
less_p (SCM x) ///((name . "<") (arity . n)) less_p (SCM x) /*:((name . "<") (arity . n)) */
{ {
if (x == cell_nil) if (x == cell_nil)
return cell_t; return cell_t;
@ -76,7 +76,7 @@ less_p (SCM x) ///((name . "<") (arity . n))
} }
SCM SCM
is_p (SCM x) ///((name . "=") (arity . n)) is_p (SCM x) /*:((name . "=") (arity . n)) */
{ {
if (x == cell_nil) if (x == cell_nil)
return cell_t; return cell_t;
@ -93,7 +93,7 @@ is_p (SCM x) ///((name . "=") (arity . n))
} }
SCM SCM
minus (SCM x) ///((name . "-") (arity . n)) minus (SCM x) /*:((name . "-") (arity . n)) */
{ {
assert_number ("minus", CAR (x)); assert_number ("minus", CAR (x));
long n = VALUE (CAR (x)); long n = VALUE (CAR (x));
@ -103,27 +103,27 @@ minus (SCM x) ///((name . "-") (arity . n))
while (x != cell_nil) while (x != cell_nil)
{ {
assert_number ("minus", CAR (x)); assert_number ("minus", CAR (x));
n -= VALUE (car (x)); n = n - VALUE (car (x));
x = cdr (x); x = cdr (x);
} }
return MAKE_NUMBER (n); return MAKE_NUMBER (n);
} }
SCM SCM
plus (SCM x) ///((name . "+") (arity . n)) plus (SCM x) /*:((name . "+") (arity . n)) */
{ {
long n = 0; long n = 0;
while (x != cell_nil) while (x != cell_nil)
{ {
assert_number ("plus", CAR (x)); assert_number ("plus", CAR (x));
n += VALUE (car (x)); n = n + VALUE (car (x));
x = cdr (x); x = cdr (x);
} }
return MAKE_NUMBER (n); return MAKE_NUMBER (n);
} }
SCM SCM
divide (SCM x) ///((name . "/") (arity . n)) divide (SCM x) /*:((name . "/") (arity . n)) */
{ {
long n = 1; long n = 1;
if (x != cell_nil) if (x != cell_nil)
@ -138,9 +138,9 @@ divide (SCM x) ///((name . "/") (arity . n))
long y = VALUE (CAR (x)); long y = VALUE (CAR (x));
if (y == 0) if (y == 0)
error (cstring_to_symbol ("divide-by-zero"), x); error (cstring_to_symbol ("divide-by-zero"), x);
if (!n) if (n == 0)
break; break;
n /= y; n = n / y;
x = cdr (x); x = cdr (x);
} }
return MAKE_NUMBER (n); return MAKE_NUMBER (n);
@ -156,45 +156,47 @@ modulo (SCM a, SCM b)
if (y == 0) if (y == 0)
error (cstring_to_symbol ("divide-by-zero"), a); error (cstring_to_symbol ("divide-by-zero"), a);
while (x < 0) while (x < 0)
x += y; x = x + y;
x = x ? x % y : 0; if (x != 0)
x = x % y;
return MAKE_NUMBER (x); return MAKE_NUMBER (x);
} }
SCM SCM
multiply (SCM x) ///((name . "*") (arity . n)) multiply (SCM x) /*:((name . "*") (arity . n)) */
{ {
long n = 1; long n = 1;
while (x != cell_nil) while (x != cell_nil)
{ {
assert_number ("multiply", CAR (x)); assert_number ("multiply", CAR (x));
n *= VALUE (car (x)); n = n * VALUE (car (x));
x = cdr (x); x = cdr (x);
} }
return MAKE_NUMBER (n); return MAKE_NUMBER (n);
} }
SCM SCM
logand (SCM x) ///((arity . n)) logand (SCM x) /*:((arity . n)) */
{ {
long n = 0; long n = 0;
while (x != cell_nil) while (x != cell_nil)
{ {
assert_number ("multiply", CAR (x)); assert_number ("multiply", CAR (x));
n &= VALUE (car (x)); n = n & VALUE (car (x));
x = cdr (x); x = cdr (x);
} }
return MAKE_NUMBER (n); return MAKE_NUMBER (n);
} }
SCM SCM
logior (SCM x) ///((arity . n)) logior (SCM x) /*:((arity . n)) */
{ {
long n = 0; long n = 0;
while (x != cell_nil) while (x != cell_nil)
{ {
assert_number ("logior", CAR (x)); assert_number ("logior", CAR (x));
n |= VALUE (car (x)); n = n | VALUE (car (x));
x = cdr (x); x = cdr (x);
} }
return MAKE_NUMBER (n); return MAKE_NUMBER (n);
@ -209,13 +211,13 @@ lognot (SCM x)
} }
SCM SCM
logxor (SCM x) ///((arity . n)) logxor (SCM x) /*:((arity . n)) */
{ {
long n = 0; long n = 0;
while (x != cell_nil) while (x != cell_nil)
{ {
assert_number ("logxor", CAR (x)); assert_number ("logxor", CAR (x));
n ^= VALUE (car (x)); n = n ^ VALUE (car (x));
x = cdr (x); x = cdr (x);
} }
return MAKE_NUMBER (n); return MAKE_NUMBER (n);
@ -228,5 +230,10 @@ ash (SCM n, SCM count)
assert_number ("ash", count); assert_number ("ash", count);
long cn = VALUE (n); long cn = VALUE (n);
long ccount = VALUE (count); long ccount = VALUE (count);
return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount); long result;
if (ccount < 0)
result = cn >> -ccount;
else
result = cn << ccount;
return MAKE_NUMBER (result);
} }