Merge branch 'master' into bignum-experimental-dev

CHANGELOG.md

@@ -2,6 +2,10 @@
 
 ## 0.35.0 - TBD
 
+Features
+
+- Add `memory-streams` to the list of symbols that `(features)` can return, indicating that the current installation supports in-memory streams.
+
 Bug Fixes
 
 - Enforce a maximum recursion depth when printing an object via `display` and `write`, and when comparing objects via `equal?`. This prevents segmentation faults when working with circular data structures.

circ-test.scm

@@ -1,39 +0,0 @@
-;; TODO: Temporary test file
-(import (scheme base) (scheme write))
-(define v1 (vector #f))
-(define v2 (vector v1))
-(vector-set! v1 0 v2)
-(display v1)
-(display (equal? v1 v2))
-(newline)
-
-(define v1 (vector 1 2 3))
-(define v2 (vector 1 v1 3))
-(vector-set! v1 1 v2)
-(display v1)
-;(display (equal? v1 v2))
-(newline)
-
-(define l1 (list #f))
-(define l2 (list l1))
-(set-cdr! l1 l2)
-(display l1)
-(display (equal? l1 l2))
-(newline)
-
-(define l1 (list 1 2 3))
-(define l2 (list 1 l1 3))
-(set-cdr! (cdr l1) l2)
-(write l1)
-(display (equal? l1 l2))
-(newline)
-
-; TODO: need to compare pointers to prevent this sort of thing:
-;
-; cyclone> (display #(1 1 1 1 1 1 1 1))
-; #(... ... ... ... ... ... ... ...)
-;
-; for equalp of pairs we track progress using cdr, cddr
-; proves that if pointers are equal we are traversing the same list
-;
-; how to handle vector traversal?

include/cyclone/runtime.h

@@ -375,6 +375,7 @@ object Cyc_io_peek_u8(void *data, object cont, object port);
 object Cyc_write_bytevector(void *data, object bvec, object port, object start, object end);
 object Cyc_io_read_line(void *data, object cont, object port);
 void Cyc_io_read_token(void *data, object cont, object port);
+int Cyc_have_mstreams();
 /**@}*/
 
 

mstreams.c

@@ -32,6 +32,15 @@ if (obj_is_not_closure(clo)) { \
  } \
 }
 
+int Cyc_have_mstreams()
+{
+#if CYC_HAVE_FMEMOPEN && CYC_HAVE_OPEN_MEMSTREAM
+  return 1;
+#else
+  return 0;
+#endif
+}
+
 object Cyc_heap_alloc_port(void *data, port_type *p);
 port_type *Cyc_io_open_input_string(void *data, object str)
 {

runtime.c

@@ -2962,6 +2962,13 @@ object Cyc_compilation_environment(void *data, object cont, object var)
       snprintf(buf, sizeof(buf), "%s", CYC_PLATFORM);
       make_utf8_string(data, str, buf);
       _return_closcall1(data, cont, &str);
+    } else if (strncmp(((symbol) var)->desc, "memory-streams", 9) == 0) {
+      char buf[] = "memory-streams";
+      if (!Cyc_have_mstreams()) {
+        buf[0] = '\0';
+      }
+      make_utf8_string(data, str, buf);
+      _return_closcall1(data, cont, &str);
     }
   }
   Cyc_rt_raise2(data, 

scheme/base.sld

@@ -235,14 +235,17 @@
   (begin
     ;; Features implemented by this Scheme
     (define (features) 
-      (cons 
-        'cyclone
-        (cons
-          (string->symbol 
-            (string-append "version-" *version-number*))
+      (let ((feats *other-features*))
+        (if (> (string-length (Cyc-compilation-environment 'memory-streams)) 0)
+          (set! feats (cons 'memory-streams feats)))
+        (cons 
+          'cyclone
           (cons
-            (string->symbol (Cyc-compilation-environment 'platform))
-            *other-features*))))
+            (string->symbol 
+              (string-append "version-" *version-number*))
+            (cons
+              (string->symbol (Cyc-compilation-environment 'platform))
+              feats)))))
 
     (define *other-features* 
             '(r7rs 

tests/unit-tests.scm

@@ -35,6 +35,49 @@
 (set-cdr! l '(c b)) ; Above seems to break if it replaces this line
 (assert:equal "list? on circular list" (list? l) #t)
 
+;; Circular data structures
+(define v1 (vector #f))
+(define v2 (vector v1))
+(vector-set! v1 0 v2)
+(cond-expand
+  (memory-streams
+   (let ((fp (open-output-string)))
+     (display v1 fp)
+     (assert:equal "display circular vector" (> (string-length (get-output-string fp)) 0) #t))))
+(assert:equal "equality on circular vectors" (equal? v1 v2) #t)
+(newline)
+
+(define v1 (vector 1 2 3))
+(define v2 (vector 1 v1 3))
+(vector-set! v1 1 v2)
+(cond-expand
+ (memory-streams
+  (let ((fp (open-output-string)))
+    (write v1 fp)
+    (assert:equal "display circular vector" (> (string-length (get-output-string fp)) 0) #t))))
+(assert:equal "equality on circular vectors, test 2" (equal? v1 v2) #t)
+(newline)
+
+(define l1 (list #f))
+(define l2 (list l1))
+(set-cdr! l1 l2)
+(cond-expand
+  (memory-streams
+   (let ((fp (open-output-string)))
+     (display l1 fp)
+     (assert:equal "display circular list" (> (string-length (get-output-string fp)) 0) #t))))
+(assert:equal "equality on circular lists" (equal? l1 l2) #f)
+
+(define l1 (list 1 2 3))
+(define l2 (list 1 l1 3))
+(set-cdr! (cdr l1) l2)
+(cond-expand
+  (memory-streams
+   (let ((fp (open-output-string)))
+     (write l1 fp)
+     (assert:equal "display circular list" (> (string-length (get-output-string fp)) 0) #t))))
+(assert:equal "equality on circular lists, test 2" (equal? l1 l2) #f)
+
 ;; Adder example
 (define (make-adder x)
   (lambda (y) (+ x  y)))