diff --git a/CHANGELOG.md b/CHANGELOG.md index 9732f62d..e4c621b9 100644 --- a/CHANGELOG.md +++ b/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. diff --git a/circ-test.scm b/circ-test.scm deleted file mode 100644 index 0201c36b..00000000 --- a/circ-test.scm +++ /dev/null @@ -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? diff --git a/include/cyclone/runtime.h b/include/cyclone/runtime.h index b1c0bfc3..3a32a332 100644 --- a/include/cyclone/runtime.h +++ b/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(); /**@}*/ diff --git a/mstreams.c b/mstreams.c index 16b5d7d1..af5b5838 100644 --- a/mstreams.c +++ b/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) { diff --git a/runtime.c b/runtime.c index 380d2df6..f9270894 100644 --- a/runtime.c +++ b/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, diff --git a/scheme/base.sld b/scheme/base.sld index c078c1b9..b4ec756b 100644 --- a/scheme/base.sld +++ b/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 diff --git a/tests/unit-tests.scm b/tests/unit-tests.scm index 79ba4051..c535dc63 100644 --- a/tests/unit-tests.scm +++ b/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)))