mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-11 00:00:49 +02:00
327 lines
10 KiB
Scheme
327 lines
10 KiB
Scheme
;;; "synrul.scm" Rule-based Syntactic Expanders -*-Scheme-*-
|
|
;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
|
|
;;;
|
|
;;; This material was developed by the Scheme project at the
|
|
;;; Massachusetts Institute of Technology, Department of Electrical
|
|
;;; Engineering and Computer Science. Permission to copy this
|
|
;;; software, to redistribute it, and to use it for any purpose is
|
|
;;; granted, subject to the following restrictions and understandings.
|
|
;;;
|
|
;;; 1. Any copy made of this software must include this copyright
|
|
;;; notice in full.
|
|
;;;
|
|
;;; 2. Users of this software agree to make their best efforts (a) to
|
|
;;; return to the MIT Scheme project any improvements or extensions
|
|
;;; that they make, so that these may be included in future releases;
|
|
;;; and (b) to inform MIT of noteworthy uses of this software.
|
|
;;;
|
|
;;; 3. All materials developed as a consequence of the use of this
|
|
;;; software shall duly acknowledge such use, in accordance with the
|
|
;;; usual standards of acknowledging credit in academic research.
|
|
;;;
|
|
;;; 4. MIT has made no warrantee or representation that the operation
|
|
;;; of this software will be error-free, and MIT is under no
|
|
;;; obligation to provide any services, by way of maintenance, update,
|
|
;;; or otherwise.
|
|
;;;
|
|
;;; 5. In conjunction with products arising from the use of this
|
|
;;; material, there shall be no use of the name of the Massachusetts
|
|
;;; Institute of Technology nor of any adaptation thereof in any
|
|
;;; advertising, promotional, or sales literature without prior
|
|
;;; written consent from MIT in each case.
|
|
|
|
;;;; Rule-based Syntactic Expanders
|
|
|
|
;;; See "Syntactic Extensions in the Programming Language Lisp", by
|
|
;;; Eugene Kohlbecker, Ph.D. dissertation, Indiana University, 1986.
|
|
;;; See also "Macros That Work", by William Clinger and Jonathan Rees
|
|
;;; (reference? POPL?). This implementation is derived from an
|
|
;;; implementation by Kent Dybvig, and includes some ideas from
|
|
;;; another implementation by Jonathan Rees.
|
|
|
|
;;; The expansion of SYNTAX-RULES references the following keywords:
|
|
;;; ER-TRANSFORMER LAMBDA IF BEGIN SET! QUOTE
|
|
;;; and the following procedures:
|
|
;;; CAR CDR NULL? PAIR? EQUAL? MAP LIST CONS APPEND
|
|
;;; ILL-FORMED-SYNTAX
|
|
;;; it also uses the anonymous keyword SYNTAX-QUOTE.
|
|
|
|
;;; For testing.
|
|
;;;(define (run-sr form)
|
|
;;; (expand/syntax-rules form (lambda (x) x) eq?))
|
|
|
|
(define (make-syntax-rules-macrology)
|
|
(make-er-expander-macrology
|
|
(lambda (define-classifier base-environment)
|
|
base-environment ;ignore
|
|
(define-classifier 'SYNTAX-RULES expand/syntax-rules))))
|
|
|
|
(define (expand/syntax-rules form rename compare)
|
|
(if (syntax-match? '((* IDENTIFIER) + ((IDENTIFIER . DATUM) EXPRESSION))
|
|
(cdr form))
|
|
(let ((keywords (cadr form))
|
|
(clauses (cddr form)))
|
|
(if (let loop ((keywords keywords))
|
|
(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-TRANSFORMER)
|
|
(,(rename 'LAMBDA)
|
|
(,r-form ,r-rename ,r-compare)
|
|
,(let loop ((clauses clauses))
|
|
(if (null? clauses)
|
|
`(,(rename 'ILL-FORMED-SYNTAX) ,r-form)
|
|
(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)
|
|
syntax-error)
|
|
,(loop (cdr clauses))))))))))))
|
|
(ill-formed-syntax form)))
|
|
|
|
(define (parse-pattern rename compare keywords pattern expression)
|
|
(let loop
|
|
((pattern pattern)
|
|
(expression expression)
|
|
(sids '())
|
|
(control #f))
|
|
(cond ((identifier? pattern)
|
|
(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-name-generator) 'CONTROL)))
|
|
(loop (car pattern)
|
|
variable
|
|
sids
|
|
(make-sid variable expression control))))
|
|
((pair? pattern)
|
|
(loop (car pattern)
|
|
`(,(rename 'CAR) ,expression)
|
|
(loop (cdr pattern)
|
|
`(,(rename 'CDR) ,expression)
|
|
sids
|
|
control)
|
|
control))
|
|
(else sids))))
|
|
|
|
(define (generate-match rename compare keywords r-rename r-compare
|
|
pattern expression)
|
|
(letrec
|
|
((loop
|
|
(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))
|
|
`#t))
|
|
((and (zero-or-more? pattern rename compare)
|
|
(null? (cddr pattern)))
|
|
(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)))))
|
|
((null? pattern)
|
|
`(,(rename 'NULL?) ,expression))
|
|
(else
|
|
`(,(rename 'EQUAL?) ,expression
|
|
(,(rename 'QUOTE) ,pattern))))))
|
|
(do-list
|
|
(lambda (pattern expression)
|
|
(let ((r-loop (rename 'LOOP))
|
|
(r-l (rename 'L))
|
|
(r-lambda (rename 'LAMBDA)))
|
|
`(((,r-lambda
|
|
(,r-loop)
|
|
(,(rename 'BEGIN)
|
|
(,(rename 'SET!)
|
|
,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))
|
|
#F)
|
|
,expression))))
|
|
(conjunction
|
|
(lambda (predicate consequent)
|
|
(cond ((eq? predicate #T) consequent)
|
|
((eq? consequent #T) predicate)
|
|
(else `(,(rename 'IF) ,predicate ,consequent #F))))))
|
|
(loop pattern expression)))
|
|
|
|
(define (generate-output rename compare r-rename sids template syntax-error)
|
|
(let loop ((template template) (ellipses '()))
|
|
(cond ((identifier? template)
|
|
(let ((sid
|
|
(let loop ((sids sids))
|
|
(and (not (null? sids))
|
|
(if (eq? (sid-name (car sids)) template)
|
|
(car sids)
|
|
(loop (cdr sids)))))))
|
|
(if sid
|
|
(begin
|
|
(add-control! sid ellipses syntax-error)
|
|
(sid-expression sid))
|
|
`(,r-rename ,(syntax-quote template)))))
|
|
((or (zero-or-more? template rename compare)
|
|
(at-least-one? template rename compare))
|
|
(optimized-append rename compare
|
|
(let ((ellipsis (make-ellipsis '())))
|
|
(generate-ellipsis rename
|
|
ellipsis
|
|
(loop (car template)
|
|
(cons ellipsis
|
|
ellipses))))
|
|
(loop (cddr template) ellipses)))
|
|
((pair? template)
|
|
(optimized-cons rename compare
|
|
(loop (car template) ellipses)
|
|
(loop (cdr template) ellipses)))
|
|
(else
|
|
`(,(rename 'QUOTE) ,template)))))
|
|
|
|
(define (add-control! sid ellipses syntax-error)
|
|
(let loop ((sid sid) (ellipses ellipses))
|
|
(let ((control (sid-control sid)))
|
|
(cond (control
|
|
(if (null? ellipses)
|
|
(syntax-error "missing ellipsis in expansion" #f)
|
|
(let ((sids (ellipsis-sids (car ellipses))))
|
|
(cond ((not (memq control sids))
|
|
(set-ellipsis-sids! (car ellipses)
|
|
(cons control sids)))
|
|
((not (eq? control (car sids)))
|
|
(syntax-error "illegal control/ellipsis combination"
|
|
control sids)))))
|
|
(loop control (cdr ellipses)))
|
|
((not (null? ellipses))
|
|
(syntax-error "extra ellipsis in expansion" #f))))))
|
|
|
|
(define (generate-ellipsis rename ellipsis body)
|
|
(let ((sids (ellipsis-sids ellipsis)))
|
|
(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)))))))
|
|
|
|
(define (zero-or-more? pattern rename compare)
|
|
(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 (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 (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 sid-type
|
|
(make-record-type "sid" '(NAME EXPRESSION CONTROL OUTPUT-EXPRESSION)))
|
|
|
|
(define make-sid
|
|
(record-constructor sid-type '(NAME EXPRESSION CONTROL)))
|
|
|
|
(define sid-name
|
|
(record-accessor sid-type 'NAME))
|
|
|
|
(define sid-expression
|
|
(record-accessor sid-type 'EXPRESSION))
|
|
|
|
(define sid-control
|
|
(record-accessor sid-type 'CONTROL))
|
|
|
|
(define sid-output-expression
|
|
(record-accessor sid-type 'OUTPUT-EXPRESSION))
|
|
|
|
(define set-sid-output-expression!
|
|
(record-modifier sid-type 'OUTPUT-EXPRESSION))
|
|
|
|
(define ellipsis-type
|
|
(make-record-type "ellipsis" '(SIDS)))
|
|
|
|
(define make-ellipsis
|
|
(record-constructor ellipsis-type '(SIDS)))
|
|
|
|
(define ellipsis-sids
|
|
(record-accessor ellipsis-type 'SIDS))
|
|
|
|
(define set-ellipsis-sids!
|
|
(record-modifier ellipsis-type 'SIDS))
|