Merge remote-tracking branch 'origin/master' into issue-522

CHANGELOG.md

@@ -1,6 +1,18 @@
 # Changelog
 
-## 0.36.0 - TBD
+## 0.37.0 - TBD
+
+Bug Fixes
+
+- Fixed a bug in `apply` where an error may be raised when processing quoted sub-expressions. For example the following would throw an error: `(apply cons '(5 (1 2)))`. Thanks to @srgx for the bug report!
+- Fixed a beta expansion optimization bug where code such as the following would cause the compiler to hang. Thanks to Yorick Hardy for the bug report:
+
+      (define (compile-forever x) x (compile-forever x))
+
+- Added a fix from Yorick Hardy to define `*ai-v4mapped*` to zero on platforms where `AI_V4MAPPED` is undefined.
+- Updated `sqrt` to properly handle complex results given non-complex input. EG: `(sqrt -1) ==> 1i`. And updated the parser to properly handle `+i` and `-i`. Thanks to Christopher Hebert for the bug reports!
+
+## 0.36.0 - February 14, 2024
 
 Features
 
@@ -9,6 +21,7 @@ Features
 
 Bug Fixes
 
+- Yorick Hardy provided a fix to `round` so that Cyclone will round to even when x is halfway between two integers, as required by R7RS.
 - Updated various numeric functions to properly handle numeric type conversions, including `quotient`, `remainder`, `numerator`, `denominator`, `truncate`, `truncate-quotient`, and `/`.
 - Fix `exact` to properly handle complex numbers, including raising an error when passed `nan` or `inf` double values.
 - Ensure the runtime properly differentiates between `+inf.0` and `-inf.0`. Thanks to jpellegrini for the bug report.

Dockerfile

@@ -4,7 +4,7 @@ MAINTAINER justin.ethier@gmail.com
 
 ARG DEBIAN_FRONTEND=noninteractive
 
-ENV CYCLONE_VERSION v0.35.0
+ENV CYCLONE_VERSION v0.36.0
 RUN apt update -y
 RUN apt install -y build-essential git rsync texinfo libtommath-dev libck-dev make gcc
 

docs/Release-Checklist.md

@@ -7,6 +7,7 @@ Steps for making a release of Cyclone:
   - `Dockerfile`
   - `DEBIAN/control` in cyclone-bootstrap
   - `.github/workflows/Release.yml` job in cyclone-bootstrap
+  - `libs/common.sld` in cyclone winds repo
 - Update documentation, if applicable
 - Tag releases and push to Github
 - Upload release notes to `gh-pages` branch
@@ -14,3 +15,8 @@ Steps for making a release of Cyclone:
 - Update release on Homebrew (automated)
 - Update release on Dockerhub (push to bitbucket)
 - Upload new binary from cyclone-bootstrap release build to the cyclone-scheme "packages" repo
+- Update WASM hosted Cyclone
+  - Trigger CI action on the WASM repo to recompile the WASM binary: https://github.com/cyclone-scheme/wasm-terminal
+  - Download the generated `.zip` artifact
+  - Extract `terminal.js` and `terminal.wasm` and copy to the `_site` directory in the repo to update the build
+  - Optionally update year in the `terminal.html` file

include/cyclone/runtime.h

@@ -504,6 +504,7 @@ int Cyc_have_mstreams();
   } \
   return_closcall1(data, cont, &d)
 
+double round_to_nearest_even(double);
 void Cyc_exact(void *data, object cont, object z);
 object Cyc_exact_no_cps(void *data, object ptr, object z);
 

runtime.c

@@ -7538,6 +7538,8 @@ static int _read_is_numeric(const char *tok, int len)
 {
   return (len &&
           ((isdigit(tok[0])) ||
+           (((len == 2) && tok[1] == 'i') 
+            && (tok[0] == '-' || tok[0] == '+')) ||
            ((len > 1) && tok[0] == '.' && isdigit(tok[1])) ||
            ((len > 1) && (tok[1] == '.' || isdigit(tok[1]))
             && (tok[0] == '-' || tok[0] == '+'))));
@@ -7931,9 +7933,6 @@ static void _read_return_number(void *data, port_type * p, int base, int exact)
  */
 static void _read_return_complex_number(void *data, port_type * p, int len)
 {
-//      TODO: return complex num, see _read_return_number for possible template
-//      probably want to have that function extract/identify the real/imaginary components.
-//      can just scan the buffer and read out start/end index of each number.
   int i;
   make_empty_vector(vec);
   make_string(str, p->tok_buf);
@@ -8765,6 +8764,11 @@ int num2ratio(double x, double *numerator, double *denominator)
   return 0;
 }
 
+double round_to_nearest_even(double x)
+{
+ return x-remainder(x,1.0);
+}
+
 /**
  * Receive a Scheme number and pass requested portion of a rational number to
  * the continuation `cont`. Pass numerator if `numerator` is true, else the

scheme/base.sld

@@ -1372,9 +1372,9 @@
     " return_double_op_no_cps(data, ptr, trunc, z);")
   (define-c round
     "(void *data, int argc, closure _, object k, object z)"
-    " return_double_op(data, k, round, z); "
+    " return_double_op(data, k, round_to_nearest_even, z); "
     "(void *data, object ptr, object z)"
-    " return_double_op_no_cps(data, ptr, round, z);")
+    " return_double_op_no_cps(data, ptr, round_to_nearest_even, z);")
   (define-c exact
     "(void *data, int argc, closure _, object k, object z)"
     " Cyc_exact(data, k, z); "
@@ -1437,10 +1437,10 @@
       (error "exact non-negative integer required" k))
     (let* ((s (if (bignum? k)
                   (bignum-sqrt k)
-                  (exact (truncate (sqrt k)))))
+                  (exact (truncate (_sqrt k)))))
            (r (- k (* s s))))
       (values s r)))
-  (define-c sqrt
+  (define-c _sqrt
     "(void *data, int argc, closure _, object k, object z)"
     " return_inexact_double_op(data, k, sqrt, z);"
     "(void *data, object ptr, object z)"

scheme/cyclone/common.sld

@@ -18,7 +18,7 @@
     memloc
   )
   (begin
-(define *version-number* "0.36.0")
+(define *version-number* "0.37.0")
 (define *version-name* "")
 (define *version* (string-append *version-number* " " *version-name* ""))
 

scheme/cyclone/cps-optimizations.sld

@@ -1665,7 +1665,7 @@
 
     ;; Full beta expansion phase, make a pass over all of the program's AST
     (define (opt:beta-expand exp)
-;(write `(DEBUG opt:beta-expand ,exp)) (newline)
+      ;(trace:info `(opt:beta-expand ,exp)) (flush-output-port)
       (cond
        ((ast:lambda? exp)
         (ast:%make-lambda
@@ -1694,6 +1694,7 @@
        (else exp)))
 
     (define (analyze-cps exp)
+      ;(trace:info `(analyze-cps ,exp))
       (analyze:find-named-lets exp)
       (analyze:find-direct-recursive-calls exp)
       (analyze:find-recursive-calls exp)
@@ -2230,11 +2231,17 @@
       (scan (if->then exp) def-sym)
       (scan (if->else exp) def-sym))
      ((app? exp)
-      (when (equal? (car exp) def-sym)
-        (trace:info `("recursive call" ,exp))
-        (with-var! def-sym (lambda (var)
-          (adbv:set-self-rec-call! var #t)))
-        ))
+      ;(trace:info `(analyze:find-recursive-calls scan app ,exp))
+      (cond
+        ((equal? (car exp) def-sym)
+         (trace:info `("recursive call" ,exp))
+         (with-var! def-sym (lambda (var)
+           (adbv:set-self-rec-call! var #t))))
+        (else
+          (for-each
+            (lambda (e)
+              (scan e def-sym))
+            exp))))
      (else #f)))
 
   ;; TODO: probably not good enough, what about recursive functions that are not top-level??

scheme/eval.sld

@@ -89,17 +89,26 @@
       ((analyze exp *global-environment* rename-env '()) *global-environment*)
       ((analyze exp (car env) rename-env '()) (car env))))
 
+;; Called from the C runtime to support apply
 (define (eval-from-c exp . _env)
   (let ((env (if (null? _env) *global-environment* (car _env))))
     (eval (wrapc exp) env)))
 
-;; Expressions received from C code are already evaluated, but sometimes too much so.
-;; Try to wrap 
+;; Helper function for eval-from-c
+;; 
+;; Expressions received from C code are already evaluated, 
+;; however any quoted expressions will have the quotes
+;; stripped off. This is a problem for expressions that
+;; aren't self evaluating - like (1 2) - so we re-quote
+;; the expressions here so a subsequent eval will work.
+;;
 (define (wrapc exp)
   (cond 
     ((application? exp)
      (cond
-       ((compound-procedure? (car exp))
+       ((or (primitive-procedure? (car exp)) 
+            (compound-procedure? (car exp))
+            (procedure? (car exp)))
         (cons 
           (car exp)
           (map 

scheme/inexact.sld

@@ -69,7 +69,6 @@
             (/ (c-log z1) (c-log z2*)))))
     (define-inexact-op c-log "log"   "clog")
     (define-inexact-op exp   "exp"   "cexp")
-    (define-inexact-op sqrt  "sqrt"  "csqrt")
     (define-inexact-op sin   "sin"   "csin")
     (define-inexact-op cos   "cos"   "ccos")
     (define-inexact-op tan   "tan"   "ctan")
@@ -93,4 +92,58 @@
                         (* (if (eqv? y -0.0) -1 1)
                            (if (eqv? x -0.0) 3.141592653589793 x))
                         (atan1 (/ y x))))))))
+
+ (define-c
+   sqrt
+   "(void *data, int argc, closure _, object k, object z)"
+   " double complex result;
+     Cyc_check_num(data, z);
+     if (obj_is_int(z)) {
+       result = csqrt(obj_obj2int(z));
+     } else if (type_of(z) == integer_tag) {
+       result = csqrt(((integer_type *)z)->value);
+     } else if (type_of(z) == bignum_tag) {
+       result = csqrt(mp_get_double(&bignum_value(z)));
+     } else if (type_of(z) == complex_num_tag) {
+       result = csqrt(complex_num_value(z));
+     } else {
+       result = csqrt(((double_type *)z)->value);
+     }
+   
+     if (cimag(result) == 0.0) {
+       if (obj_is_int(z) && creal(result) == round(creal(result))) {
+         return_closcall1(data, k, obj_int2obj(creal(result)));
+       }
+       make_double(d, creal(result));
+       return_closcall1(data, k, &d);
+     } else {
+       complex_num_type cn;
+       assign_complex_num((&cn), result);
+       return_closcall1(data, k, &cn);
+     } "
+   "(void *data, object ptr, object z)"
+   " double complex result;
+     Cyc_check_num(data, z);
+     if (obj_is_int(z)) {
+       result = csqrt(obj_obj2int(z));
+     } else if (type_of(z) == integer_tag) {
+       result = csqrt(((integer_type *)z)->value);
+     } else if (type_of(z) == bignum_tag) {
+       result = csqrt(mp_get_double(&bignum_value(z)));
+     } else if (type_of(z) == complex_num_tag) {
+       result = csqrt(complex_num_value(z));
+     } else {
+       result = csqrt(((double_type *)z)->value);
+     }
+  
+     if (cimag(result) == 0.0) {
+       if (obj_is_int(z) && creal(result) == round(creal(result))) {
+         return obj_int2obj(creal(result));
+       }
+       assign_double(ptr, creal(result));
+     } else {
+       assign_complex_num(ptr, result);
+     }
+     return ptr;
+     ")
 ))

scheme/read.sld

@@ -294,7 +294,10 @@
                                    (substring t 0 end)
                                    (substring t end (- len 1))))
                      (real (string->number real-str))
-                     (imag (string->number imag-str))
+                     (imag (cond
+                             ((equal? "+" imag-str) 1)  ;; Special case, +i w/no number
+                             ((equal? "-" imag-str) -1) ;; Special case, -i
+                             (else (string->number imag-str))))
                     )
                 (Cyc-make-rect real imag)))
              (else

srfi/106.sld

@@ -388,7 +388,7 @@
 #ifdef AI_V4MAPPED
       return_closcall1(data, k, obj_int2obj(AI_V4MAPPED)); 
 #else
-      Cyc_rt_raise_msg(data, \"AI_V4MAPPED is not available on this platform\");
+      return_closcall1(data, k, obj_int2obj(0)); 
 #endif
       ")
     (define *ai-all* (ai-all))
@@ -398,7 +398,7 @@
 #ifdef AI_ALL
       return_closcall1(data, k, obj_int2obj(AI_ALL)); 
 #else
-      Cyc_rt_raise_msg(data, \"AI_ALL is not available on this platform\");
+      return_closcall1(data, k, obj_int2obj(0)); 
 #endif
       ")
     (make-const ai-addrconfig  "AI_ADDRCONFIG" )

tests/base.scm

@@ -9,6 +9,8 @@
 
 (import 
   (scheme base)
+  (scheme eval)
+  (scheme inexact)
   (cyclone test))
 
 
@@ -30,6 +32,12 @@
   (test '() (make-list -2))
 )
 
+(test-group
+  "apply"
+  (test '(5 1 2) (eval '(apply cons '(5 (1 2)))))
+  (test '(5 1 2) (apply cons '(5 (1 2))))
+)
+
 (cond-expand
   (memory streams
     (test-group
@@ -91,6 +99,9 @@
   (test 4.0  (ceiling 3.5))
   (test 3.0  (truncate 3.5))
   (test 4.0  (round 3.5))
+  (test 2.0  (round 2.5))
+  (test -4.0 (round -3.5))
+  (test -2.0 (round -2.5))
   (test 4.0  (round 7/2)) ;; Rationals not supported, so result is inexact
   (test 7    (round 7))
 
@@ -99,6 +110,18 @@
   (test 2.0 (denominator (inexact (/ 6 4))))
 )
 
+(test-group
+  "sqrt"
+  (test 1i (sqrt -1))
+  (test 1i (sqrt -1.0))
+  (test +i (sqrt -1.0))
+  (test 2 (sqrt 4))
+  (test 2.0 (sqrt 4.0))
+  (test 2i (sqrt -4.0))
+  (test #t (complex? (sqrt -1)))
+  (test #t (complex? (sqrt -i)))
+)
+
 (test-group
   "exact"
   (test -1 (exact -1))
@@ -106,8 +129,8 @@
   (test -1 (exact -1.1))
   (test -1 (exact -1.1))
   (test 1.0+1.0i (exact 1.1+1.2i))
-  (test #t (bignum? (exact 111111111111111111111111111.0)))
-  (test #t (bignum? (exact -111111111111111111111111111.0)))
+  ;(test #t (bignum? (exact 111111111111111111111111111.0)))
+  ;(test #t (bignum? (exact -111111111111111111111111111.0)))
   ;(test +inf.0 (exact +inf.0))
 )