add new files to git

2 files changed, 163 insertions, 0 deletions

diff --git a/internal.scm b/internal.scm
new file mode 100644
index 0000000..8db7999
--- /dev/null
+++ b/internal.scm
@@ -0,0 +1,137 @@
+#| 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 is-type? (condition-predicate 'type))
+
+(define (create-predicate id)
+  (lambda (proc)
+    (cond
+      ((not (procedure? proc)) #f)
+      ((get-mapping proc)
+       => (cut fxmapping-contains? <> id))
+      (else #f))))
+
+(define (create-accessor id)
+  (lambda (proc)
+    (define map
+      (handle-exceptions E (abort
+                            (make-composite-condition
+                             (make-property-condition
+                              'exn
+                              'location
+                              (quote accessor)
+                              'arguments
+                              (list proc)
+                              'message
+                              "not a procedure")
+                             E))
+        (get-mapping proc)))
+    (define (raise-error)
+      (abort
+       (make-composite-condition
+        (make-property-condition 'exn
+                                 'location
+                                 (quote accessor)
+                                 'arguments
+                                 (list proc)
+                                 'message
+                                 "tag was not found")
+        (make-property-condition 'assertion))))
+    (if map
+        (fxmapping-ref map id raise-error)
+        (raise-error))))
+
+;;; ;;;;;;;;;;;;;;;
+;;; Bootstrapping
+;;; ;;;;;;;;;;;;;;;
+
+(define get-base-procedure (create-accessor 0))
+(define tagged-procedure? (create-predicate 0))
+
+(define procedure/self-tag -1)
+(define procedure/self? (create-predicate procedure/self-tag))
+
+(define (create-constructor id)
+  (lambda (tag proc)
+    (cond
+      ((not (procedure? proc))
+       (abort (make-composite-condition
+               (make-property-condition
+                'exn
+                'location
+                (quote constructor)
+                'arguments
+                (list proc)
+                'message
+                "not a procedure")
+               (make-property-condition
+                'type
+                'value
+                proc))))
+      ((procedure/self? proc)
+       (letrec* ((base (get-base-procedure proc))
+                 (nproc
+                  (create/signifier-pair (lambda args
+                                           (apply base nproc args))
+                                         (make-signifier
+                                          (fxmapping-set (get-mapping proc)
+                                                         id
+                                                         tag)))))
+         nproc))
+      ((tagged-procedure? proc)
+       (let ((map (get-mapping proc)))
+         (set-signifier-pair proc
+                             unique-symbol
+                             (make-signifier
+                              (fxmapping-set map id tag)))))
+      (else (create/signifier-pair proc
+                                   (make-signifier
+                                    (fxmapping id tag
+                                               0 proc)))))))
+
+(define tag/this (create-constructor -1))
+
+(define-syntax define-procedure-tag
+  (syntax-rules ()
+    ((define-procedure-tag constructor predicate? accessor)
+     ;; This uses `define-values` instead of a define for `id` because
+     ;; Chicken breaks hygiene for top-level `define` names.
+     (define-values (constructor predicate? accessor)
+       (let ((id (unique-id)))
+         (values
+          (create-constructor id)
+          (create-predicate id)
+          (create-accessor id)))))))
+
+(define-syntax lambda/this
+  (syntax-rules ()
+    ((lambda/this this formal body ...)
+     ;; Quick hack to make the constructor work. Should fix.
+     (tag/this #f
+               (tag/this #f
+                         (lambda (this . formal) body ...))))))
+
+(define-syntax define/this
+  (syntax-rules ()
+    ((define/this (name this . args) body ...)
+     (define name (lambda/this this args body ...)))))
diff --git a/srfi-259.sld b/srfi-259.sld
new file mode 100644
index 0000000..f302ebb
--- /dev/null
+++ b/srfi-259.sld
@@ -0,0 +1,26 @@
+#| 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) (srfi 259 extensions))
+  (export define-procedure-tag))
\ No newline at end of file