<<>> <<;;; ExtendSyntax.scheme>> <<;;; Copyright Ó 1988, 1989, 1991 by Xerox Corporation. All rights reserved.>> <<;;; Last changed by Pavel on March 22, 1989 6:18:21 pm PST>> <<;;; Michael Plass, January 20, 1989 3:58:23 pm PST>> <> <> <<>> <> <> <<>> (export (syntax-match? extend-syntax extend-syntax/code let-syntax) (define (syntax-match? keys pat exp) <> (cond ((symbol? pat) (if (memq pat keys) (eq? exp pat) #t)) ((pair? pat) (cond ((equal? (cdr pat) '(...)) (let f ((lst exp)) (or (null? lst) (and (pair? lst) (syntax-match? keys (car pat) (car lst)) (f (cdr lst)))))) ((eq? (car pat) '{) (let loop ((pat-tail (cdr pat)) (exp-tail exp)) (cond ((and (null? exp-tail) (equal? pat-tail '(} ...)))) ((not (pair? pat-tail)) (error 'syntax-match? pat "Malformed pattern: Mismatched {")) ((eq? (car pat-tail) '}) (if (equal? (cdr pat-tail) '(...)) (loop (cdr pat) exp-tail) (error 'syntax-match? pat "Malformed pattern: } not followed by elipsis"))) (else (and (pair? exp-tail) (syntax-match? keys (car pat-tail) (car exp-tail)) (loop (cdr pat-tail) (cdr exp-tail))))))) (else (and (pair? exp) (syntax-match? keys (car pat) (car exp)) (syntax-match? keys (cdr pat) (cdr exp)))))) (else (equal? exp pat)))) <> <> <> <> <> (define (make-id name access control . maybe-step) (list* name access control maybe-step)) (define id-name car) (define id-access cadr) (define id-control caddr) (define id-step cadddr) (define (set-id-step! id step) (set-car! (cdddr id) step)) (define (id-stepper id) (if (<= (id-step id) 4) `(,(vector-ref '#(cannot-happen cdr cddr cdddr cddddr) (id-step id)) ,(id-name id)) `(list-tail ,(id-name id) ,(id-step id)))) (define lookup assq) ; This must change if ID-NAME is not CAR <> (define (make-loop) (list '())) (define loop-ids car) (define set-loop-ids! set-car!) (define (add-control! control loops) <> (cond ((not (null? control)) (if (null? loops) (error 'extend-syntax "missing ellipsis in expansion")) (let ((x (loop-ids (car loops)))) (if (not (memq control x)) (set-loop-ids! (car loops) (cons control x)))) (add-control! (id-control control) (cdr loops))))) (define c...rs <<;; A little association list to make ADD-CAR and ADD-CDR easier.>> `((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr))) (define (add-car access) <<;; Return a concise access form that is equivalent to `(car ,access)>> (let ((x (and (pair? access) (assq (car access) c...rs)))) (if x `(,(cadr x) ,@(cdr access)) `(car ,access)))) (define (add-cdr access) <<;; Return a concise access form that is equivalent to `(cdr ,access)>> (let ((x (and (pair? access) (assq (car access) c...rs)))) (if x `(,(cddr x) ,@(cdr access)) `(cdr ,access)))) (define (parse keys pattern access control ids) <> <> <> <> (cond ((symbol? pattern) (if (memq pattern keys) ids (cons (make-id pattern access control) ids))) ((pair? pattern) (cond ((equal? (cdr pattern) '(...)) << We're going to have a loop. Create an iteration variable, add it to the control environment and recurse, assuming that the new variable will be bound to the tails of the matched list.>> (let ((x (gensym))) (parse keys (car pattern) (add-car x) (make-id x access control 1) ids))) ((eq? (car pattern) '{) << We're going to have a loop-of-groups. Create an iteration variable that will range over the heads of such groups, add it to the control environment and recurse on each of the elements of the group. We need to know how long the group is in order to properly step the iteration variable later.>> (let* ((x (gensym)) (iter-id (make-id x access control #f))) (let loop ((pat-tail (cdr pattern)) (count 0) (access x) (ids ids)) (cond ((not (pair? pat-tail)) (error 'extend-syntax "Unmatched { in pattern")) ((eq? (car pat-tail) '}) (cond ((equal? (cdr pat-tail) '(...)) (if (zero? count) (error 'extend-syntax "empty { } ... group")) (set-id-step! iter-id count) ids) (else (error 'extend-syntax "} not followed by ellipsis in pattern")))) (else (loop (cdr pat-tail) (+ count 1) (add-cdr access) (parse keys (car pat-tail) (add-car access) iter-id ids))))))) (else (parse keys (car pattern) (add-car access) control (parse keys (cdr pattern) (add-cdr access) control ids))))) (else ids))) (define (gen keys exp ids loops) <> <> <> <> (cond ((symbol? exp) (let ((id (lookup exp ids))) (cond ((not id) exp) (else <> (add-control! (id-control id) loops) (list 'unquote (id-access id)))))) ((pair? exp) (cond ((eq? (car exp) 'with) (if (not (syntax-match? '(with) '(with ((p x) ...) e) exp)) (error 'extend-syntax "invalid 'with' form" exp) (list 'unquote (gen-with keys (map car (cadr exp)) (map cadr (cadr exp)) (caddr exp) ids loops)))) ((and (pair? (cdr exp)) (eq? (cadr exp) '...)) (let ((x (make-loop))) (gen-cons (list 'unquote-splicing (make-single-loop x (gen keys (car exp) ids (cons x loops)))) (gen keys (cddr exp) ids loops)))) ((eq? (car exp) '{) (let* ((x (make-loop)) (new-loops (cons x loops))) (let loop ((tail (cdr exp)) (bodies '())) (cond ((not (pair? tail)) (error 'extend-syntax "Unmatched { in expansion")) ((eq? (car tail) '}) (if (and (pair? (cdr tail)) (eq? (cadr tail) '...)) (gen-cons (list 'unquote-splicing (make-multiple-loop x (reverse bodies))) (gen keys (cddr tail) ids loops)) (error 'extend-syntax "} not followed by ellipsis in expansion"))) (else (loop (cdr tail) (cons (gen keys (car tail) ids new-loops) bodies))))))) (else (let ((a (gen keys (car exp) ids loops)) (d (gen keys (cdr exp) ids loops))) (if (and (pair? d) (eq? (car d) 'unquote)) (list a (list 'unquote-splicing (cadr d))) (cons a d)))))) (else exp))) (define (gen-cons head tail) <> (if (null? tail) (if (syntax-match? '(unquote-splicing) '(unquote-splicing *) head) (list 'unquote (cadr head)) (cons head tail)) (if (syntax-match? '(unquote) '(unquote *) tail) (list head (list 'unquote-splicing (cadr tail))) (cons head tail)))) (define (gen-with keys pats exprs body ids loops) <> <> <> <> <> <> <> (if (null? pats) (make-quasi (gen keys body ids loops)) (let ((p (car pats)) (e (car exprs)) (g (gensym))) `(let ((,g ,(gen-quotes keys e ids loops))) (if (syntax-match? '() ',p ,g) ,(gen-with keys (cdr pats) (cdr exprs) body (parse '() p g '() ids) loops) (error ',(car keys) "does not fit 'with' pattern" ,g ',p)))))) (define (gen-quotes keys expr ids loops) <> <> <> (cond ((syntax-match? '(quote) '(quote x) expr) (make-quasi (gen keys (cadr expr) ids loops))) ((pair? expr) (cons (gen-quotes keys (car expr) ids loops) (gen-quotes keys (cdr expr) ids loops))) (else expr))) (define (make-single-loop loop body) <> <> <> (let ((ids (loop-ids loop))) (cond ((null? ids) <> (error 'extend-syntax "extra ellipsis in expansion")) ((equal? body (list 'unquote `(car ,(id-name (car ids))))) <> <> <> <> <> (id-access (car ids))) <<((and (null? (cdr ids))>> << (syntax-match? '(unquote car) '(unquote (f (car x))) body)>> << (eq? (cadadr body) (id-name (car ids)))>> << (= 1 (id-step (car ids))))>> <> <> <> <> <> <> <<`(map ,(caadr body) ,(id-access (car ids))))>> (else `(let loop ,(map (lambda (id) (list (id-name id) (id-access id))) ids) (if (or ,@(map (lambda (id) `(null? ,(id-name id))) ids)) '() (cons ,(make-quasi body) (loop ,@(map id-stepper ids))))))))) (define (make-multiple-loop loop bodies) <> <> <> (let ((ids (loop-ids loop))) (cond ((null? ids) <> (error 'extend-syntax "extra ellipsis in expansion")) (else `(let loop ,(map (lambda (id) (list (id-name id) (id-access id))) ids) (if (or ,@(map (lambda (id) `(null? ,(id-name id))) ids)) '() (list* ,@(map make-quasi bodies) (loop ,@(map id-stepper ids))))))))) (define (make-quasi s-exp) <> (if (and (pair? s-exp) (eq? (car s-exp) 'unquote)) (cadr s-exp) (list 'quasiquote s-exp))) (define (make-clause keys cl x) (cond ((syntax-match? '() '(pat fender exp) cl) (let ((pat (car cl)) (fender (cadr cl)) (exp (caddr cl))) (let ((ids (parse keys pat x '() '()))) `((and (syntax-match? ',keys ',pat ,x) ,(gen-quotes keys fender ids '())) ,(make-quasi (gen keys exp ids '())))))) ((syntax-match? '() '(pat exp) cl) (let ((pat (car cl)) (exp (cadr cl))) (let ((ids (parse keys pat x '() '()))) `((syntax-match? ',keys ',pat ,x) ,(make-quasi (gen keys exp ids '())))))) (else (error 'extend-syntax "invalid clause" cl)))) (define (expand-syntax keys clauses) <> (let ((x (gensym))) `(lambda (,x) (cond ,@(map (lambda (cl) (make-clause keys cl x)) clauses) (else (error ',(car keys) "invalid syntax" ,x)))))) (define extend-syntax (make-syntax (lambda (keys . clauses) (cond ((and (not (null? keys)) (every symbol? keys)) `(macro ,(car keys) ,(expand-syntax keys clauses))) (else (error 'extend-syntax "invalid key list" keys)))))) (define extend-syntax/code (make-syntax (lambda (keys . clauses) (cond ((and (not (null? keys)) (every symbol? keys)) `',(expand-syntax keys clauses)) (else (error 'extend-syntax/code "invalid key list" keys)))))) (define let-syntax (make-syntax (lambda (bindings . body) (let ((new-bindings (map (lambda (binding) (if (pair? (car binding)) `(,(caar binding) (lambda x (,(expand-syntax (car binding) (cdr binding)) (cons ',(caar binding) x)))) binding)) bindings))) `(primitive-let-syntax ,new-bindings ,@body))))) )