write

1 files changed, 128 insertions, 0 deletions

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))))))
+