Add define-deferred-procedure to capture a common pattern.

diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm
index 8aed7d510730d26034a5048ee052b54de345ba09..c2e61a20178038bd909f6932282b16cc93ca861c 100644 (file)
--- a/src/runtime/host-adapter.scm
+++ b/src/runtime/host-adapter.scm
@@ -50,6 +50,28 @@ USA.
                        'cref/object-root
                        #!default))
 
+(let ((env (->environment '(runtime))))
+  (if (not (environment-bound? env 'define-deferred-procedure))
+      (eval '(define-syntax define-deferred-procedure
+              (er-macro-transformer
+               (lambda (form rename compare)
+                 (declare (ignore compare))
+                 (syntax-check '(_ identifier expression expression) form)
+                 (let ((name (cadr form))
+                       (dependency (caddr form))
+                       (expr (cadddr form))
+                       (args (new-identifier 'args)))
+                   `(,(rename 'begin)
+                     (,(rename 'define) ,name
+                      (,(rename 'lambda) ,args
+                       (,(rename 'defer-boot-action) ,dependency
+                        (,(rename 'lambda) ()
+                         (,(rename 'apply) ,name ,args)))))
+                     (,(rename 'defer-boot-action) ,dependency
+                      (,(rename 'lambda) ()
+                       (,(rename 'set!) ,name ,expr)
+                       ,(rename 'unspecific))))))))
+           env)))
 
 (let ((env (->environment '(scode-optimizer expansion))))
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index adf5ee221c22ec54fab14da48263a8765f7ef63c..cbad53ec5239bfd8a2dbcec3cc4b8c693e015fc2 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5042,6 +5042,7 @@ USA.
          define-guarantee)
   (export (runtime)
          define-deferred
+         define-deferred-procedure
          define-primitives
          select-on-bytes-per-word
          ucode-primitive

diff --git a/src/runtime/sysmac.scm b/src/runtime/sysmac.scm
index 3c946ade4c0be2a011686d1de91e5daebd2989af..299438a2ee58c901c5ece5054779aefdc08d89e9 100644 (file)
--- a/src/runtime/sysmac.scm
+++ b/src/runtime/sysmac.scm
@@ -107,6 +107,26 @@ USA.
             (,(rename 'set!) ,name ,value)
             ,(rename 'unspecific))))))))
 
+(define-syntax define-deferred-procedure
+  (er-macro-transformer
+   (lambda (form rename compare)
+     (declare (ignore compare))
+     (syntax-check '(_ identifier expression expression) form)
+     (let ((name (cadr form))
+          (dependency (caddr form))
+          (expr (cadddr form))
+          (args (new-identifier 'args)))
+       `(,(rename 'begin)
+        (,(rename 'define) ,name
+         (,(rename 'lambda) ,args
+          (,(rename 'defer-boot-action) ,dependency
+           (,(rename 'lambda) ()
+            (,(rename 'apply) ,name ,args)))))
+        (,(rename 'defer-boot-action) ,dependency
+         (,(rename 'lambda) ()
+          (,(rename 'set!) ,name ,expr)
+          ,(rename 'unspecific))))))))
+
 (define-syntax select-on-bytes-per-word
   (er-macro-transformer
    (lambda (form rename compare)