;;;; Core primitives
(define :begin
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-encapsulate-values
(lambda (deferred-items)
spar-match-null))))
(define :if
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-call-with-values if-item
(spar-elt)
spar-match-null))))
(define :quote
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-call-with-values constant-item
(spar-elt)
spar-match-null))))
(define :quote-identifier
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-call-with-values quoted-id-item
(spar-elt)
spar-match-null))))
\f
(define :set!
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-call-with-values
(lambda (lhs-item rhs-item)
;; the compiler wants this, but it would be nice to eliminate this
;; hack.
(define :or
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-encapsulate-values or-item
(spar-elt)
spar-match-null))))
(define :delay
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-call-with-values delay-item
(spar-elt)
;;;; Definitions
(define keyword:define
- (spar-promise->keyword
+ (spar-classifier->keyword
(delay
(spar-call-with-values defn-item
(spar-elt)
spar-match-null))))
(define :define-syntax
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-call-with-values
(lambda (id senv item)
;;;; Lambdas
(define :lambda
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-call-with-values
(lambda (bvl body senv)
spar-push-body))))
(define :named-lambda
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-call-with-values
(lambda (name bvl body senv)
;;;; LET-like
(define keyword:let
- (spar-promise->keyword
+ (spar-classifier->keyword
(delay
(spar-call-with-values
(lambda (bindings body senv)
spar-push-body)))
(define :let-syntax
- (spar-promise->runtime spar-promise:let-syntax))
+ (spar-classifier->runtime spar-promise:let-syntax))
(define keyword:let-syntax
- (spar-promise->keyword spar-promise:let-syntax))
+ (spar-classifier->keyword spar-promise:let-syntax))
(define :letrec-syntax
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-call-with-values
(lambda (bindings body senv)
(env access-item-env))
(define keyword:access
- (spar-promise->keyword
+ (spar-classifier->keyword
(delay
(spar-call-with-values access-item
(spar-elt)
(compile-expr-item (access-item-env item)))))
(define :the-environment
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-seq
(spar-or (spar-match senv-top-level? spar-arg:senv)
(spar-push-value the-environment-item)))))
(define keyword:unspecific
- (spar-promise->keyword
+ (spar-classifier->keyword
(delay
(spar-seq
(spar-elt)
(spar-push-value unspecific-item)))))
(define keyword:unassigned
- (spar-promise->keyword
+ (spar-classifier->keyword
(delay
(spar-seq
(spar-elt)
;;;; Declarations
(define :declare
- (spar-promise->runtime
+ (spar-classifier->runtime
(delay
(spar-call-with-values
(lambda (senv hist decls)
biselector:cddr
biselector:cdr
biselector:cr
- classifier->keyword
classify-form
error:syntax
hist-cadr
serror
sfor-each
smap
- spar-promise->keyword
subform-select)
(export (runtime syntax low)
reclassify
spar-macro-transformer->expander
syntactic-keyword->item)
(export (runtime syntax)
+ classifier->keyword
classifier->runtime
er-macro-transformer->keyword-item
keyword-item
keyword-item?
rsc-macro-transformer->keyword-item
sc-macro-transformer->keyword-item
+ spar-classifier->keyword
+ spar-classifier->runtime
+ spar-transformer->runtime
spar-macro-transformer->keyword-item
- spar-promise->classifier
- spar-promise->runtime))
+ spar-promise-caller))
(define-package (runtime syntax items)
(files "syntax-items")
spar-transform-values
spar-with-mapped-senv)
(export (runtime syntax)
- spar->classifier
+ spar-call
spar-push-classified
spar-push-deferred-classified
spar-push-open-classified))
expr))
(define (sc-wrapper transformer get-closing-senv)
- (lambda (form use-senv)
- (close-syntax (transformer form use-senv)
- (get-closing-senv))))
+ (wrap-no-hist
+ (lambda (form use-senv)
+ (close-syntax (transformer form use-senv)
+ (get-closing-senv)))))
(define (rsc-macro-transformer->expander transformer env #!optional expr)
(expander-item (rsc-wrapper transformer (runtime-getter env))
expr))
(define (rsc-wrapper transformer get-closing-senv)
- (lambda (form use-senv)
- (close-syntax (transformer form (get-closing-senv))
- use-senv)))
+ (wrap-no-hist
+ (lambda (form use-senv)
+ (close-syntax (transformer form (get-closing-senv))
+ use-senv))))
(define (er-macro-transformer->expander transformer env #!optional expr)
(expander-item (er-wrapper transformer (runtime-getter env))
expr))
(define (er-wrapper transformer get-closing-senv)
- (lambda (form use-senv)
- (close-syntax (transformer form
- (make-er-rename (get-closing-senv))
- (make-er-compare use-senv))
- use-senv)))
+ (wrap-no-hist
+ (lambda (form use-senv)
+ (close-syntax (transformer form
+ (make-er-rename (get-closing-senv))
+ (make-er-compare use-senv))
+ use-senv))))
(define (make-er-rename closing-senv)
(lambda (identifier)
(identifier=? use-senv x use-senv y)))
(define (spar-macro-transformer->expander spar env expr)
- (keyword-item (spar-wrapper spar (runtime-getter env))
- expr))
+ (expander-item (spar-wrapper spar (runtime-getter env))
+ expr))
(define (spar-macro-transformer->keyword-item spar closing-senv expr)
- (keyword-item (spar-wrapper spar (lambda () closing-senv))
+ (expander-item (spar-wrapper spar (lambda () closing-senv))
expr))
(define (spar-wrapper spar get-closing-senv)
(lambda (form senv hist)
- (reclassify (close-syntax ((spar->classifier spar) form senv hist)
- (get-closing-senv))
- senv
- hist)))
+ (close-syntax (spar-call spar form senv hist)
+ (get-closing-senv))))
(define (runtime-getter env)
(lambda ()
(define (keyword-item impl #!optional expr)
(%keyword-item impl expr))
-(define (expander-item impl expr)
- (%keyword-item (lambda (form senv hist)
- (reclassify (with-error-context form senv hist
- (lambda ()
- (impl form senv)))
- senv
- hist))
- expr))
-
(define-record-type <keyword-item>
(%keyword-item impl expr)
keyword-item?
(define (keyword-item-has-expr? item)
(not (default-object? (keyword-item-expr item))))
+(define (expander-item transformer expr)
+ (keyword-item (transformer->classifier transformer)
+ expr))
+
+(define (transformer->classifier transformer)
+ (lambda (form senv hist)
+ (reclassify (transformer form senv hist)
+ senv
+ hist)))
+
+(define (wrap-no-hist transformer)
+ (lambda (form senv hist)
+ (with-error-context form senv hist
+ (lambda ()
+ (transformer form senv)))))
+
(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 (classifier->keyword classifier)
+ (close-syntax 'keyword
+ (make-keyword-senv 'keyword
+ (keyword-item classifier))))
+
+(define (spar-classifier->runtime promise)
+ (classifier->runtime (spar-promise-caller promise)))
+
+(define (spar-transformer->runtime promise)
+ (classifier->runtime (transformer->classifier (spar-promise-caller promise))))
+
+(define (spar-classifier->keyword promise)
+ (classifier->keyword (spar-promise-caller promise)))
-(define (spar-promise->classifier promise)
+(define (spar-promise-caller promise)
(lambda (form senv hist)
- ((spar->classifier (force promise)) form senv hist)))
+ (spar-call (force promise) form senv hist)))
(define (syntactic-keyword->item keyword environment)
(let ((item (environment-lookup-macro environment keyword)))
;;;
;;; (failure)
-(define (spar->classifier spar)
- (lambda (form senv hist)
- (spar (%new-input form hist)
- senv
- (%new-output)
- (lambda (input senv output failure)
- (declare (ignore senv failure))
- (if (not (%input-null? input))
- (error "Rule failed to match entire form."))
- (output 'get-only))
- (lambda ()
- (serror form senv hist "Ill-formed syntax:" form)))))
+(define (spar-call spar form senv hist)
+ (spar (%new-input form hist)
+ senv
+ (%new-output)
+ (lambda (input senv output failure)
+ (declare (ignore senv failure))
+ (if (not (%input-null? input))
+ (error "Rule failed to match entire form."))
+ (output 'get-only))
+ (lambda ()
+ (serror form senv hist "Ill-formed syntax:" form))))
\f
;;;; Inputs and outputs
\f
;;;; Utilities
-(define (classifier->keyword classifier)
- (close-syntax 'keyword
- (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)
projects / mit-scheme.git / commitdiff