write

6 files changed, 299 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..02015c2
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,7 @@
+*.build.sh
+*.o
+*.install.sh
+*.link
+*.static*
+*.import*
+*.so
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..110f855
--- /dev/null
+++ b/README.md
@@ -0,0 +1,12 @@
+# SRFI-259 for CHICKEN
+
+This is an implementation of SRFI-259 for CHICKEN.
+
+Notable features:
+
+* Different than `extend-procedure`, because `extend-procedure` is
+  stateful.
+* Uses an efficient set type (integer maps) to store tags.
+
+This is the first time I've written low-level CHICKEN code: use at your own
+risk.
diff --git a/lowlevel.scm b/lowlevel.scm
new file mode 100644
index 0000000..3f22155
--- /dev/null
+++ b/lowlevel.scm
@@ -0,0 +1,128 @@
+#| Copyright (C) 2025 Peter McGoron
+ |
+ | Permission is hereby granted, free of charge, to any person obtaining a
+ | copy of this software and associated documentation files (the
+ | "Software"), to deal in the Software without restriction, including
+ | without limitation the rights to use, copy, modify, merge, publish,
+ | distribute, sublicense, and/or sell copies of the Software, and to
+ | permit persons to whom the Software is furnished to do so, subject to
+ | the following conditions:
+ |
+ | The above copyright notice and this permission notice (including the
+ | next paragraph) shall be included in all copies or substantial portions
+ | of the Software.
+ |
+ | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+ | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ |#
+
+;;; This is the low-level Chicken code that implements tagged procedures.
+;;; The standard `extend-procedure` cannot be used because it is mutating
+;;; by default, while SRFI-259 is persistent.
+;;; 
+;;; The code works by having a "signifier pair", whose car is a unique
+;;; (in the sense of eqv) symbol and whose cdr is a integer map to the
+;;; tag values.
+
+(define unique-id
+  ;; Generate a fixnum, which will serve as the ID for each tagged
+  ;; procedure constructor.
+  (let ((i 0))
+    (lambda ()
+      (set! i (fx+ i 1))
+      i)))
+
+(define unique-symbol
+  ;; This uninterned symbol is guaranteed to be a unique memory location
+  ;; and is used to pick out the procedure tag mapping from the closure
+  ;; data.
+  (string->uninterned-symbol "srfi-259"))
+
+(define create/signifier-pair
+  ;; Given a procedure that does not have tags associated with it, create
+  ;; a new procedure object, with the same underlying procedure and closed
+  ;; over variables, with `sig` as the signifier pair.
+  (foreign-primitive scheme-object ((scheme-object proc)
+                                    (scheme-object sig))
+                     "
+int old_size = C_header_size(proc);
+C_word closure[C_SIZEOF_CLOSURE(old_size + 1)];
+int i;
+
+closure[0] = C_CLOSURE_TYPE | (old_size + 1);
+for (i = 0; i < old_size; i++)
+    C_block_item(closure, i) = C_block_item(proc, i);
+    // C_mutate_slot(&C_block_item(closure, i), C_block_item(proc, i));
+C_block_item(closure, old_size) = sig;
+
+C_return(closure);"))
+
+(define set-signifier-pair
+  ;; Given a procedure that has tags associated with it, create a new
+  ;; procedure object, with the same underlying procedure and closure,
+  ;; with `sig` as the signifier pair.
+  (foreign-primitive scheme-object ((scheme-object proc)
+                                    (scheme-object unique_symbol)
+                                    (scheme-object sig))
+                     "
+int size = C_header_size(proc);
+C_word item;
+int i;
+C_word closure[C_SIZEOF_CLOSURE(size)];
+closure[0] = C_CLOSURE_TYPE | size;
+
+for (i = 0; i < size; i++) {
+    item = C_block_item(proc, i);
+    if (!C_immediatep(item) && C_pairp(item) && C_eqp(unique_symbol, C_u_i_car(item))) {
+        C_block_item(closure, i) = sig;
+        // C_mutate_slot(&C_block_item(closure, i), sig);
+    } else {
+        C_block_item(closure, i) = item;
+        // C_mutate_slot(&C_block_item(closure, i), C_block_item(proc, i));
+    }
+}
+
+C_return(closure);
+"))
+
+(define (decoration-is-tag? x)
+  ;; Return true if a decoration is a tagged procedure.
+  (and (pair? x)
+       (eq? (car x) unique-symbol)))
+
+(define (get-mapping proc)
+  ;; Return the mapping in a tagged procedure if it exists, or `#f` if it
+  ;; does not exist. This relies on an undocumented internal function,
+  ;; although it could be implemented with documented functions.
+  (cond
+    ((##sys#lambda-decoration proc decoration-is-tag?) => cdr)
+    (else #f)))
+
+(define (make-signifier fxmap)
+  ;; Create a signifier pair that can be inserted into the closure.
+  (cons unique-symbol fxmap))
+
+(define (set-tagged-mapping proc key value)
+  ;; Return a new closure object that is tagged, has all of its previous
+  ;; tags except that `key` maps to `value`.
+  (cond
+    ((not (procedure? proc)) (raise
+                              (make-property-condition '(srfi-259 assertion-violation)
+                                                       'message
+                                                       "not a procedure"
+                                                       'arguments
+                                                       (list proc key value))))
+    ((get-mapping proc)
+     => (lambda (oldmap)
+          (set-signifier-pair proc
+                              unique-symbol
+                              (make-signifier
+                               (fxmapping-set oldmap key value)))))
+    (else (create/signifier-pair proc (make-signifier
+                                       (fxmapping key value))))))
+
diff --git a/srfi-259.egg b/srfi-259.egg
new file mode 100644
index 0000000..6cc1531
--- /dev/null
+++ b/srfi-259.egg
@@ -0,0 +1,11 @@
+((author "Peter McGoron")
+ (version "0.9.0")
+ (synopsis "Tagged procedures with type safety")
+ (category data)
+ (license "MIT")
+ (dependencies r7rs integer-map)
+ (test-dependencies test)
+ (components (extension srfi-259
+               (source "srfi-259.sld")
+               (source-dependencies "lowlevel.scm")
+               (csc-options "-k" "-debug-info" "-R" "r7rs" "-X" "r7rs" "-O3"))))
diff --git a/srfi-259.sld b/srfi-259.sld
new file mode 100644
index 0000000..20a78be
--- /dev/null
+++ b/srfi-259.sld
@@ -0,0 +1,65 @@
+#| Copyright (C) 2025 Peter McGoron
+ |
+ | Permission is hereby granted, free of charge, to any person obtaining a
+ | copy of this software and associated documentation files (the
+ | "Software"), to deal in the Software without restriction, including
+ | without limitation the rights to use, copy, modify, merge, publish,
+ | distribute, sublicense, and/or sell copies of the Software, and to
+ | permit persons to whom the Software is furnished to do so, subject to
+ | the following conditions:
+ |
+ | The above copyright notice and this permission notice (including the
+ | next paragraph) shall be included in all copies or substantial portions
+ | of the Software.
+ |
+ | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+ | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ |#
+
+(define-library (srfi 259)
+  (import (scheme base) (scheme write)
+          integer-map
+          (chicken base)
+          (chicken foreign)
+          (chicken condition)
+          (chicken fixnum))
+  (export define-procedure-tag)
+  (include "lowlevel.scm")
+  (begin
+    (define-syntax define-procedure-tag
+      (syntax-rules ()
+        ((define-procedure-tag constructor predicate? accessor)
+         ;; Hygiene is broken here on CHICKEN, because `id` is not renamed
+         ;; here. It needs to be lexical, not global.
+         (begin
+           (define constructor #f)
+           (define predicate? #f)
+           (define accessor #f)
+           (let ((id (unique-id)))
+             (set! constructor
+                   (lambda (tag proc)
+                     (set-tagged-mapping proc id tag)))
+             (set! predicate?
+                   (lambda (proc)
+                     (cond
+                       ((get-mapping proc) => (cut fxmapping-contains? <> id))
+                       (else #f))))
+             (set! accessor
+                   (lambda (proc)
+                     (let ((map (get-mapping proc))
+                           (raise-error (lambda ()
+                                          (raise
+                                           (make-property-condition
+                                            '(srfi-259 assertion-violation)
+                                            'message
+                                            "procedure does not contain id"
+                                            'arguments
+                                            (list proc id))))))
+                       (if map
+                           (fxmapping-ref map id raise-error)
+                           (raise-error))))))))))))
\ No newline at end of file
diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..8618059
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,76 @@
+#| Copyright (C) 2025 Peter McGoron
+ |
+ | Permission is hereby granted, free of charge, to any person obtaining a
+ | copy of this software and associated documentation files (the
+ | "Software"), to deal in the Software without restriction, including
+ | without limitation the rights to use, copy, modify, merge, publish,
+ | distribute, sublicense, and/or sell copies of the Software, and to
+ | permit persons to whom the Software is furnished to do so, subject to
+ | the following conditions:
+ |
+ | The above copyright notice and this permission notice (including the
+ | next paragraph) shall be included in all copies or substantial portions
+ | of the Software.
+ |
+ | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+ | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+
+ | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ |#
+
+(import r7rs test (srfi 259))
+
+(test-begin "SRFI 259")
+
+(define-procedure-tag tag-foo tag-foo? get-tag-foo)
+(define-procedure-tag tag-baz tag-baz? get-tag-baz)
+
+(test-group "tagging lambdas"
+  (let* ((var 100)
+         (tagged (tag-foo 'bar (lambda (x)
+                                 (set! var (+ var x))
+                                 var))))
+    (test-assert "tag-foo is tag-foo?" (tag-foo? tagged))
+    (test "get-tag-foo returns tagged value" 'bar (get-tag-foo tagged))
+    (test "var is previous value" 100 var)
+    (test "tagged procedure is callable" 110 (tagged 10))
+    (test "var has changed" 110 var)
+    (test-assert "not tag-baz?" (not (tag-baz? tagged)))
+    (test-assert "get-tag-baz raises an exception"
+                 (handle-exceptions exn #t
+                   (get-tag-baz tagged)
+                   #f))
+    (test-group "tagged again"
+      (let ((tagged-again (tag-foo 'quux tagged)))
+        (test-assert "tagging again retains tag-foo?" (tag-foo? tagged-again))
+        (test "tagging again sets new value" 'quux (get-tag-foo tagged-again))
+        (test "tagging again retains old value in previous procedure" 'bar (get-tag-foo tagged))
+        (test-assert "the procedures not eqv?" (not (eqv? tagged tagged-again)))
+        (test "tagging again returns a procedure" 150 (tagged 40))
+        (test "var has changed" 150 var)))
+    (test-group "tagged baz"
+      (let ((tagged-baz (tag-baz 'corge tagged)))
+        (test-assert "tag-baz?" (tag-baz? tagged-baz))
+        (test-assert "tag-baz and tag-foo?" (tag-foo? tagged-baz))
+        (test "retains get-tag-foo" 'bar (get-tag-foo tagged-baz))
+        (test "retains get-tag-baz" 'corge (get-tag-baz tagged-baz))
+        (test-assert "previous procedure is not tag-baz?" (not (tag-baz? tagged)))))))
+
+(test-group "tagging imported procedures"
+  (let* ((tagged (tag-foo 'foo +))
+         (tagged (tag-baz 'baz tagged)))
+    (test-assert "not tag-foo?" (not (tag-foo? +)))
+    (test-assert "not tag-baz?" (not (tag-baz? +)))
+    (test-assert "tag-foo?" (tag-foo? tagged))
+    (test-assert "tag-baz?" (tag-baz? tagged))
+    (test "operationally the same procedure?"
+          (+ 50 50)
+          (tagged 50 50))
+    (test "get-tag-foo" 'foo (get-tag-foo tagged))
+    (test "get-tag-baz" 'baz (get-tag-baz tagged))))
+
+(test-end "SRFI 259")