[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
extend-syntax for T
I've gotten quite a few requests for this, so here it is.
------------------------------------------------------------------------
(herald extend)
;;;
;;; Extend-syntax for T
;;;
;;; The port from MacScheme to T was done by
;;; Mike Coffin (mike@arizona.edu)
;;;
;;; When loaded, this file defines two functions, SYNTAX-MATCH? and
;;; EXTEND-SYNTAX->MACRO-EXPANDER, and also installs two macros,
;;; EXTENDED-SYNTAX and EXTEND-SYNTAX.
;;;
;;; SYNTAX-MATCH? is used by EXTEND-SYNTAX->MACRO-EXPANDER to choose
;;; among clauses and check for syntactic errors; it is also available
;;; to the user.
;;;
;;; EXTEND-SYNTAX->MACRO-EXPANDER is the basic function.
;;; It translates an argument that looks like
;;; ((key1 key2 ...) clause ...)
;;; --- i.e., the cdr of an extend-syntax form --- into unEVALed code
;;; for a macro-expander. For example,
;;; (extend-syntax->macro-expander '((foo) ((foo a b) (+ a b))))
;;; ==>
;;; (MACRO-EXPANDER (FOO . X.72)
;;; (LET ((X.72 (CONS 'FOO X.72)))
;;; (COND ((SYNTAX-MATCH? '(FOO) '(FOO A B) X.72)
;;; `(+ ,(CADR X.72) ,(CADDR X.72)))
;;; (ELSE (ERROR "extend-syntax: invalid syntax: ~a~%"
;;; X.72)))))
;;;
;;; EXTENDED-SYNTAX is a macro that returns the actual macro-expander.
;;; This is most useful as an argument to DEFINE-SYNTAX or
;;; DEFINE-LOCAL-SYNTAX. E.g.,
;;; (define-local-syntax add+1
;;; (extended-syntax (add+1)
;;; ((add+1 x y ...)
;;; (+ 1 x y ...))))
;;;
;;; And finally, the macro EXTEND-SYNTAX, which creates a macro-expander
;;; and then installs it with DEFINE-SYNTAX. Nice looking but not as
;;; flexible as one might like.
;;;
;;; The original header follows.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; extend.sch
;;; 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.
;;; The basic design of extend-syntax is due to Eugene Kohlbecker. See
;;; "E. Kohlbecker: Syntactic Extensions in the Programming Language Lisp",
;;; Ph.D. Dissertation, Indiana University, 1986." The structure of "with"
;;; pattern/value clauses, the method for compiling extend-syntax into
;;; Scheme code, and the actual implementation are due to Kent Dybvig.
;;; Made available courtesy R. Kent Dybvig
;;; MacScheme conversion by Jeff De Vries
;;; note: requires the use of MacScheme Version 1.2 or greater
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; these routines are provided for compatibility with other Schemes.
(define-local-syntax (when condition . actions)
`(if ,condition
(block ,@actions)
nil)
)
(define-local-syntax (unless condition . actions)
`(if ,condition
t
(block ,@actions))
)
(labels (
( (andmap p . args)
;; use "first-finish" rule
(iterate andmap ((args args) (value t))
(if (iterate any-at-end? ((ls args))
(and (pair? ls)
(or (not (pair? (car ls)))
(any-at-end? (cdr ls)))))
value
(let ((value (apply p (map car args))))
(and value (andmap (map cdr args) value))))))
;; constuctor and access functions for id's.
( (id name access control)
(list name access control))
( id-name car)
( id-access cadr)
( id-control caddr)
;; constuctor and access functions for loop's
( (loop) (list '()))
( loop-ids car)
( loop-ids! (setter car))
;; alist used to add one more car or cdr to an access chain.
( 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)))
;; optimized versions of `(car ,access)
( (add-car access)
(let ((x (and (pair? access) (assq (car access) c...rs))))
(if (null? x)
`(car ,access)
`(,(cadr x) ,@(cdr access)))))
;; optimized version of `(cdr ,access)
( (add-cdr access)
(let ((x (and (pair? access) (assq (car access) c...rs))))
(if (null? x)
`(cdr ,access)
`(,(cddr x) ,@(cdr access)))))
( (parse keys pat acc cntl ids)
(cong-
((symbol? pat)
(if (memq pat keys)
ids
(cons (id pat acc cntl) ids)))
((pair? pat)
(if (equal? (cdr pat) '(...))
(let ((x (generate-symbol "X")))
(parse keys (car pat) x (id x acc cntl) ids))
(parse keys (car pat) (add-car acc) cntl
(parse keys (cdr pat) (add-cdr acc) cntl ids))))
(else ids)))
( (gen keys exp ids loops)
(cond
((symbol? exp)
(let ((id (lookup exp ids)))
(if (null? id)
exp
(block
(add-control! (id-control id) loops)
(list 'unquote (id-access id))))))
((pair? exp)
(cond
((eq? (car exp) 'with)
(unless (syntax-match? '(with) '(with ((p x) ...) e) exp)
(error "extend-syntax: invalid 'with' form~a" 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 (loop)))
(make-loop
x
(gen keys (car exp) ids (cons x loops))
(gen keys (cddr exp) ids loops))))
(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)))
( (gen-with keys pats exps body ids loops)
(if (null? pats)
(make-quasi (gen keys body ids loops))
(let ((p (car pats)) (e (car exps)) (g (generate-symbol "X")))
`(let ((,g ,(gen-quotes keys e ids loops)))
(if (syntax-match? '() ',p ,g)
,(gen-with
keys
(cdr pats)
(cdr exps)
body
(parse '() p g '() ids)
loops)
(error "extend-syntax: ~a does not fit with pattern ~a, ~a"
',(car keys) ,g ,p)
)))))
( (gen-quotes keys exp ids loops)
(cond
((syntax-match? '(quote) '(quote x) exp)
(make-quasi (gen keys (cadr exp) ids loops)))
((pair? exp)
(cons (gen-quotes keys (car exp) ids loops)
(gen-quotes keys (cdr exp) ids loops)))
(else exp)))
( (lookup sym ids)
(iterate loop ((ls ids))
(cond
((null? ls) nil)
((eq? (id-name (car ls)) sym) (car ls))
(else (loop (cdr ls))))))
( (add-control! id loops)
(unless (null? id)
(when (null? loops)
(error "extend-syntax: missing ellipsis in expansion"))
(let ((x (loop-ids (car loops))))
(unless (memq id x)
(loop-ids! (car loops) (cons id x))))
(add-control! (id-control id) (cdr loops))))
( (make-loop loop body tail)
(let ((ids (loop-ids loop)))
(when (null? ids)
(error "extend-syntax: extra ellipsis in expansion"))
(cond
((equal? body (list 'unquote (id-name (car ids))))
(if (null? tail)
(list 'unquote (id-access (car ids)))
(cons (list 'unquote-splicing (id-access (car ids)))
tail)))
((and (null? (cdr ids))
(syntax-match? '(unquote) '(unquote (f x)) body)
(eq? (cadadr body) (id-name (car ids))))
(let ((x `(map ,(caadr body) ,(id-access (car ids)))))
(if (null? tail)
(list 'unquote x)
(cons (list 'unquote-splicing x) tail))))
(else
(let ((x `(map (lambda ,(map id-name ids) ,(make-quasi body))
,@(map id-access ids))))
(if (null? tail)
(list 'unquote x)
(cons (list 'unquote-splicing x) tail)))))))
;; return `exp. As an optimization, if exp looks like ,expx we just
;; return expx instead of `,expx.
( (make-quasi exp)
(if (and (pair? exp) (eq? (car exp) 'unquote))
(cadr exp)
(list 'quasiquote exp)))
;; return a cond clause to compare clause cl with the form x and
;; return the appropriate EVALuable form.
( (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 ~a~%" cl))))
( make-syntax
(let ((x (generate-symbol "X")))
(lambda (keys clauses)
`(macro-expander (,(car keys) . ,x)
(let ((,x (cons ',(car keys) ,x)))
(cond
,@(map (lambda (cl) (make-clause keys cl x))
clauses)
(else
(error "extend-syntax: invalid syntax: ~a~%" ,x)
))))
)))
);; end of label functions; beginning of labels body
;;; syntax-match? is used by extend-syntax to choose among clauses and
;;; to check for syntactic errors. It is also available to the user.
(define syntax-match?
(lambda (keys pat exp)
(cond
((symbol? pat) (if (memq pat keys) (eq? exp pat) t))
((pair? pat)
(if (equal? (cdr pat) '(...))
(iterate f ((lst exp))
(or (null? lst)
(and (pair? lst)
(syntax-match? keys (car pat) (car lst))
(f (cdr lst)))))
(and (pair? exp)
(syntax-match? keys (car pat) (car exp))
(syntax-match? keys (cdr pat) (cdr exp)))))
(else (equal? exp pat)))))
;;
;; This is the fundamental function. It translates an argument
;; that looks like ((key1 key2 ...) clause ...) --- i.e., the cdr
;; of an extend-syntax form --- into unEVALed code for a
;; macro-expander. E.g.,
;; (ext-syn->macro-exp '((foo) ((foo a b) (+ a b))))
;; ==>
;; (MACRO-EXPANDER (FOO . X.72)
;; (LET ((X.72 (CONS 'FOO X.72)))
;; (COND ((SYNTAX-MATCH? '(FOO) '(FOO A B) X.72)
;; `(+ ,(CADR X.72) ,(CADDR X.72)))
;; (ELSE (ERROR "extend-syntax: invalid syntax: ~a~%"
;; X.72)))))
;;
(define (extend-syntax->macro-expander x)
(cond
((and
(syntax-match? '() '( (key1 key2 ...) clause ...) x)
(andmap symbol? (car x) ))
(let
((f (make-syntax (car x) (cdr x))))
(if (syntax-match? '() 'proc f)
f
(error "extend-syntax: does not fit 'with' pattern: ~a, ~a"
f 'proc))))
(else (error "extend-syntax:: invalid syntax: ~a" x))))
;; return a macro expander that corresponds to the extend-syntax
;; form x. This is useful as an argument to define-syntax or
;; define-local-syntax. E.g.,
;;
;; (define-local-syntax add+1
;; (extended-syntax (add+1)
;; ((add+1 x y ...)
;; (+ 1 x y ...))))
(define-syntax (extended-syntax . x)
(extend-syntax->macro-expander x))
;; The nicest looking but least general form.
(define-syntax (extend-syntax . x)
`(define-syntax
,(caar x)
,(extend-syntax->macro-expander x)))
);; end of labels
;;; end of extend.t