add lambda/this

6 files changed, 84 insertions, 121 deletions

diff --git a/README.md b/README.md
index 110f855..96a5fd2 100644
--- a/README.md
+++ b/README.md
@@ -10,3 +10,24 @@ Notable features:
 
 This is the first time I've written low-level CHICKEN code: use at your own
 risk.
+
+## Usage
+
+Import `(srfi 259)` for only the standard bindings. Import
+`(srfi 259 extensions)` for the SRFI-259 macro and the extensions
+described below.
+
+## Extensions
+
+This library implements lambdas with object scope.
+
+    (lambda/this this formal body ...)
+
+Create a procedure such that `this` will be bound to the current
+procedure.  When a new procedure is created using a tag constructor,
+`this` will point to the new procedure, not to the old procedure. This
+allows for a procedure to inspect its own tags.
+
+    (procedure/this? obj)
+
+Returns true if `obj` is a procedure created using `lambda/this`.
diff --git a/extensions.sld b/extensions.sld
new file mode 100644
index 0000000..3612398
--- /dev/null
+++ b/extensions.sld
@@ -0,0 +1,33 @@
+#| 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 extensions)
+  (import (scheme base)
+          integer-map
+          (chicken base)
+          (chicken foreign)
+          (chicken condition)
+          (chicken fixnum))
+  (export define-procedure-tag procedure/self? lambda/this define/this)
+  (include "lowlevel.scm")
+  (include "internal.scm"))
\ No newline at end of file
diff --git a/lowlevel.scm b/lowlevel.scm
index 1c338b5..1032534 100644
--- a/lowlevel.scm
+++ b/lowlevel.scm
@@ -109,18 +109,3 @@ C_return(closure);
 (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
-    ((get-mapping proc)
-     => (lambda (oldmap)
-          (set-signifier-pair proc
-                              unique-symbol
-                              (make-signifier
-                               (fxmapping-set oldmap key value)))))
-    ;; get-mapping will test if `proc` is a procedure
-    (else (create/signifier-pair proc (make-signifier
-                                       (fxmapping key value))))))
-
diff --git a/srfi-259.egg b/srfi-259.egg
index f0dae1e..fa7c2b1 100644
--- a/srfi-259.egg
+++ b/srfi-259.egg
@@ -1,5 +1,5 @@
 ((author "Peter McGoron")
- (version "0.9.2")
+ (version "0.10.0")
  (synopsis "Tagged procedures with type safety")
  (category data)
  (license "MIT")
@@ -7,5 +7,9 @@
  (test-dependencies test)
  (components (extension srfi-259
                (source "srfi-259.sld")
-               (source-dependencies "lowlevel.scm")
+               (component-dependencies srfi.259.extensions)
+               (csc-options "-R" "r7rs" "-X" "r7rs" "-O3"))
+             (extension srfi.259.extensions
+               (source "extensions.sld")
+               (source-dependencies "lowlevel.scm" "internal.scm")
                (csc-options "-R" "r7rs" "-X" "r7rs" "-O3"))))
diff --git a/srfi-259.sld b/srfi-259.sld
deleted file mode 100644
index 649f42d..0000000
--- a/srfi-259.sld
+++ /dev/null
@@ -1,92 +0,0 @@
-#| 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 is-type? (condition-predicate 'type))
-    (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
-              ;; constructor
-              (lambda (tag proc)
-                (handle-exceptions E (abort
-                                      (make-composite-condition
-                                       (make-property-condition
-                                        'exn
-                                        'location
-                                        (quote constructor)
-                                        'arguments
-                                        (list proc)
-                                        'message
-                                        "not a procedure")
-                                       E))
-                  (set-tagged-mapping proc id tag)))
-              ;; predicate?
-              (lambda (proc)
-                (cond
-                  ((not (procedure? proc)) #f)
-                  ((get-mapping proc)
-                   => (cut fxmapping-contains? <> id))
-                  (else #f)))
-              ;; accessor
-              (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)))))))))))
\ No newline at end of file
diff --git a/tests/run.scm b/tests/run.scm
index feb1cc1..ce927ff 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -22,7 +22,7 @@
  | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  |#
 
-(import r7rs test (chicken condition) (chicken gc) (srfi 259))
+(import r7rs test (chicken condition) (chicken gc) (srfi 259 extensions))
 
 (test-begin "SRFI 259")
 
@@ -96,17 +96,6 @@
   (test-assert "lists are not tagged" (not (tag-foo? '(1 2 3 4))))
   (raises-type-error "lists are not tagged" (tag-foo 'data '(1 2 3 4))))
 
-(import (chicken pretty-print))
-
-(define (debug-dump obj)
-  (let ((vec (make-vector (##sys#size obj))))
-    (display (##sys#size obj)) (newline)
-    (do ((i 0 (+ i 1)))
-        ((= i (##sys#size obj)) (newline))
-      (vector-set! vec i (##sys#slot obj i)))
-    (pp vec)
-    (newline)))
-
 (test-group "define-procedure-tag is a define form"
   (let ()
     (define (square x) (* x x))
@@ -122,3 +111,26 @@
     (test "square value" (tagged-square 10) (square 10))))
 
 (test-end "SRFI 259")
+
+(test-begin "SRFI 259 extensions")
+
+(define/this (try-this this x)
+  (when (tag-foo? this)
+    (set! x (+ x (get-tag-foo this))))
+  (when (tag-baz? this)
+    (set! x (+ x (get-tag-baz this))))
+  x)
+
+(test "no tag" 10 (try-this 10))
+
+(define new-try-this (tag-foo 10 try-this))
+(test "with tag-foo" 20 (new-try-this 10))
+(test "does not affect the one with no tag" 10 (try-this 10))
+
+(define new-new-try-this (tag-baz 20 new-try-this))
+(test "with tag-baz" 40 (new-new-try-this 10))
+(test "does not affect the one with tag-foo" 20 (new-try-this 10))
+(test "does not affect the one with no tag" 10 (try-this 10))
+
+(test-end "SRFI 259 extensions")
+(test-exit)