>From 4b65e8359ebf28e984580b7a61660ed9d4930576 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 25 May 2013 13:37:44 +0200 Subject: [PATCH 1/2] syntax-rules R7RS-compatibility: Implement "ellipsis escape" syntax: (... TEMPLATE) is equivalent to TEMPLATE, except with the special meaning of the (current) ellipsis being disabled --- synrules.scm | 120 +++++++++++++++++++++++++++++++---------------------------- 1 file changed, 64 insertions(+), 56 deletions(-) diff --git a/synrules.scm b/synrules.scm index cf8912e..5ecfc3b 100644 --- a/synrules.scm +++ b/synrules.scm @@ -117,41 +117,42 @@ (null? (cddr rule))) (let ((pattern (cdar rule)) (template (cadr rule))) - `((,%and ,@(process-match %tail pattern #f)) + `((,%and ,@(process-match %tail pattern #f ellipsis?)) (,%let* ,(process-pattern pattern %tail - (lambda (x) x) #f) + (lambda (x) x) #f ellipsis?) ,(process-template template 0 - (meta-variables pattern 0 '() #f))))) + ellipsis? + (meta-variables pattern 0 ellipsis? '() #f))))) (##sys#syntax-error-hook "ill-formed syntax rule" rule))) ;; Generate code to test whether input expression matches pattern - (define (process-match input pattern seen-segment?) + (define (process-match input pattern seen-segment? el?) (cond ((symbol? pattern) (if (memq pattern subkeywords) `((,%compare ,input (,%rename (##core#syntax ,pattern)))) `())) - ((segment-pattern? pattern seen-segment?) - (process-segment-match input pattern)) + ((segment-pattern? pattern seen-segment? el?) + (process-segment-match input pattern el?)) ((pair? pattern) `((,%let ((,%temp ,input)) (,%and (,%pair? ,%temp) - ,@(process-match `(,%car ,%temp) (car pattern) #f) - ,@(process-match `(,%cdr ,%temp) (cdr pattern) #f))))) + ,@(process-match `(,%car ,%temp) (car pattern) #f el?) + ,@(process-match `(,%cdr ,%temp) (cdr pattern) #f el?))))) ((vector? pattern) `((,%let ((,%temp ,input)) (,%and (,%vector? ,%temp) ,@(process-match `(,%vector->list ,%temp) - (vector->list pattern) #f))))) + (vector->list pattern) #f el?))))) ((or (null? pattern) (boolean? pattern) (char? pattern)) `((,%eq? ,input ',pattern))) (else `((,%equal? ,input ',pattern))))) - (define (process-segment-match input pattern) - (let ((conjuncts (process-match `(,%car ,%l) (car pattern) #f))) + (define (process-segment-match input pattern el?) + (let ((conjuncts (process-match `(,%car ,%l) (car pattern) #f el?))) `((,%and (,%list? ,input) ; Can't ask for its length if not a proper list (,%let ((,%len (,%length ,input))) (,%and (,%>= ,%len ,(length (cddr pattern))) @@ -159,7 +160,7 @@ (,%len ,%len)) (,%cond ((,%= ,%len ,(length (cddr pattern))) - ,@(process-match %l (cddr pattern) #t)) + ,@(process-match %l (cddr pattern) #t el?)) (,%else (,%and ,@conjuncts (,%loop (,%cdr ,%l) (,%+ ,%len -1)))))))))))) @@ -167,12 +168,12 @@ ;; Generate code to take apart the input expression ;; This is pretty bad, but it seems to work (can't say why). - (define (process-pattern pattern path mapit seen-segment?) + (define (process-pattern pattern path mapit seen-segment? el?) (cond ((symbol? pattern) (if (memq pattern subkeywords) '() (list (list pattern (mapit path))))) - ((segment-pattern? pattern seen-segment?) + ((segment-pattern? pattern seen-segment? el?) (let* ((tail-length (length (cddr pattern))) (%match (if (zero? tail-length) ; Simple segment? path ; No list traversing overhead at runtime! @@ -185,20 +186,21 @@ (if (eq? %temp x) %match ; Optimization: no map+lambda `(,%map1 (,%lambda (,%temp) ,x) ,%match)))) - #f) + #f el?) (process-pattern (cddr pattern) - `(##sys#take-right ,path ,tail-length) mapit #t)))) + `(##sys#take-right ,path ,tail-length) + mapit #t el?)))) ((pair? pattern) - (append (process-pattern (car pattern) `(,%car ,path) mapit #f) - (process-pattern (cdr pattern) `(,%cdr ,path) mapit #f))) + (append (process-pattern (car pattern) `(,%car ,path) mapit #f el?) + (process-pattern (cdr pattern) `(,%cdr ,path) mapit #f el?))) ((vector? pattern) (process-pattern (vector->list pattern) - `(,%vector->list ,path) mapit #f)) + `(,%vector->list ,path) mapit #f el?)) (else '()))) ;; Generate code to compose the output expression according to template - (define (process-template template dim env) + (define (process-template template dim el? env) (cond ((symbol? template) (let ((probe (assq template env))) (if probe @@ -207,16 +209,19 @@ (##sys#syntax-error-hook "template dimension error (too few ellipses?)" template)) `(,%rename (##core#syntax ,template))))) - ((segment-template? template) - (let* ((depth (segment-depth template)) + ((ellipsis-escaped-pattern? template el?) + (if (or (not (pair? (cdr template))) (pair? (cddr template))) + (##sys#syntax-error-hook + "Invalid escaped ellipsis template" template) + (process-template (cadr template) dim (lambda _ #f) env))) + ((segment-template? template el?) + (let* ((depth (segment-depth template el?)) (seg-dim (+ dim depth)) (vars - (free-meta-variables (car template) seg-dim env '()))) + (free-meta-variables (car template) seg-dim el? env '()))) (if (null? vars) (##sys#syntax-error-hook "too many ellipses" template) - (let* ((x (process-template (car template) - seg-dim - env)) + (let* ((x (process-template (car template) seg-dim el? env)) (gen (if (and (pair? vars) (null? (cdr vars)) (symbol? x) @@ -227,62 +232,65 @@ (gen (do ((d depth (- d 1)) (gen gen `(,%apply ,%append ,gen))) ((= d 1) - gen)))) - (if (null? (segment-tail template)) + gen))) + (tail (segment-tail template el?))) + (if (null? tail) gen ;+++ - `(,%append ,gen ,(process-template (segment-tail template) - dim env))))))) + `(,%append ,gen ,(process-template tail dim el? env))))))) ((pair? template) - `(,%cons ,(process-template (car template) dim env) - ,(process-template (cdr template) dim env))) + `(,%cons ,(process-template (car template) dim el? env) + ,(process-template (cdr template) dim el? env))) ((vector? template) `(,%list->vector - ,(process-template (vector->list template) dim env))) + ,(process-template (vector->list template) dim el? env))) (else `(,%quote ,template)))) ;; Return an association list of (var . dim) - (define (meta-variables pattern dim vars seen-segment?) + (define (meta-variables pattern dim el? vars seen-segment?) (cond ((symbol? pattern) (if (memq pattern subkeywords) vars (cons (cons pattern dim) vars))) - ((segment-pattern? pattern seen-segment?) - (meta-variables (car pattern) (+ dim 1) - (meta-variables (cddr pattern) dim vars #t) #f)) + ((segment-pattern? pattern seen-segment? el?) + (meta-variables (car pattern) (+ dim 1) el? + (meta-variables (cddr pattern) dim el? vars #t) #f)) ((pair? pattern) - (meta-variables (car pattern) dim - (meta-variables (cdr pattern) dim vars #f) #f)) + (meta-variables (car pattern) dim el? + (meta-variables (cdr pattern) dim el? vars #f) #f)) ((vector? pattern) - (meta-variables (vector->list pattern) dim vars #f)) + (meta-variables (vector->list pattern) dim el? vars #f)) (else vars))) ;; Return a list of meta-variables of given higher dim - (define (free-meta-variables template dim env free) + (define (free-meta-variables template dim el? env free) (cond ((symbol? template) (if (and (not (memq template free)) (let ((probe (assq template env))) (and probe (>= (cdr probe) dim)))) (cons template free) free)) - ((segment-template? template) + ((segment-template? template el?) (free-meta-variables (car template) - dim env + dim el? env (free-meta-variables (cddr template) - dim env free))) + dim el? env free))) ((pair? template) (free-meta-variables (car template) - dim env + dim el? env (free-meta-variables (cdr template) - dim env free))) + dim el? env free))) ((vector? template) - (free-meta-variables (vector->list template) dim env free)) + (free-meta-variables (vector->list template) dim el? env free)) (else free))) - (define (segment-pattern? p seen-segment?) - (and (segment-template? p) + (define (ellipsis-escaped-pattern? pattern el?) + (and (pair? pattern) (el? (car pattern)))) + + (define (segment-pattern? p seen-segment? el?) + (and (segment-template? p el?) (cond (seen-segment? (##sys#syntax-error-hook "Only one segment per level is allowed" p)) @@ -290,24 +298,24 @@ (##sys#syntax-error-hook "Cannot combine dotted tail and ellipsis" p)) (else #t)))) - (define (segment-template? pattern) + (define (segment-template? pattern el?) (and (pair? pattern) (pair? (cdr pattern)) - (ellipsis? (cadr pattern)))) + (el? (cadr pattern)))) ;; Count the number of `...'s in PATTERN. - (define (segment-depth pattern) - (if (segment-template? pattern) - (+ 1 (segment-depth (cdr pattern))) + (define (segment-depth pattern el?) + (if (segment-template? pattern el?) + (+ 1 (segment-depth (cdr pattern) el?)) 0)) ;; Get whatever is after the `...'s in PATTERN. - (define (segment-tail pattern) + (define (segment-tail pattern el?) (let loop ((pattern (cdr pattern))) (if (and (pair? pattern) - (ellipsis? (car pattern))) + (el? (car pattern))) (loop (cdr pattern)) pattern))) -- 1.8.2.3