From: Chris Hanson Date: Tue, 20 Feb 2018 07:01:29 +0000 (-0800) Subject: Another round of changes to the spar API. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~234 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=55c1d00c51e10cda66d02602870f4a071e795766;p=mit-scheme.git Another round of changes to the spar API. --- diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 73c429ac0..5740a39d0 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -532,6 +532,7 @@ USA. (runtime syntax items) (runtime syntax rename) (runtime syntax top-level) + (runtime syntax parser) ;; REP Loops (RUNTIME INTERRUPT-HANDLER) (RUNTIME GC-STATISTICS) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index edfa5e368..a447c98ae 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4440,6 +4440,7 @@ USA. serror sfor-each smap + spar-promise->keyword subform-select) (export (runtime syntax low) reclassify @@ -4464,7 +4465,9 @@ USA. keyword-item? rsc-macro-transformer->keyword-item sc-macro-transformer->keyword-item - spar-macro-transformer->keyword-item)) + spar-macro-transformer->keyword-item + spar-promise->classifier + spar-promise->runtime)) (define-package (runtime syntax items) (files "syntax-items") @@ -4550,21 +4553,26 @@ USA. spar-elt spar-fail spar-filter-map-values + spar-push-id-elt + spar-push-id-elt= spar-map-values - spar-match-elt - spar-match-elt-full spar-opt + spar-push-body spar-push-closed-elt spar-push-closed-form + spar-push-datum spar-push-elt spar-push-form + spar-push-hist spar-push-mapped-form spar-push-mapped-full + spar-push-senv spar-push-thunk-value - spar-push-value + spar-push-values spar-repeat spar-require-form spar-require-full + spar-require-null spar-require-senv spar-require-value spar-seq @@ -4573,8 +4581,12 @@ USA. spar-with-mapped-senv) (export (runtime syntax) spar->classifier - spar-classify-elt - spar-push-classified)) + spar-push-classified-elt + spar-push-classified-form + spar-push-deferred-classified-elt + spar-push-deferred-classified-form + spar-push-open-classified-elt + spar-push-open-classified-form)) (define-package (runtime syntax rename) (files "syntax-rename") diff --git a/src/runtime/syntax-low.scm b/src/runtime/syntax-low.scm index c05c9d809..764d0ad8a 100644 --- a/src/runtime/syntax-low.scm +++ b/src/runtime/syntax-low.scm @@ -128,6 +128,14 @@ USA. (define (classifier->runtime classifier) (make-unmapped-macro-reference-trap (keyword-item classifier))) +(define (spar-promise->runtime promise) + (make-unmapped-macro-reference-trap + (keyword-item (spar-promise->classifier promise)))) + +(define (spar-promise->classifier promise) + (lambda (form senv hist) + ((spar->classifier (force promise)) form senv hist))) + (define (syntactic-keyword->item keyword environment) (let ((item (environment-lookup-macro environment keyword))) (if (not item) diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm index 6ce08fdd6..0d3e9f201 100644 --- a/src/runtime/syntax-parser.scm +++ b/src/runtime/syntax-parser.scm @@ -179,18 +179,28 @@ USA. (%output-push output (%input-form input)) failure)) -(define (spar-push-value object) +(define (spar-push-hist input senv output success failure) + (success (%null-input) + senv + (%output-push output (%input-hist input)) + failure)) + +(define (spar-push-senv input senv output success failure) + (success input + senv + (%output-push output senv) + failure)) + +(define (spar-push-datum object) (lambda (input senv output success failure) - (declare (ignore input)) - (success (%null-input) + (success input senv (%output-push output object) failure))) (define (spar-push-thunk-value procedure) (lambda (input senv output success failure) - (declare (ignore input)) - (success (%null-input) + (success input senv (%output-push output (procedure)) failure))) @@ -209,7 +219,7 @@ USA. (%output-push output (procedure (%input-form input) senv)) failure))) -(define (spar-push-classified procedure) +(define (%push-classified procedure) (lambda (input senv output success failure) (success (%null-input) senv @@ -348,52 +358,85 @@ USA. (define spar-discard-elt (spar-elt spar-discard-form)) +(define spar-require-null + (spar-require-form null?)) + (define spar-push-elt (spar-elt spar-push-form)) +;;;; Environment combinators + +(define (spar-with-mapped-senv procedure . spars) + (let ((spar (%seq spars))) + (lambda (input senv output success failure) + (spar input + (procedure senv) + output + (lambda (input* senv* output* failure*) + (declare (ignore senv*)) + (success input* senv output* failure*)) + failure)))) + (define spar-push-closed-form (spar-push-mapped-full (lambda (form senv) (make-syntactic-closure senv '() form)))) +(define spar-push-closed-elt + (spar-elt spar-push-closed-form)) + (define spar-push-partially-closed-form (spar-push-mapped-full (lambda (form senv) (lambda (free) (make-syntactic-closure senv free form))))) -(define spar-push-closed-elt - (spar-elt spar-push-closed-form)) - (define spar-push-partially-closed-elt (spar-elt spar-push-partially-closed-form)) -(define (spar-classify-elt procedure) - (spar-elt (spar-push-classified procedure))) +(define-deferred spar-push-classified-form + (%push-classified classify-form)) -(define (spar-match-elt predicate) - (spar-elt (spar-require-form predicate) - spar-push-form)) +(define-deferred spar-push-classified-elt + (spar-elt spar-push-classified-form)) -(define (spar-match-elt-full predicate) - (spar-elt (spar-require-full predicate) - spar-push-form)) +(define spar-push-deferred-classified-form + (%push-classified + (lambda (form senv hist) + (lambda () + (classify-form form senv hist))))) -;;;; Environment combinators +(define spar-push-deferred-classified-elt + (spar-elt spar-push-deferred-classified-form)) -(define (spar-with-mapped-senv procedure . spars) - (let ((spar (%seq spars))) - (lambda (input senv output success failure) - (spar input - (procedure senv) - output - (lambda (input* senv* output* failure*) - (declare (ignore senv*)) - (success input* senv output* failure*)) - failure)))) +(define spar-push-open-classified-form + (%push-classified + (lambda (form senv hist) + (declare (ignore senv)) + (lambda (senv*) + (classify-form form senv* hist))))) + +(define spar-push-open-classified-elt + (spar-elt spar-push-open-classified-form)) + +(define-deferred spar-push-id-elt + (spar-elt (spar-require-form identifier?) + spar-push-form)) + +(define (spar-push-id-elt= id) + (spar-elt (spar-require-full + (lambda (form senv) + (and (identifier? form) + (identifier=? senv form senv id)))) + spar-push-form)) ;;;; Value combinators +(define (spar-push-values . spars) + (%with-output (lambda (output output*) + (%output-push output (%output-all output*))) + spars)) + (define (spar-encapsulate-values procedure . spars) (%encapsulate procedure spars)) @@ -433,4 +476,14 @@ USA. senv* (procedure output output*) failure*)) - failure)))) \ No newline at end of file + failure)))) + +(define spar-push-body + (spar-encapsulate-values + (lambda (elts) + (lambda (frame-senv) + (let ((body-senv (make-internal-senv frame-senv))) + (map-in-order (lambda (elt) (elt body-senv)) + elts)))) + (spar+ spar-push-open-classified-elt) + spar-require-null)) \ No newline at end of file diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index 2ec9317ce..94352cfaf 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -347,6 +347,9 @@ USA. (make-keyword-senv 'keyword (keyword-item classifier)))) +(define (spar-promise->keyword promise) + (classifier->keyword (spar-promise->classifier promise))) + (define (capture-syntactic-environment expander) `(,(classifier->keyword (lambda (form senv hist)