(spar-transformer->runtime
(delay
(spar-call-with-values
- (lambda (close identifiers expr . body-forms)
+ (lambda (close bvl expr . body-forms)
(let ((r-cwv (close 'call-with-values))
(r-lambda (close 'lambda)))
`(,r-cwv (,r-lambda () ,expr)
- (,r-lambda (,@identifiers) ,@body-forms))))
- (spar-elt)
- (spar-push spar-arg:close)
- (spar-push-elt-if r4rs-lambda-list? spar-arg:form)
- (spar-push-elt spar-arg:form)
- (spar+ (spar-push-elt spar-arg:form))
- (spar-match-null)))
+ (,r-lambda ,bvl ,@body-forms))))
+ (pattern->spar '(ignore (push close) r4rs-bvl expr (+ form)))))
system-global-environment))
-(define-syntax :define-record-type
- (er-macro-transformer
- (lambda (form rename compare)
- compare ;ignore
- (if (syntax-match? '((or identifier
- (identifier expression))
- (identifier * identifier)
- identifier
- * (identifier identifier ? identifier))
- (cdr form))
- (let ((type-spec (cadr form))
- (constructor (car (caddr form)))
- (c-tags (cdr (caddr form)))
- (predicate (cadddr form))
- (fields (cddddr form))
- (de (rename 'define)))
- (let ((type (if (pair? type-spec) (car type-spec) type-spec)))
- `(,(rename 'begin)
- (,de ,type
- (,(rename 'new-make-record-type)
- ',type
- ',(map car fields)
- ,@(if (pair? type-spec)
- (list (cadr type-spec))
- '())))
- (,de ,constructor (,(rename 'record-constructor) ,type ',c-tags))
- (,de ,predicate (,(rename 'record-predicate) ,type))
- ,@(append-map
- (lambda (field)
- (let ((name (car field)))
- (cons `(,de ,(cadr field)
- (,(rename 'record-accessor) ,type ',name))
- (if (pair? (cddr field))
- `((,de ,(caddr field)
- (,(rename 'record-modifier)
- ,type ',name)))
- '()))))
- fields))))
- (ill-formed-syntax form)))))
-
+(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)
+ '()))))
+ '())
+ ,@(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))))))))))
+ system-global-environment))
+\f
(define-syntax :define
(er-macro-transformer
(lambda (form rename compare)
(,scode-lambda-name:let ,@ids)
,@body-forms)
,@vals))))
- (spar-elt)
- (spar-push spar-arg:close)
- (spar-or (spar-push-elt-if identifier? spar-arg:form)
- (spar-push '#f))
- (spar-elt
- (spar-call-with-values list
- (spar* (spar-elt
- (spar-call-with-values cons
- (spar-push-elt-if identifier? spar-arg:form)
- (spar-or (spar-push-elt spar-arg:form)
- (spar-push-value unassigned-expression)))
- (spar-match-null)))
- (spar-match-null)))
- (spar+ (spar-push-elt spar-arg:form))
- (spar-match-null)))
+ (pattern->spar
+ `(ignore (push close)
+ (or id (push #f))
+ (elt
+ (list
+ (*
+ (elt
+ (cons id
+ (or expr
+ (push-value ,unassigned-expression)))))))
+ (+ form)))))
system-global-environment))
(define named-let-strategy 'internal-definition)
elts))))
(spar+ (spar-elt spar-push-open-classified))
(spar-match-null))
- (spar-push spar-arg:senv)))
\ No newline at end of file
+ (spar-push spar-arg:senv)))
+\f
+;;;; Shorthand
+
+(define (make-pattern-compiler expr? caller)
+ (call-with-constructors expr?
+ (lambda (:* :+ :call :close :cons :elt :eqv? :form :hist :identifier? :list
+ :match-elt :match-null :mit-bvl? :opt :or :push :push-elt
+ :push-elt-if :push-value :r4rs-bvl? :senv :seq :symbol? :value)
+
+ (define (loop pattern)
+ (cond ((symbol? pattern)
+ (case pattern
+ ((symbol) (:push-elt-if (:symbol?) (:form)))
+ ((identifier id) (:push-elt-if (:identifier?) (:form)))
+ ((form expr) (:push-elt (:form)))
+ ((r4rs-bvl) (:push-elt-if (:r4rs-bvl?) (:form)))
+ ((mit-bvl) (:push-elt-if (:mit-bvl?) (:form)))
+ ((ignore) (:elt))
+ (else (bad-pattern pattern))))
+ ((procedure? pattern)
+ (:push-elt-if pattern (:form)))
+ ((and (pair? pattern)
+ (list? (cdr pattern)))
+ (case (car pattern)
+ ((*) (apply :* (map loop (cdr pattern))))
+ ((+) (apply :+ (map loop (cdr pattern))))
+ ((?) (apply :opt (map loop (cdr pattern))))
+ ((or) (apply :or (map loop (cdr pattern))))
+ ((seq) (apply :seq (map loop (cdr pattern))))
+ ((quote)
+ (if (not (and (pair? (cdr pattern))
+ (null? (cddr pattern))))
+ (bad-pattern pattern))
+ (:match-elt (:eqv?) (cadr pattern) (:form)))
+ ((push) (apply :push (map convert-spar-arg (cdr pattern))))
+ ((push-value)
+ (apply :push-value
+ (cadr pattern)
+ (map convert-spar-arg (cddr pattern))))
+ ((list) (apply :call (:list) (map loop (cdr pattern))))
+ ((cons) (apply :call (:cons) (map loop (cdr pattern))))
+ ((call) (apply :call (cadr pattern) (map loop (cddr pattern))))
+ ((spar) (apply :seq (cdr pattern)))
+ ((elt)
+ (:elt (apply :seq (map loop (cdr pattern)))
+ (:match-null)))
+ (else
+ (bad-pattern pattern))))
+ (else
+ (bad-pattern pattern))))
+
+ (define (convert-spar-arg arg)
+ (case arg
+ ((form) (:form))
+ ((hist) (:hist))
+ ((close) (:close))
+ ((senv) (:senv))
+ ((value) (:value))
+ (else arg)))
+
+ (define (bad-pattern pattern)
+ (error:wrong-type-argument pattern "syntax-parser pattern" caller))
+
+ (lambda (pattern)
+ (if (not (list? pattern))
+ (bad-pattern pattern))
+ (:seq (apply :seq (map loop pattern))
+ (:match-null))))))
+\f
+(define (call-with-constructors expr? procedure)
+
+ (define (proc name procedure)
+ (if expr?
+ (lambda args (cons name args))
+ (lambda args (apply procedure args))))
+
+ (define (flat-proc name procedure)
+ (if expr?
+ (lambda args (cons name (elide-seqs args)))
+ (lambda args (apply procedure args))))
+
+ (define (elide-seqs exprs)
+ (append-map (lambda (expr)
+ (if (and (pair? expr)
+ (eq? 'spar-seq (car expr)))
+ (cdr expr)
+ (list expr)))
+ exprs))
+
+ (define (const name value)
+ (if expr?
+ (lambda () name)
+ (lambda () value)))
+
+ (procedure (flat-proc 'spar* spar*)
+ (flat-proc 'spar+ spar+)
+ (flat-proc 'spar-call-with-values spar-call-with-values)
+ (const 'spar-arg:close spar-arg:close)
+ (const 'cons cons)
+ (flat-proc 'spar-elt spar-elt)
+ (const 'eqv? eqv?)
+ (const 'spar-arg:form spar-arg:form)
+ (const 'spar-arg:hist spar-arg:hist)
+ (const 'identifier? identifier?)
+ (const 'list list)
+ (proc 'spar-match-elt spar-match-elt)
+ (proc 'spar-match-null spar-match-null)
+ (const 'mit-lambda-list? mit-lambda-list?)
+ (flat-proc 'spar-opt spar-opt)
+ (proc 'spar-or spar-or)
+ (proc 'spar-push spar-push)
+ (proc 'spar-push-elt spar-push-elt)
+ (proc 'spar-push-elt-if spar-push-elt-if)
+ (proc 'spar-push-value spar-push-value)
+ (const 'r4rs-lambda-list? r4rs-lambda-list?)
+ (const 'spar-arg:senv spar-arg:senv)
+ (flat-proc 'spar-seq spar-seq)
+ (const 'symbol? symbol?)
+ (const 'spar-arg:value spar-arg:value)))
+
+(define-deferred pattern->spar
+ (make-pattern-compiler #f 'pattern->spar))
+
+(define-deferred pattern->spar-expr
+ (make-pattern-compiler #t 'pattern->spar-expr))
\ No newline at end of file
projects / mit-scheme.git / commitdiff