diff --git a/test-immut.scm b/test-immut.scm new file mode 100644 index 00000000..bbcbaa45 --- /dev/null +++ b/test-immut.scm @@ -0,0 +1,40 @@ +;; A temporary test file +(import (scheme base) (scheme write)) + + + (define-c immutable? + "(void *data, int argc, closure _, object k, object obj)" + "object result = boolean_f; + if (is_object_type(obj) && + (type_of(obj) == pair_tag || + type_of(obj) == vector_tag || + type_of(obj) == bytevector_tag || + type_of(obj) == string_tag + ) && + immutable(obj) ) { + result = boolean_t; + } + return_closcall1(data, k, result); ") + +(define-c _Cyc-set-immutable! + "(void *data, int argc, closure _, object k, object obj, object val)" + "object result = boolean_f; + if (is_object_type(obj)) { + immutable(obj) = (val == boolean_f) ? 0 : 1; + result = boolean_t; + } + return_closcall1(data, k, result); ") + +(define lis '(1 2 3)) + +(write + (list + (immutable? lis) + (immutable? (car lis)) + (_Cyc-set-immutable! lis #f) + (immutable? lis) + (immutable? (car lis)) + (set-car! lis 'a) + lis + ) +)