From a04378caa642239cabb3204dfd759899a7c84426 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 29 Nov 2018 22:45:50 -0800 Subject: [PATCH] syntax-rules: eliminate use of rename for creating new identifiers. This confusion is one of several that has resulted from long-term muddy thinking on my part, and is a contributor to the bug that was filed. Also, clean up the code a bit in preparation for further changes required by R7RS. --- src/runtime/syntax-rules.scm | 305 +++++++++++++++++------------------ 1 file changed, 147 insertions(+), 158 deletions(-) diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm index 7ba5c7d98..434cf511f 100644 --- a/src/runtime/syntax-rules.scm +++ b/src/runtime/syntax-rules.scm @@ -45,29 +45,30 @@ USA. (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-macro-transformer) - (,(rename 'lambda) - (,r-form ,r-rename ,r-compare) - (,(rename 'declare) (ignorable ,r-rename ,r-compare)) - ,(let loop ((clauses clauses)) - (if (pair? clauses) - (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)) - ,(loop (cdr clauses))))) - `(,(rename 'begin) - (,(rename 'ill-formed-syntax) ,r-form)))))))))))) + (syntax-error "Keywords list contains duplicates:" keywords)) + (let ((r-form (new-identifier 'form)) + (r-rename (new-identifier 'rename)) + (r-compare (new-identifier 'compare))) + `(,(rename 'er-macro-transformer) + (,(rename 'lambda) + (,r-form ,r-rename ,r-compare) + (,(rename 'declare) (ignorable ,r-rename ,r-compare)) + ,(let loop ((clauses clauses)) + (if (pair? clauses) + (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)) + ,(loop (cdr clauses))))) + `(,(rename 'begin) + (,(rename 'ill-formed-syntax) + (,(rename 'quote) ,r-form)))))))))))) (define (parse-pattern rename compare keywords pattern expression) (let loop @@ -79,10 +80,10 @@ USA. (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-local-identifier-renamer) 'control))) + ((zero-or-more? rename compare pattern) + (if (not (null? (cddr pattern))) + (syntax-error "Misplaced ellipsis:" pattern)) + (let ((variable (new-identifier 'control))) (loop (car pattern) variable sids @@ -96,6 +97,13 @@ USA. control) control)) (else sids)))) + +(define-record-type + (make-sid name expression control) + sid? + (name sid-name) + (expression sid-expression) + (control sid-control)) (define (generate-match rename compare keywords r-rename r-compare pattern expression) @@ -104,39 +112,25 @@ USA. (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)) + (let-ify rename expression + (lambda (expr) + `(,(rename 'and) + (,(rename 'identifier?) ,expr) + (,r-compare ,expr + (,r-rename ,(syntax-quote pattern)))))) `#t)) - ((and (zero-or-more? pattern rename compare) - (null? (cddr pattern))) + ((zero-or-more? rename compare pattern) + ;; (cddr pattern) guaranteed null by parser above. (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))))) + (let-ify rename expression + (lambda (expr) + `(,(rename 'and) + (,(rename 'pair?) ,expr) + ,(loop (car pattern) + `(,(rename 'car) ,expr)) + ,(loop (cdr pattern) + `(,(rename 'cdr) ,expr)))))) ((null? pattern) `(,(rename 'null?) ,expression)) (else @@ -144,47 +138,43 @@ USA. (,(rename 'quote) ,pattern)))))) (do-list (lambda (pattern expression) - (let ((r-loop (rename 'loop)) - (r-l (rename 'l)) - (r-lambda (rename 'lambda))) - `(((,r-lambda - () - (,(rename 'define) - ,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)) - ,expression)))) - (conjunction - (lambda (predicate consequent) - (cond ((eq? predicate #t) consequent) - ((eq? consequent #t) predicate) - (else `(,(rename 'if) ,predicate ,consequent #f)))))) + (let ((r-loop (new-identifier 'loop)) + (r-l (new-identifier 'l))) + `((,(rename 'let) + () + (,(rename 'define) + (,r-loop ,r-l) + (,(rename 'if) + (,(rename 'null?) ,r-l) + #t + (,(rename 'and) + (,(rename 'pair?) ,r-l) + ,(loop pattern `(,(rename 'car) ,r-l)) + (,r-loop (,(rename 'cdr) ,r-l))))) + ,r-loop) + ,expression))))) (loop pattern expression))) + +(define (let-ify rename expression generate-body) + (if (identifier? expression) + (generate-body expression) + (let ((temp (new-identifier 'temp))) + `(,(rename 'let) ((,temp ,expression)) ,(generate-body temp))))) (define (generate-output rename compare r-rename sids template) (let loop ((template template) (ellipses '())) (cond ((identifier? template) (let ((sid - (let loop ((sids sids)) - (and (pair? sids) - (if (eq? (sid-name (car sids)) template) - (car sids) - (loop (cdr sids))))))) + (find (lambda (sid) + (eq? (sid-name sid) template)) + sids))) (if sid (begin (add-control! sid ellipses) (sid-expression sid)) + ;; Template is a keyword: `(,r-rename ,(syntax-quote template))))) - ((or (zero-or-more? template rename compare) - (at-least-one? template rename compare)) + ((zero-or-more? rename compare template) (optimized-append rename compare (let ((ellipsis (make-ellipsis '()))) (generate-ellipsis rename @@ -201,54 +191,62 @@ USA. `(,(rename 'quote) ,template))))) (define (add-control! sid ellipses) - (let loop ((sid sid) (ellipses ellipses)) - (let ((control (sid-control sid))) - (cond (control - (if (pair? ellipses) - (let ((sids (ellipsis-sids (car ellipses)))) - (cond ((not (memq control sids)) - (set-ellipsis-sids! (car ellipses) - (cons control sids))) - ((not (eq? control (car sids))) - (error "illegal control/ellipsis combination" - control sids)))) - (syntax-error "Missing ellipsis in expansion." #f)) - (loop control (cdr ellipses))))))) + (let ((control (sid-control sid))) + (if control + (begin + (if (not (pair? ellipses)) + (syntax-error "Missing ellipsis in expansion.")) + (let ((sids (ellipsis-sids (car ellipses)))) + (if (memq control sids) + (if (not (eq? control (car sids))) + (error "illegal control/ellipsis combination:" + control sids)) + (set-ellipsis-sids! (car ellipses) (cons control sids)))) + (add-control! control (cdr ellipses)))))) (define (generate-ellipsis rename ellipsis body) + ;; Generation of body will have filled in the sids: (let ((sids (ellipsis-sids ellipsis))) - (if (pair? sids) - (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))))) - (syntax-error "Missing ellipsis in expansion." #f)))) + (if (not (pair? sids)) + (syntax-error "Missing ellipsis in expansion.")) + ;; Optimize trivial case: + (if (and (eq? body (sid-name (car sids))) + (null? (cdr sids))) + (sid-expression (car sids)) + `(,(rename 'map) (,(rename 'lambda) ,(map sid-name sids) ,body) + ,@(map sid-expression sids))))) + +(define-record-type + (make-ellipsis sids) + ellipsis? + (sids ellipsis-sids set-ellipsis-sids!)) -(define (zero-or-more? pattern rename compare) +(define (optimized-append rename compare x y) + (cond ((constant-null? rename compare x) y) + ((constant-null? rename compare y) x) + (else `(,(rename 'append) ,x ,y)))) + +(define (optimized-cons rename compare a d) + (cond ((and (constant? rename compare a) + (constant? rename compare d)) + `(,(rename 'quote) + ,(cons (constant->datum rename compare a) + (constant->datum rename compare d)))) + ((constant-null? rename compare d) + `(,(rename 'list) ,a)) + ((and (pair? d) + (compare (car d) (rename 'list)) + (list? (cdr d))) + `(,(rename 'list) ,a ,@(cdr d))) + (else + `(,(rename 'cons) ,a ,d)))) + +(define (zero-or-more? rename compare pattern) (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 (syntax-quote expression) `(,(classifier->keyword (lambda (form senv hist) @@ -256,38 +254,29 @@ USA. (constant-item (serror-ctx form senv hist) (cadr form)))) ,expression)) -(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 (constant-null? rename compare expr) + (and (quoted? rename compare expr) + (eqv? '() (quoted-datum expr)))) -(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 (constant? rename compare expr) + (or (quoted? rename compare expr) + (boolean? expr) + (bytevector? expr) + (char? expr) + (number? expr) + (string? expr) + (vector? expr))) -(define-record-type - (make-sid name expression control) - sid? - (name sid-name) - (expression sid-expression) - (control sid-control) - (output-expression sid-output-expression set-sid-output-expression!)) +(define (constant->datum rename compare expr) + (if (quoted? rename compare expr) + (quoted-datum expr) + expr)) -(define-record-type - (make-ellipsis sids) - ellipsis? - (sids ellipsis-sids set-ellipsis-sids!)) \ No newline at end of file +(define (quoted-datum expr) + (cadr expr)) + +(define (quoted? rename compare expr) + (and (pair? expr) + (compare (car expr) (rename 'quote)) + (pair? (cdr expr)) + (null? (cddr expr)))) \ No newline at end of file -- 2.25.1