(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
`((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)
(let ((x (and (pair? access)
           (assq (car access) c...rs))))
(if x
`(,(cadr x) ,@(cdr access))
`(car ,access))))

(define (add-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) '(...))
(let ((x (gensym)))
(parse keys
(car pattern)
(add-car x)
(make-id x access control 1)
ids)))
((eq? (car pattern) '{)
(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)))
(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)))))
)
n
;;; 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
Copyright (C) 1987 Cadence Research Systems
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.

syntax-match? is used by Extend-Syntax to choose among clauses and to check for syntactic errors.  It is also available to users.
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.
The LOOP data structure:
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.
;; A little association list to make ADD-CAR and ADD-CDR easier.
;; Return a concise access form that is equivalent to `(car ,access)
;; Return a concise access form that is equivalent to `(cdr ,access)
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.
 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.
 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.
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.
Tell the outer loops that this identifier is in here.
Generate (cons head tail) with a couple of optimizations.
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.
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.
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.
No looping pattern variables appear inside this expansion ellipsis.
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.
((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))))
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.
No looping pattern variables appear inside this expansion ellipsis.
Wrap the given S-EXP in a QUASIQUOTE, with one optimization.
The real expansion function for EXTEND-SYNTAX and EXTEND-SYNTAX/CODE.
Κ –
(cedarcode) style•NewlineDelimiter

™™JšœΠet
œ=™LJ™:J™2—J˜Jš
Οb+™+Iraggedš
ΡbfiΝ™ΝJ™J™?J™DJ™˜C˜$J™
˜˜˜J˜
J˜——˜˜˜˜˜˜J˜+J˜————˜˜J˜˜J˜J˜"˜J˜>—˜˜"J˜J˜L——˜˜J˜4J˜+—————˜˜J˜*J˜.————˜J˜———J˜™J™"J™;J™TJ™ͺ˜2J˜'—J˜J˜J˜J˜˜J˜—˜˜˜6J˜—J˜J˜*——J˜JšœΟc(˜=—J˜šœ 
™˜J˜—J˜J˜J˜˜$J™ν
˜˜˜J˜7—˜!˜J˜.——J˜2————J˜˜J™@J˜J˜J˜J˜J˜J˜J˜J˜J˜J˜J˜J˜J˜J˜—J˜˜J™D˜J˜(˜J˜J˜———J˜˜J™D˜J˜(˜J˜J˜———J˜˜/J™{J™RJ™nJ™Ÿ
˜˜˜J˜J˜-——˜˜˜Icodeš
ΟfΉ
™Ή
˜J˜I——˜Lšœ
‘₯™¦˜J˜,˜#J˜J˜J˜˜˜J˜0—˜˜˜˜J˜-—J˜J˜—˜J˜A———˜˜J˜J˜J˜J˜>—J˜—————˜˜2J˜;————˜J˜———J˜˜ J™€
J™FJ™/J™H˜˜˜˜˜	J˜—˜J™5J˜$J˜"————˜˜˜˜;J˜0˜˜	J˜J˜J˜J˜J˜J˜	————˜.˜˜	˜˜J˜,——J˜"———˜˜J˜˜J˜˜˜J˜2—˜˜J˜˜	˜J˜(—J˜!—J˜B——˜˜J˜7——————˜˜(J˜&˜J˜J˜*J˜—————˜J˜———J˜˜J™9˜˜BJ˜J˜—˜0J˜0J˜———J˜˜1J™GJ™5J™+J™SJ™AJ™/J™U˜J˜&˜J˜J˜˜+˜˜
J˜J˜
J˜J˜J˜J˜—˜J˜J˜J˜	——————J˜˜(J™Β
J™J™(˜˜)J˜.—˜
˜,J˜(——˜J˜———J˜˜$J™€
J™;J™2˜˜˜J™CJ˜5—˜:™$J™—™J™—J™RJ˜—™J™=J™*J™™J™—™J™—J™:J™YJ™,—˜˜
˜˜,J˜——˜9J˜˜J˜$———————J˜˜(J™rJ™;J™A˜˜˜J™CJ˜5—˜˜
˜˜,J˜——˜9J˜˜ J˜$———————J˜˜J™<˜J˜!J˜J˜——J˜˜˜˜)˜J˜J˜˜'˜&J˜&J˜(————˜"˜J˜˜'˜!J˜(————˜J˜-———J˜˜$J™E˜˜
˜J˜5˜J˜-—————J˜š
œ˜š
œ˜˜˜˜J˜˜J˜——˜J˜3—————J˜š
œ˜š
œ˜˜˜˜J˜J˜ —˜J˜8—————J˜˜˜˜˜*˜2˜*J˜#˜<˜:J˜5˜J˜—————J˜0————J˜
——…—!<š