From a9bf1f05b41d2ffbd4b6f30569c1fafae7fdb213 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 21 Mar 2018 17:14:53 -0700 Subject: [PATCH] Implement spar-top-level to cut down on boilerplate. --- src/runtime/mit-macros.scm | 141 ++++++++++++++++------------------ src/runtime/runtime.pkg | 1 + src/runtime/syntax-parser.scm | 34 ++++---- 3 files changed, 89 insertions(+), 87 deletions(-) diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index ceb4b26b5..97a6f450b 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -147,64 +147,61 @@ USA. (define :receive (spar-transformer->runtime (delay - (spar-call-with-values - (lambda (close bvl expr . body-forms) - (let ((r-cwv (close 'call-with-values)) - (r-lambda (close 'lambda))) - `(,r-cwv (,r-lambda () ,expr) - (,r-lambda ,bvl ,@body-forms)))) - (pattern->spar '(ignore (push close) r4rs-bvl expr (+ form))))) + (spar-top-level '(r4rs-bvl expr (list (+ form))) + (lambda (close bvl expr body-forms) + (let ((r-cwv (close 'call-with-values)) + (r-lambda (close 'lambda))) + `(,r-cwv (,r-lambda () ,expr) + (,r-lambda ,bvl ,@body-forms)))))) system-global-environment)) (define :define-record-type (spar-transformer->runtime (delay - (spar-call-with-values - (lambda (close type-name parent maker-name maker-args pred-name - field-specs) - (let ((beg (close 'begin)) - (de (close 'define)) - (mrt (close 'new-make-record-type)) - (rc (close 'record-constructor)) - (rp (close 'record-predicate)) - (ra (close 'record-accessor)) - (rm (close 'record-modifier))) - `(,beg - (,de ,type-name - (,mrt ',type-name - ',(map car field-specs) - ,@(if parent - (list parent) - '()))) - ,@(if maker-name - `((,de ,maker-name - (,rc ,type-name - ,@(if maker-args - (list `',maker-args) + (spar-top-level + '((or (seq id (push #f)) + (elt id expr)) + (or (seq '#f (push #f #f)) + (seq id (push #f)) + (elt id (list (* symbol)))) + (or (seq '#f (push #f)) + id) + (list (* (list (elt symbol id (or id (push #f))))))) + (lambda (close type-name parent maker-name maker-args pred-name + field-specs) + (let ((beg (close 'begin)) + (de (close 'define)) + (mrt (close 'new-make-record-type)) + (rc (close 'record-constructor)) + (rp (close 'record-predicate)) + (ra (close 'record-accessor)) + (rm (close 'record-modifier))) + `(,beg + (,de ,type-name + (,mrt ',type-name + ',(map car field-specs) + ,@(if parent + (list parent) + '()))) + ,@(if maker-name + `((,de ,maker-name + (,rc ,type-name + ,@(if maker-args + (list `',maker-args) + '())))) + '()) + ,@(if pred-name + `((,de ,pred-name (,rp ,type-name))) + '()) + ,@(append-map (lambda (field) + (let ((field-name (car field))) + `((,de ,(cadr field) + (,ra ,type-name ',field-name)) + ,@(if (caddr field) + `((,de ,(caddr field) + (,rm ,type-name ',field-name))) '())))) - '()) - ,@(if pred-name - `((,de ,pred-name (,rp ,type-name))) - '()) - ,@(append-map (lambda (field) - (let ((field-name (car field))) - `((,de ,(cadr field) - (,ra ,type-name ',field-name)) - ,@(if (caddr field) - `((,de ,(caddr field) - (,rm ,type-name ',field-name))) - '())))) - field-specs)))) - (pattern->spar - '(ignore (push close) - (or (seq id (push #f)) - (elt id expr)) - (or (seq '#f (push #f #f)) - (seq id (push #f)) - (elt id (list (* symbol)))) - (or (seq '#f (push #f)) - id) - (list (* (list (elt symbol id (or id (push #f)))))))))) + field-specs)))))) system-global-environment)) (define-syntax :define @@ -233,27 +230,25 @@ USA. (define :let (spar-transformer->runtime (delay - (spar-call-with-values - (lambda (close name bindings . body-forms) - (let ((ids (map car bindings)) - (vals (map cdr bindings))) - (if name - (generate-named-let close name ids vals body-forms) - `((,(close 'named-lambda) - (,scode-lambda-name:let ,@ids) - ,@body-forms) - ,@vals)))) - (pattern->spar - `(ignore (push close) - (or id (push #f)) - (elt - (list - (* - (elt - (cons id - (or expr - (push-value ,unassigned-expression))))))) - (+ form))))) + (spar-top-level + `((or id (push #f)) + (elt + (list + (* + (elt + (cons id + (or expr + (push-value ,unassigned-expression))))))) + (list (+ form))) + (lambda (close name bindings body-forms) + (let ((ids (map car bindings)) + (vals (map cdr bindings))) + (if name + (generate-named-let close name ids vals body-forms) + `((,(close 'named-lambda) + (,scode-lambda-name:let ,@ids) + ,@body-forms) + ,@vals)))))) system-global-environment)) (define named-let-strategy 'internal-definition) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 2856084f9..10881b824 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4580,6 +4580,7 @@ USA. spar-repeat spar-seq spar-succeed + spar-top-level spar-transform-values spar-with-mapped-senv) (export (runtime syntax) diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm index d0c0b0370..d3bdca6fa 100644 --- a/src/runtime/syntax-parser.scm +++ b/src/runtime/syntax-parser.scm @@ -348,7 +348,7 @@ USA. (define (spar-match-null) (spar-match null? spar-arg:form)) -;;;; Environment combinators +;;;; Classifier support (define (spar-with-mapped-senv procedure . spars) (let ((spar (%seq spars))) @@ -360,7 +360,7 @@ USA. (declare (ignore senv*)) (success input* senv output* failure*)) failure)))) - + (define-deferred spar-push-classified (spar-push-value classify-form spar-arg:form @@ -383,6 +383,18 @@ USA. spar-arg:form spar-arg:senv spar-arg:hist)) + +(define-deferred spar-push-body + (spar-seq + (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-elt spar-push-open-classified)) + (spar-match-null)) + (spar-push spar-arg:senv))) ;;;; Value combinators @@ -426,21 +438,15 @@ USA. (procedure output output*) failure*)) failure)))) - -(define-deferred spar-push-body - (spar-seq - (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-elt spar-push-open-classified)) - (spar-match-null)) - (spar-push spar-arg:senv))) ;;;; Shorthand +(define (spar-top-level pattern procedure) + (spar-call-with-values procedure + (spar-elt) + (spar-push spar-arg:close) + (pattern->spar pattern))) + (define (make-pattern-compiler expr? caller) (call-with-constructors expr? (lambda (:* :+ :call :close :cons :elt :eqv? :form :hist :identifier? :list -- 2.25.1