From ba001262df4cfe9100357e663aa98cf04c434c9a Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 26 Nov 2019 22:27:27 -0800 Subject: [PATCH] Add define-deferred-procedure to capture a common pattern. --- src/runtime/host-adapter.scm | 22 ++++++++++++++++++++++ src/runtime/runtime.pkg | 1 + src/runtime/sysmac.scm | 20 ++++++++++++++++++++ 3 files changed, 43 insertions(+) diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm index 8aed7d510..c2e61a201 100644 --- 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 adf5ee221..cbad53ec5 100644 --- 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 3c946ade4..299438a2e 100644 --- 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) -- 2.25.1