;;; implementation by Kent Dybvig, and includes some ideas from
;;; another implementation by Jonathan Rees.
+;;; Implementation comments:
+
+;;; Parsing of syntax-rules clauses is complex due to the interaction of quoting
+;;; mechanisms, overriding of ellipses, and identifier comparison. This is
+;;; mitigated here by a rewriting phase that transforms them into an
+;;; easily-walked form that consists of nested lists keyed by symbols. The form
+;;; memoizes identifiers so that they can be compared using eq?.
+
+;;; The rewritten forms are then checked for various syntactic restrictions that
+;;; are different for patterns and templates. Patterns are checked for excess
+;;; ellipses, but not templates where it is allowed. Ellipsis depth is computed
+;;; for the pattern variables, and then checked in the template to make sure
+;;; that references have the correct depth and nesting relationships.
+
+;;; One special exception is dotted-list patterns, where the RHS of the dotted
+;;; list is an identifier. In that case no ellipses are allowed in the LHS of
+;;; the pattern, because otherwise matching would require backtracking and there
+;;; would be more than one possible match.
+
+;;; The generated code is then simple, deferring most of the work to the
+;;; procedures syntax-rules:match-datum and syntax-rules:expand-template. These
+;;; names must be bound in the global environment since that's the only means we
+;;; have for efficiently referencing them in the generated code.
+
(declare (usual-integrations))
\f
(define-syntax syntax-rules
(er-macro-transformer
(lambda (form rename compare)
-
- (define (process ellipsis keywords clauses)
- (if (any-duplicates? keywords eq?)
- (syntax-error "Keywords list contains duplicates:" keywords))
- (let ((ellipsis
- (if (memq ellipsis keywords)
- #f
- ellipsis))
+ (let-values
+ (((ellipsis literals clauses)
+ (cond ((syntax-match? '((* identifier)
+ * ((identifier . datum) datum))
+ (cdr form))
+ (values (rename '...) (cadr form) (cddr form)))
+ ((syntax-match? '(identifier
+ (* identifier)
+ * ((identifier . datum) datum))
+ (cdr form))
+ (values (cadr form) (caddr form) (cdddr form)))
+ (else
+ (ill-formed-syntax form)))))
+ (let ((underscore (rename '_))
(r-form (new-identifier 'form))
(r-rename (new-identifier 'rename))
(r-compare (new-identifier 'compare)))
`(,(rename 'er-macro-transformer)
(,(rename 'lambda)
(,r-form ,r-rename ,r-compare)
- (,(rename 'declare) (ignorable ,r-rename ,r-compare))
- ,(let loop ((clauses clauses))
+ (,(rename 'declare) (ignore ,r-compare))
+ ,@(if (null? clauses)
+ `((,(rename 'declare) (ignore ,r-rename)))
+ '())
+ ,(let loop
+ ((clauses
+ (parse-clauses ellipsis literals clauses underscore
+ compare)))
(if (pair? clauses)
- (let ((pattern (caar clauses)))
- (let ((sids
- (parse-pattern rename compare ellipsis keywords
- pattern r-form)))
- `(,(rename 'if)
- ,(generate-match rename compare ellipsis keywords
- r-rename r-compare
- pattern r-form)
- ,(generate-output rename compare ellipsis
- r-rename sids (cadar clauses))
- ,(loop (cdr clauses)))))
- `(,(rename 'ill-formed-syntax) ,r-form)))))))
-
- (cond ((syntax-match? '((* identifier)
- * ((identifier . datum) expression))
- (cdr form))
- (process '... (cadr form) (cddr form)))
- ((syntax-match? '(identifier
- (* identifier)
- * ((identifier . datum) expression))
- (cdr form))
- (process (cadr form) (caddr form) (cdddr form)))
- (else
- (ill-formed-syntax form))))))
+ (let ((pattern (caar clauses))
+ (template (cadar clauses))
+ (r-dict (new-identifier 'dict)))
+ `(let ((,r-dict
+ (,(rename 'syntax-rules:match-datum)
+ ,(syntax-quote pattern)
+ (cdr ,r-form))))
+ (if ,r-dict
+ (,(rename 'syntax-rules:expand-template)
+ ,(syntax-quote template)
+ ,r-dict
+ ,r-rename)
+ ,(loop (cdr clauses)))))
+ `(,(rename 'ill-formed-syntax) ,r-form))))))))))
+
+(define (parse-clauses ellipsis literals clauses underscore compare)
+ (if (any-duplicates? literals compare)
+ (syntax-error "Literals list contains duplicates:" literals))
+ (let ((rewrite (make-rewriter ellipsis literals underscore compare)))
+ (map (lambda (clause)
+ (parse-clause rewrite (car clause) (cadr clause)))
+ clauses)))
+
+(define (parse-clause rewrite pattern template)
+ (if (not (and (pair? pattern) (identifier? (car pattern))))
+ (syntax-error "Pattern must start with identifier:" pattern))
+ (let ((p (rewrite (cdr pattern)))
+ (t (rewrite template)))
+ (let ((pvs (compute-segments p))
+ (tvs (compute-segments t)))
+ (check-for-multiple-segments p pattern)
+ (if (any-duplicates? pvs eq? car)
+ (syntax-error "Duplicate vars in pattern:" pattern))
+ (for-each (lambda (group)
+ (check-template-var-references (cdr group)
+ (length (car group))
+ pvs))
+ (group-by-segment tvs)))
+ (list p t)))
\f
-(define (parse-pattern rename compare ellipsis keywords pattern expression)
- (let loop
- ((pattern pattern)
- (expression expression)
- (sids '())
- (control #f)
- (ellipsis ellipsis))
- (cond ((identifier? pattern)
- (if (and ellipsis (compare pattern (rename ellipsis)))
- (syntax-error "Misplaced ellipsis:" pattern))
- (if (memq pattern keywords)
- sids
- (cons (make-sid pattern expression control) sids)))
- ((ellipsis-quote? rename compare ellipsis pattern)
- (loop (cadr pattern) expression sids control #f))
- ((zero-or-more? rename compare ellipsis pattern)
- (if (not (null? (cddr pattern)))
- (syntax-error "Misplaced ellipsis:" pattern))
- (let ((variable (new-identifier 'control)))
- (loop (car pattern)
- variable
- sids
- (make-sid variable expression control)
- ellipsis)))
- ((pair? pattern)
- (loop (car pattern)
- `(,(rename 'car) ,expression)
- (loop (cdr pattern)
- `(,(rename 'cdr) ,expression)
- sids
- control
- ellipsis)
- control
- ellipsis))
- (else sids))))
-
-(define-record-type <sid>
- (make-sid name expression control)
- sid?
- (name sid-name)
- (expression sid-expression)
- (control sid-control))
+(define (make-rewriter ellipsis literals underscore compare)
+
+ (define (rewriter ellipsis literals)
+
+ (define (rewrite x)
+ (cond ((pair? x)
+ (if (and (ellipsis-id? (car x))
+ (pair? (cdr x))
+ (null? (cddr x)))
+ ((rewriter #f (cons ellipsis literals))
+ (cadr x))
+ (let-values (((x y) (scan-elts x '())))
+ (if (null? x)
+ (cons 'list (reverse y))
+ (cons 'dotted-list (reverse (cons (rewrite x) y)))))))
+ ((vector? x)
+ (let-values (((x y) (scan-elts (vector->list x) '())))
+ (declare (ignore x))
+ (cons 'vector (reverse y))))
+ ((identifier? x)
+ (cond ((member x literals compare)
+ (list 'literal (strip-syntactic-closures x)))
+ ((compare underscore x)
+ (list 'anon-var))
+ (else
+ (if (ellipsis? x)
+ (syntax-error "Misplaced ellipsis"))
+ (list 'var (memoize x)))))
+ ((null? x)
+ (list 'list))
+ (else
+ (if (not (or (string? x) (char? x) (boolean? x) (number? x)
+ (lambda-tag? x)))
+ (syntax-error "Ill-formed pattern:" x))
+ (list 'literal x))))
+
+ (define (scan-elts x y)
+ (if (pair? x)
+ (let loop ((t (cdr x)) (w (rewrite (car x))))
+ (if (and (pair? t)
+ (ellipsis-id? (car t)))
+ (loop (cdr t) (list '* w))
+ (scan-elts t (cons w y))))
+ (values x y)))
+
+ (define (ellipsis? id)
+ (and ellipsis (compare id ellipsis)))
+
+ (define (ellipsis-id? object)
+ (and (identifier? object)
+ (ellipsis? object)))
+
+ rewrite)
+
+ (define memoize
+ (let ((ids '()))
+ (lambda (id)
+ (let ((p (member id ids compare)))
+ (if p
+ (car p)
+ (begin
+ (set! ids (cons id ids))
+ id))))))
+
+ (rewriter (if (member ellipsis literals compare) #f ellipsis)
+ literals))
\f
-(define (generate-match rename compare ellipsis keywords r-rename r-compare
- pattern expression)
- (letrec
- ((loop
- (lambda (pattern expression ellipsis)
- (cond ((identifier? pattern)
- (if (memq pattern keywords)
- (let-ify rename expression
- (lambda (expr)
- `(,(rename 'and)
- (,(rename 'identifier?) ,expr)
- (,r-compare ,expr
- (,r-rename ,(syntax-quote pattern))))))
- `#t))
- ((ellipsis-quote? rename compare ellipsis pattern)
- (loop (cadr pattern) expression #f))
- ((zero-or-more? rename compare ellipsis pattern)
- ;; (cddr pattern) guaranteed null by parser above.
- (do-list (car pattern) expression ellipsis))
- ((pair? pattern)
- (let-ify rename expression
- (lambda (expr)
- `(,(rename 'and)
- (,(rename 'pair?) ,expr)
- ,(loop (car pattern)
- `(,(rename 'car) ,expr)
- ellipsis)
- ,(loop (cdr pattern)
- `(,(rename 'cdr) ,expr)
- ellipsis)))))
- ((null? pattern)
- `(,(rename 'null?) ,expression))
- (else
- `(,(rename 'equal?) ,expression
- (,(rename 'quote) ,pattern))))))
- (do-list
- (lambda (pattern expression ellipsis)
- (let ((r-loop (new-identifier 'loop))
- (r-l (new-identifier 'l)))
- `((,(rename 'let)
- ()
- (,(rename 'define)
- (,r-loop ,r-l)
- (,(rename 'if)
- (,(rename 'null?) ,r-l)
- #t
- (,(rename 'and)
- (,(rename 'pair?) ,r-l)
- ,(loop pattern `(,(rename 'car) ,r-l) ellipsis)
- (,r-loop (,(rename 'cdr) ,r-l)))))
- ,r-loop)
- ,expression)))))
- (loop pattern expression ellipsis)))
-
-(define (let-ify rename expression generate-body)
- (if (identifier? expression)
- (generate-body expression)
- (let ((temp (new-identifier 'temp)))
- `(,(rename 'let) ((,temp ,expression)) ,(generate-body temp)))))
+(define (compute-segments y)
+ (reverse
+ (let loop ((y y) (segs '()) (vars '()))
+ (case (car y)
+ ((list dotted-list vector)
+ (fold (lambda (elt vars)
+ (loop (strip-segments elt)
+ (append (make-list (count-segments elt) '*) segs)
+ vars))
+ vars
+ (cdr y)))
+ ((var) (cons (cons (cadr y) segs) vars))
+ ((literal anon-var) vars)
+ (else (error "Unknown element marker:" y))))))
+
+(define (check-for-multiple-segments p pattern)
+ (let loop ((p p))
+ (case (car p)
+ ((list dotted-list vector)
+ (if (and (eq? 'dotted-list (car p))
+ (special-dot-tail? p))
+ (if (any segment? (cdr p))
+ (syntax-error "No ellipses allowed in pattern:" pattern))
+ (begin
+ (if (fix:> (count segment? (cdr p)) 1)
+ (syntax-error "Only one ellipsis allowed in pattern:" pattern))
+ (if (any (lambda (elt) (fix:> (count-segments elt) 1)) (cdr p))
+ (syntax-error "No nested ellipses allowed in pattern:"
+ pattern))))
+ (for-each (lambda (elt)
+ (loop (strip-segments elt)))
+ (cdr p)))
+ ((var literal anon-var) unspecific)
+ (else (error "Unknown element marker:" p)))))
+
+(define (group-by-segment vars)
+ (let loop ((vars vars) (groups '()))
+ (if (pair? vars)
+ (loop (cdr vars)
+ (let ((name (caar vars))
+ (segment (cdar vars)))
+ (let ((group (assq segment groups)))
+ (if group
+ (begin
+ (set-cdr! group (cons name (cdr group)))
+ groups)
+ (cons (list segment name) groups)))))
+ groups)))
+
+(define (check-template-var-references names depth pvs)
+ (let ((pvs*
+ (filter (lambda (pv)
+ (memq (car pv) names))
+ pvs)))
+ ;; All vars in segment must have correct depth.
+ (let ((pvs**
+ (remove (lambda (pv)
+ (fix:= (length (cdr pv)) depth))
+ pvs*)))
+ (if (pair? pvs**)
+ (syntax-error "Mismatched segment depth in template:"
+ (map car pvs**))))
+ ;; All vars in segment must be in the same pattern segment.
+ (if (pair? pvs*)
+ (let ((seg (cdar pvs*)))
+ (let ((pvs**
+ (remove (lambda (pv) (eq? (cdr pv) seg))
+ pvs*)))
+ (if (pair? pvs**)
+ (syntax-error "Mixed segments in template:"
+ (map car pvs**))))))))
\f
-(define (generate-output rename compare ellipsis r-rename sids template)
- (let loop ((template template) (ellipses '()) (ellipsis* ellipsis))
- (cond ((identifier? template)
- (let ((sid
- (find (lambda (sid)
- (eq? (sid-name sid) template))
- sids)))
- (if sid
- (begin
- (add-control! sid ellipses)
- (sid-expression sid))
- `(,r-rename ,(syntax-quote template)))))
- ((ellipsis-quote? rename compare ellipsis* template)
- (loop (cadr template) ellipses #f))
- ((zero-or-more? rename compare ellipsis* template)
- (optimized-append rename compare
- (let ((ellipsis (make-ellipsis '())))
- (generate-ellipsis rename
- ellipsis
- (loop (car template)
- (cons ellipsis ellipses)
- ellipsis*)))
- (loop (cddr template) ellipses ellipsis*)))
- ((pair? template)
- (optimized-cons rename compare
- (loop (car template) ellipses ellipsis*)
- (loop (cdr template) ellipses ellipsis*)))
- (else
- `(,(rename 'quote) ,template)))))
-
-(define (add-control! sid ellipses)
- (let ((control (sid-control sid)))
- (if control
- (begin
- (if (not (pair? ellipses))
- (syntax-error "Missing ellipsis in expansion."))
- (let ((sids (ellipsis-sids (car ellipses))))
- (if (memq control sids)
- (if (not (eq? control (car sids)))
- (error "illegal control/ellipsis combination:"
- control sids))
- (set-ellipsis-sids! (car ellipses) (cons control sids))))
- (add-control! control (cdr ellipses))))))
-
-(define (generate-ellipsis rename ellipsis body)
- ;; Generation of body will have filled in the sids:
- (let ((sids (ellipsis-sids ellipsis)))
- (if (not (pair? sids))
- (syntax-error "Missing ellipsis in expansion."))
- ;; Optimize trivial case:
- (if (and (eq? body (sid-name (car sids)))
- (null? (cdr sids)))
- (sid-expression (car sids))
- `(,(rename 'map) (,(rename 'lambda) ,(map sid-name sids) ,body)
- ,@(map sid-expression sids)))))
-
-(define-record-type <ellipsis>
- (make-ellipsis sids)
- ellipsis?
- (sids ellipsis-sids set-ellipsis-sids!))
+(define (syntax-rules:match-datum pattern datum)
+
+ (define (match-datum pat datum dict k)
+
+ (define (k-list pats data dict)
+ (and (null? pats)
+ (null? data)
+ (k dict)))
+
+ (let ((x (cdr pat)))
+ (case (car pat)
+ ((list)
+ (and (list? datum)
+ (match-segment x datum dict (length x) (length datum) k-list)))
+ ((vector)
+ (and (vector? datum)
+ (match-segment x (vector->list datum) dict (length x)
+ (vector-length datum) k-list)))
+ ((dotted-list)
+ (match-segment x datum dict (fix:- (length x) 1) (count-pairs datum)
+ (lambda (pats datum dict)
+ (match-datum (car pats) datum dict k))))
+ ((literal)
+ (and (equal? (car x) datum)
+ (k dict)))
+ ((var) (k (dict-add (car x) datum dict)))
+ ((anon-var) (k dict))
+ (else (error "Unknown element marker:" pat)))))
+
+ (define (match-segment pats data dict n m k)
+ (let ((i (list-index segment? pats)))
+ (if (and i (fix:<= i m))
+ (fixed pats data dict i
+ (lambda (pats data dict)
+ (let ((n (fix:- (fix:- n i) 1))
+ (m (fix:- m i))
+ (pat (segment-body (car pats))))
+ (let loop ((data data) (m m) (dicts '()))
+ (if (fix:< n m)
+ (match-datum pat (car data) '()
+ (lambda (dict)
+ (loop (cdr data) (fix:- m 1) (cons dict dicts))))
+ (fixed (cdr pats) data (wrap-dicts dicts dict)
+ n k))))))
+ (and (fix:<= n m)
+ (fixed pats data dict n k)))))
+
+ (define (fixed pats data dict n k)
+ (if (fix:> n 0)
+ (match-datum (car pats) (car data) dict
+ (lambda (dict)
+ (fixed (cdr pats) (cdr data) dict (fix:- n 1) k)))
+ (k pats data dict)))
+
+ (match-datum pattern datum (new-dict) (lambda (dict) dict)))
\f
-(define (optimized-append rename compare x y)
- (cond ((constant-null? rename compare x) y)
- ((constant-null? rename compare y) x)
- (else `(,(rename 'append) ,x ,y))))
-
-(define (optimized-cons rename compare a d)
- (cond ((and (constant? rename compare a)
- (constant? rename compare d))
- `(,(rename 'quote)
- ,(cons (constant->datum rename compare a)
- (constant->datum rename compare d))))
- ((constant-null? rename compare d)
- `(,(rename 'list) ,a))
- ((and (pair? d)
- (compare (car d) (rename 'list))
- (list? (cdr d)))
- `(,(rename 'list) ,a ,@(cdr d)))
- (else
- `(,(rename 'cons) ,a ,d))))
-
-(define (ellipsis-quote? rename compare ellipsis pattern)
- (and ellipsis
- (pair? pattern)
- (identifier? (car pattern))
- (compare (car pattern) (rename ellipsis))
- (pair? (cdr pattern))
- (null? (cddr pattern))))
-
-(define (zero-or-more? rename compare ellipsis pattern)
- (and ellipsis
- (pair? pattern)
- (pair? (cdr pattern))
- (identifier? (cadr pattern))
- (compare (cadr pattern) (rename ellipsis))))
+(define (syntax-rules:expand-template template dict rename)
+
+ (define (loop t dict)
+
+ (define (per-elt elt)
+ (let expand-segment ((elt elt) (dict dict))
+ (if (segment? elt)
+ (append-map (lambda (dict)
+ (expand-segment (segment-body elt) dict))
+ (unwrap-dict dict (segment-vars elt)))
+ (list (loop elt dict)))))
+
+ (case (car t)
+ ((list) (append-map per-elt (cdr t)))
+ ((vector) (list->vector (append-map per-elt (cdr t))))
+ ((dotted-list)
+ (let ((n (fix:- (length (cdr t)) 1)))
+ (let scan ((i 0) (elts (cdr t)))
+ (if (fix:< i n)
+ (append (per-elt (car elts)) (scan (fix:+ i 1) (cdr elts)))
+ (loop (car elts) dict)))))
+ ((var)
+ (let ((datum (dict-lookup (cadr t) dict)))
+ (if (eq? datum no-datum)
+ (rename (cadr t))
+ datum)))
+ ((literal) (cadr t))
+ ((anon-var) (rename '_))
+ (else (error "Unknown element marker:" t))))
+
+ (add-segment-vars! template)
+ (loop template dict))
+(define (add-segment-vars! t)
+ (let loop ((t t) (ids '()))
+ (case (car t)
+ ((list dotted-list vector)
+ (fold (lambda (elt ids)
+ (if (segment? elt)
+ (let ((ids* (loop (strip-segments (segment-body elt)) '())))
+ (do ((elt elt (segment-body elt)))
+ ((not (segment? elt)))
+ (set-cdr! (cdr elt) (list ids*)))
+ (lset-union eq? ids* ids))
+ (loop elt ids)))
+ ids
+ (cdr t)))
+ ((var) (lset-adjoin eq? ids (cadr t)))
+ ((literal anon-var) ids)
+ (else (error "Unknown element marker:" t)))))
+\f
+(define-integrable (segment? elt) (eq? '* (car elt)))
+(define-integrable (segment-body elt) (cadr elt))
+(define-integrable (segment-vars elt) (caddr elt))
+
+(define (strip-segments elt)
+ (if (segment? elt)
+ (strip-segments (segment-body elt))
+ elt))
+
+(define (count-segments elt)
+ (let loop ((elt elt) (n 0))
+ (if (segment? elt)
+ (loop (segment-body elt) (fix:+ n 1))
+ n)))
+
+(define (special-dot-tail? p)
+ (let ((tail-pat (last p)))
+ (or (eq? 'var (car tail-pat))
+ (eq? 'anon-var (car tail-pat)))))
+
+;; Like quote but doesn't strip syntactic closures:
(define (syntax-quote expression)
`(,(classifier->keyword
(lambda (form senv hist)
(constant-item (serror-ctx form senv hist) (cadr form))))
,expression))
-(define (constant-null? rename compare expr)
- (and (quoted? rename compare expr)
- (eqv? '() (quoted-datum expr))))
-
-(define (constant? rename compare expr)
- (or (quoted? rename compare expr)
- (boolean? expr)
- (bytevector? expr)
- (char? expr)
- (number? expr)
- (string? expr)
- (vector? expr)))
-
-(define (constant->datum rename compare expr)
- (if (quoted? rename compare expr)
- (quoted-datum expr)
- expr))
-
-(define (quoted-datum expr)
- (cadr expr))
-
-(define (quoted? rename compare expr)
- (and (pair? expr)
- (compare (car expr) (rename 'quote))
- (pair? (cdr expr))
- (null? (cddr expr))))
\ No newline at end of file
+(define-integrable (new-dict) (make-dict '()))
+(define-integrable (make-dict bindings) bindings)
+(define-integrable (dict-add id datum dict) (cons (make-binding id datum) dict))
+(define-integrable (dict-bindings dict) dict)
+(define-integrable (make-binding id datum) (list id datum))
+(define-integrable (binding-id binding) (car binding))
+(define-integrable (binding-datum binding) (cadr binding))
+(define no-datum (list 'no-datum))
+
+(define (dict-lookup id dict)
+ (let ((binding (assq id (dict-bindings dict))))
+ (if binding
+ (binding-datum binding)
+ no-datum)))
+
+(define (wrap-dicts dicts tail)
+ (if (pair? dicts)
+ (let join ((dicts dicts))
+ (if (pair? (car dicts))
+ (cons (let ((per-id (map car dicts)))
+ (make-binding (binding-id (car per-id))
+ (reverse (map binding-datum per-id))))
+ (join (map cdr dicts)))
+ tail))
+ tail))
+
+(define (unwrap-dict dict ids)
+ (let loop
+ ((items
+ (map (lambda (binding)
+ (map (lambda (datum)
+ (make-binding (binding-id binding) datum))
+ (binding-datum binding)))
+ (filter (lambda (binding)
+ (memq (binding-id binding) ids))
+ (dict-bindings dict)))))
+ (if (and (pair? items) (pair? (car items)))
+ (cons (make-dict (map car items))
+ (loop (map cdr items)))
+ '())))
\ No newline at end of file
projects / mit-scheme.git / commitdiff