From 7e20d0747c5d33e97cd3bd6f94f7d5d3d6acddc2 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 19 Jan 2018 19:58:48 -0800 Subject: [PATCH] Rewrite define-bundle-interface to do renaming manually. Automatic renamer was clumsy and error-prone. --- src/runtime/mit-macros.scm | 72 +++++++++++++++----------------------- 1 file changed, 29 insertions(+), 43 deletions(-) diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index 2a6160e9b..2c319cc65 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -779,54 +779,40 @@ USA. (cddddr form))))) (define (make-interface-helper rename interface capturer predicate elements) - (rename-generated-expression - rename - `(begin - (define ,interface - (make-bundle-interface + (let ((rlist (rename 'list))) + `(,(rename 'begin) + (,(rename 'define) + ,interface + (,(rename 'make-bundle-interface) ',(strip-angle-brackets interface) - (list ,@(map (lambda (element) - (if (symbol? element) - `(list ',element) - `(list ',(car element) - ,@(map (lambda (p) - `(list ',(car p) - ,@(cdr p))) - (cdr element))))) - elements)))) - (define ,predicate - (dispatch-tag->predicate ,interface)) - (define-syntax ,capturer - (sc-macro-transformer - (lambda (form use-environment) - (if (not (null? (cdr form))) - (syntax-error "Ill-formed special form:" form)) - (list 'capture-bundle + (,rlist ,@(map (lambda (element) + (if (symbol? element) + `(,rlist ',element) + `(,rlist ',(car element) + ,@(map (lambda (p) + `(,rlist ',(car p) ,@(cdr p))) + (cdr element))))) + elements)))) + (,(rename 'define) + ,predicate + (,(rename 'dispatch-tag->predicate) ,interface)) + (,(rename 'define-syntax) + ,capturer + (,(rename 'sc-macro-transformer) + (,(rename 'lambda) + (form use-env) + (if (,(rename 'not) (,(rename 'null?) (,(rename 'cdr) form))) + (,(rename 'syntax-error) "Ill-formed special form:" form)) + (,rlist 'capture-bundle ',interface ,@(map (lambda (element) - `(close-syntax ',(if (symbol? element) - element - (car element)) - use-environment)) + `(,(rename 'close-syntax) + ',(if (symbol? element) + element + (car element)) + use-env)) elements)))))))) -(define (rename-generated-expression rename expr) - (let loop ((expr expr)) - (cond ((identifier? expr) - (rename expr)) - ((and (pair? expr) - (list? (cdr expr))) - (cons (rename (car expr)) - (let ((rest (cdr expr))) - (case (car expr) - ((quote dispatch-tag->predicate) - rest) - ((define define-syntax) - (cons (car rest) (map loop (cdr rest)))) - (else - (map loop rest)))))) - (else expr)))) - (define-syntax :capture-bundle (syntax-rules () ((_ interface name ...) -- 2.25.1