(and (pair? keywords)
(or (memq (car keywords) (cdr keywords))
(loop (cdr keywords)))))
- (syntax-error "Keywords list contains duplicates:" keywords)
- (let ((r-form (rename 'form))
- (r-rename (rename 'rename))
- (r-compare (rename 'compare)))
- `(,(rename 'er-macro-transformer)
- (,(rename 'lambda)
- (,r-form ,r-rename ,r-compare)
- (,(rename 'declare) (ignorable ,r-rename ,r-compare))
- ,(let loop ((clauses clauses))
- (if (pair? clauses)
- (let ((pattern (caar clauses)))
- (let ((sids
- (parse-pattern rename compare keywords
- pattern r-form)))
- `(,(rename 'if)
- ,(generate-match rename compare keywords
- r-rename r-compare
- pattern r-form)
- ,(generate-output rename compare r-rename
- sids (cadar clauses))
- ,(loop (cdr clauses)))))
- `(,(rename 'begin)
- (,(rename 'ill-formed-syntax) ,r-form))))))))))))
+ (syntax-error "Keywords list contains duplicates:" keywords))
+ (let ((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))
+ (if (pair? clauses)
+ (let ((pattern (caar clauses)))
+ (let ((sids
+ (parse-pattern rename compare keywords
+ pattern r-form)))
+ `(,(rename 'if)
+ ,(generate-match rename compare keywords
+ r-rename r-compare
+ pattern r-form)
+ ,(generate-output rename compare r-rename
+ sids (cadar clauses))
+ ,(loop (cdr clauses)))))
+ `(,(rename 'begin)
+ (,(rename 'ill-formed-syntax)
+ (,(rename 'quote) ,r-form))))))))))))
(define (parse-pattern rename compare keywords pattern expression)
(let loop
(if (memq pattern keywords)
sids
(cons (make-sid pattern expression control) sids)))
- ((and (or (zero-or-more? pattern rename compare)
- (at-least-one? pattern rename compare))
- (null? (cddr pattern)))
- (let ((variable ((make-local-identifier-renamer) 'control)))
+ ((zero-or-more? rename compare pattern)
+ (if (not (null? (cddr pattern)))
+ (syntax-error "Misplaced ellipsis:" pattern))
+ (let ((variable (new-identifier 'control)))
(loop (car pattern)
variable
sids
control)
control))
(else sids))))
+
+(define-record-type <sid>
+ (make-sid name expression control)
+ sid?
+ (name sid-name)
+ (expression sid-expression)
+ (control sid-control))
\f
(define (generate-match rename compare keywords r-rename r-compare
pattern expression)
(lambda (pattern expression)
(cond ((identifier? pattern)
(if (memq pattern keywords)
- (let ((temp (rename 'temp)))
- `((,(rename 'lambda)
- (,temp)
- (,(rename 'if)
- (,(rename 'identifier?) ,temp)
- (,r-compare ,temp
- (,r-rename ,(syntax-quote pattern)))
- #f))
- ,expression))
+ (let-ify rename expression
+ (lambda (expr)
+ `(,(rename 'and)
+ (,(rename 'identifier?) ,expr)
+ (,r-compare ,expr
+ (,r-rename ,(syntax-quote pattern))))))
`#t))
- ((and (zero-or-more? pattern rename compare)
- (null? (cddr pattern)))
+ ((zero-or-more? rename compare pattern)
+ ;; (cddr pattern) guaranteed null by parser above.
(do-list (car pattern) expression))
- ((and (at-least-one? pattern rename compare)
- (null? (cddr pattern)))
- `(,(rename 'if) (,(rename 'null?) ,expression)
- #f
- ,(do-list (car pattern) expression)))
((pair? pattern)
- (let ((generate-pair
- (lambda (expression)
- (conjunction
- `(,(rename 'pair?) ,expression)
- (conjunction
- (loop (car pattern)
- `(,(rename 'car) ,expression))
- (loop (cdr pattern)
- `(,(rename 'cdr) ,expression)))))))
- (if (identifier? expression)
- (generate-pair expression)
- (let ((temp (rename 'temp)))
- `((,(rename 'lambda) (,temp) ,(generate-pair temp))
- ,expression)))))
+ (let-ify rename expression
+ (lambda (expr)
+ `(,(rename 'and)
+ (,(rename 'pair?) ,expr)
+ ,(loop (car pattern)
+ `(,(rename 'car) ,expr))
+ ,(loop (cdr pattern)
+ `(,(rename 'cdr) ,expr))))))
((null? pattern)
`(,(rename 'null?) ,expression))
(else
(,(rename 'quote) ,pattern))))))
(do-list
(lambda (pattern expression)
- (let ((r-loop (rename 'loop))
- (r-l (rename 'l))
- (r-lambda (rename 'lambda)))
- `(((,r-lambda
- ()
- (,(rename 'define)
- ,r-loop
- (,r-lambda
- (,r-l)
- (,(rename 'if)
- (,(rename 'null?) ,r-l)
- #t
- ,(conjunction
- `(,(rename 'pair?) ,r-l)
- (conjunction (loop pattern `(,(rename 'car) ,r-l))
- `(,r-loop (,(rename 'cdr) ,r-l)))))))
- ,r-loop))
- ,expression))))
- (conjunction
- (lambda (predicate consequent)
- (cond ((eq? predicate #t) consequent)
- ((eq? consequent #t) predicate)
- (else `(,(rename 'if) ,predicate ,consequent #f))))))
+ (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))
+ (,r-loop (,(rename 'cdr) ,r-l)))))
+ ,r-loop)
+ ,expression)))))
(loop pattern expression)))
+
+(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)))))
\f
(define (generate-output rename compare r-rename sids template)
(let loop ((template template) (ellipses '()))
(cond ((identifier? template)
(let ((sid
- (let loop ((sids sids))
- (and (pair? sids)
- (if (eq? (sid-name (car sids)) template)
- (car sids)
- (loop (cdr sids)))))))
+ (find (lambda (sid)
+ (eq? (sid-name sid) template))
+ sids)))
(if sid
(begin
(add-control! sid ellipses)
(sid-expression sid))
+ ;; Template is a keyword:
`(,r-rename ,(syntax-quote template)))))
- ((or (zero-or-more? template rename compare)
- (at-least-one? template rename compare))
+ ((zero-or-more? rename compare template)
(optimized-append rename compare
(let ((ellipsis (make-ellipsis '())))
(generate-ellipsis rename
`(,(rename 'quote) ,template)))))
(define (add-control! sid ellipses)
- (let loop ((sid sid) (ellipses ellipses))
- (let ((control (sid-control sid)))
- (cond (control
- (if (pair? ellipses)
- (let ((sids (ellipsis-sids (car ellipses))))
- (cond ((not (memq control sids))
- (set-ellipsis-sids! (car ellipses)
- (cons control sids)))
- ((not (eq? control (car sids)))
- (error "illegal control/ellipsis combination"
- control sids))))
- (syntax-error "Missing ellipsis in expansion." #f))
- (loop control (cdr 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 (pair? sids)
- (let ((name (sid-name (car sids)))
- (expression (sid-expression (car sids))))
- (cond ((and (null? (cdr sids))
- (eq? body name))
- expression)
- ((and (null? (cdr sids))
- (pair? body)
- (pair? (cdr body))
- (eq? (cadr body) name)
- (null? (cddr body)))
- `(,(rename 'map) ,(car body) ,expression))
- (else
- `(,(rename 'map) (,(rename 'lambda) ,(map sid-name sids)
- ,body)
- ,@(map sid-expression sids)))))
- (syntax-error "Missing ellipsis in expansion." #f))))
+ (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!))
\f
-(define (zero-or-more? pattern rename compare)
+(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 (zero-or-more? rename compare pattern)
(and (pair? pattern)
(pair? (cdr pattern))
(identifier? (cadr pattern))
(compare (cadr pattern) (rename '...))))
-(define (at-least-one? pattern rename compare)
-;;; (and (pair? pattern)
-;;; (pair? (cdr pattern))
-;;; (identifier? (cadr pattern))
-;;; (compare (cadr pattern) (rename '+)))
- pattern rename compare ;ignore
- #f)
-
(define (syntax-quote expression)
`(,(classifier->keyword
(lambda (form senv hist)
(constant-item (serror-ctx form senv hist) (cadr form))))
,expression))
-(define (optimized-cons rename compare a d)
- (cond ((and (pair? d)
- (compare (car d) (rename 'quote))
- (pair? (cdr d))
- (null? (cadr d))
- (null? (cddr d)))
- `(,(rename 'list) ,a))
- ((and (pair? d)
- (compare (car d) (rename 'list))
- (list? (cdr d)))
- `(,(car d) ,a ,@(cdr d)))
- (else
- `(,(rename 'cons) ,a ,d))))
+(define (constant-null? rename compare expr)
+ (and (quoted? rename compare expr)
+ (eqv? '() (quoted-datum expr))))
-(define (optimized-append rename compare x y)
- (if (and (pair? y)
- (compare (car y) (rename 'quote))
- (pair? (cdr y))
- (null? (cadr y))
- (null? (cddr y)))
- x
- `(,(rename 'append) ,x ,y)))
+(define (constant? rename compare expr)
+ (or (quoted? rename compare expr)
+ (boolean? expr)
+ (bytevector? expr)
+ (char? expr)
+ (number? expr)
+ (string? expr)
+ (vector? expr)))
-(define-record-type <sid>
- (make-sid name expression control)
- sid?
- (name sid-name)
- (expression sid-expression)
- (control sid-control)
- (output-expression sid-output-expression set-sid-output-expression!))
+(define (constant->datum rename compare expr)
+ (if (quoted? rename compare expr)
+ (quoted-datum expr)
+ expr))
-(define-record-type <ellipsis>
- (make-ellipsis sids)
- ellipsis?
- (sids ellipsis-sids set-ellipsis-sids!))
\ No newline at end of file
+(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
projects / mit-scheme.git / commitdiff