[_CDCSL_93-16_]<1>Cedar>release>Scheme>ExtendSyntax.scheme

;;; ExtendSyntax.scheme

;;; Last changed by Pavel on March 22, 1989 6:18:21 pm PST

;;; Michael Plass, January 20, 1989 3:58:23 pm PST

Permission to copy this software, in whole or in part, to use this software for any lawful noncommercial purpose, and to redistribute this software is granted subject to the restriction that all copies made of this software must include this copyright notice in full. Cadence makes no warranties or representations of any kind, either express or implied, including but not limited to implied warranties of merchantability or fitness for any particular purpose.

Made available through the courtesy of R. Kent Dybvig (thanks!)

Made to work with Cedar Scheme (and heavily munged) by Pavel Curtis.

(export (syntax-match? extend-syntax extend-syntax/code let-syntax)

(define (syntax-match? keys pat exp)

syntax-match? is used by Extend-Syntax to choose among clauses and to check for syntactic errors. It is also available to users.

(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))))

The ID data structure:

NAME is the name of the identifier

ACCESS is a form that provides the value for the identifier

CONTROL is another ID that is the iteration variable for an ellipsis around this ID.

STEP is only defined for iteration variables; it is the number of time to apply CDR to the iteration variable each time through the loop. For simple ellipsis use, this will always be 1, but use of { and } to delimit groups will give this a higher value, namely the number of elements in the group.

(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

The LOOP data structure:

(define (make-loop)

(list '()))

(define loop-ids car)

(define set-loop-ids! set-car!)

(define (add-control! control loops)

CONTROL is the control ID for a variable inside the given LOOPS. Add it to the innermost LOOP and recurse on the next outer control ID and LOOP. There should be at least as many nested expansion ellipses as there were pattern ellipses.

(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)

Parse the given PATTERN and return a list of ID structures that extract the pieces from the value of the expression ACCESS.

KEYS is a list of symbols that are to be treated as keywords instead of variables.

CONTROL is an ID (or '()) representing the control environment (the nested ellipsis loops) of the ACCESS form.

IDS is a list of the ID's already found by other calls to PARSE. Our returned value should have IDS as a tail. This trick is more flexible and saves consing.

(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)

EXP is an expansion pattern. Return an S-expression that, when wrapped in a QUASIQUOTE, would evaluate to the proper expansion.

KEYS is passed to GEN-WITH so that a proper error message can be made.

IDS is the list of pattern variables available.

LOOPS is a list of LOOPs representing the expansion ellipses around EXP.

(cond

((symbol? exp)

(let ((id (lookup exp ids)))

(cond

((not id)

exp)

(else

Tell the outer loops that this identifier is in here.

(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)

Generate (cons head tail) with a couple of optimizations.

(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)

Return a form that evaluates to the proper expansion of a WITH pattern.

KEYS is used only for making an error message, below.

PATS is a list of the patterns to be bound.

EXPRS is a list of the expressions against whose values the PATS are to be matched.

BODY is the expansion pattern to be used inside the new bindings.

IDS is the list of pattern variables available.

LOOPS is a list of LOOPs representing the expansion ellipses around the WITH pattern.

(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"

',p))))))

(define (gen-quotes keys expr ids loops)

EXPR is a form in the binding list of a WITH pattern. Walk the expression looking for QUOTE expressions and replace them with quasiquoted expressions filling in the values of pattern variables.

A grungy kind of code-walk is done that just walks the tree of conses in the expression. It's probably safe to do it this way.

KEYS, IDS, and LOOPS are to pass to GEN.

(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)

Return an expression that will evaluate to the expansion of an elliptical expansion pattern whose body is a single s-expression.

LOOP is the current loop for which we should generate code.

BODY is the S-expression for the body of the loop.

(let ((ids (loop-ids loop)))

(cond

((null? ids)

No looping pattern variables appear inside this expansion ellipsis.

(error 'extend-syntax "extra ellipsis in expansion"))

((equal? body (list 'unquote `(car ,(id-name (car ids)))))

Handle the important special case of

VAR ...

in the pattern and

VAR ...

in the expansion. Just splice in the piece that matches that part of the pattern.

(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))))

Another special case, with

tree ...

in the pattern and

VAR ...

in the expansion, where VAR is one of the symbols in tree.

Call MAP on the appropriate selector and the piece that matches that part of the pattern.

`(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)

Return an expression that will evaluate to the expansion of an elliptical expansion pattern whose body is a group.

LOOP is the current loop for which we should generate code.

BODIES is a list of the S-expressions for the bodies of the loop.

(let ((ids (loop-ids loop)))

(cond

((null? ids)

No looping pattern variables appear inside this expansion ellipsis.

(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)

Wrap the given S-EXP in a QUASIQUOTE, with one optimization.

(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)

The real expansion function for EXTEND-SYNTAX and EXTEND-SYNTAX/CODE.

(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)))))

)