write

1 files changed, 65 insertions, 0 deletions

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