conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fixes bug 181105: syntax pattern variable list length mismatch error 

is obscure
This commit is contained in:
Abdulaziz Ghuloum 2008-01-09 08:47:48 -05:00
parent 62765c2885
commit 4444496609
4 changed files with 160 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

2
scheme/last-revision
View File

@ -1 +1 @@
1334 1335

1
scheme/makefile.ss
View File

@ -1382,6 +1382,7 @@
[make-i/o-would-block-condition i] [make-i/o-would-block-condition i]
[i/o-would-block-condition? i] [i/o-would-block-condition? i]
[i/o-would-block-port i] [i/o-would-block-port i]
[ellipsis-map ]
)) ))
(define (macro-identifier? x) (define (macro-identifier? x)

301
scheme/psyntax.expander.ss
View File

@ -25,7 +25,7 @@
syntax-violation syntax-violation
syntax->datum make-variable-transformer syntax->datum make-variable-transformer
eval-r6rs-top-level boot-library-expand eval-top-level eval-r6rs-top-level boot-library-expand eval-top-level
null-environment scheme-report-environment) null-environment scheme-report-environment ellipsis-map)
(import (import
(except (rnrs) (except (rnrs)
environment environment? identifier? environment environment? identifier?
@ -2226,149 +2226,164 @@
(build-lambda no-source (list x) body) (build-lambda no-source (list x) body)
(list (chi-expr expr r mr))))))))))) (list (chi-expr expr r mr)))))))))))
(define syntax-transformer (define (ellipsis-map proc ls . ls*)
(let () (define who '...)
(define gen-syntax (unless (list? ls)
(lambda (src e r maps ellipsis? vec?) (assertion-violation who "not a list" ls))
(syntax-match e () (unless (null? ls*)
(dots (ellipsis? dots) (let ([n (length ls)])
(stx-error src "misplaced ellipsis in syntax form")) (for-each
(id (id? id) (lambda (x)
(let* ((label (id->label e)) (unless (list? x)
(b (label->binding label r))) (assertion-violation who "not a list" x))
(if (eq? (binding-type b) 'syntax) (unless (= (length x) n)
(let-values (((var maps) (assertion-violation who "length mismatch" ls x)))
(let ((var.lev (binding-value b))) ls*)))
(gen-ref src (car var.lev) (cdr var.lev) maps)))) (apply map proc ls ls*))
(values (list 'ref var) maps))
(values (list 'quote e) maps)))) (define syntax-transformer
((dots e) (ellipsis? dots) (let ()
(if vec? (define gen-syntax
(stx-error src "misplaced ellipsis in syntax form") (lambda (src e r maps ellipsis? vec?)
(gen-syntax src e r maps (lambda (x) #f) #f)))
((x dots . y) (ellipsis? dots)
(let f ((y y)
(k (lambda (maps)
(let-values (((x maps)
(gen-syntax src x r
(cons '() maps) ellipsis? #f)))
(if (null? (car maps))
(stx-error src
"extra ellipsis in syntax form")
(values (gen-map x (car maps)) (cdr maps)))))))
(syntax-match y ()
(() (k maps))
((dots . y) (ellipsis? dots)
(f y
(lambda (maps)
(let-values (((x maps) (k (cons '() maps))))
(if (null? (car maps))
(stx-error src "extra ellipsis in syntax form")
(values (gen-mappend x (car maps)) (cdr maps)))))))
(_
(let-values (((y maps)
(gen-syntax src y r maps ellipsis? vec?)))
(let-values (((x maps) (k maps)))
(values (gen-append x y) maps)))))))
((x . y)
(let-values (((xnew maps)
(gen-syntax src x r maps ellipsis? #f)))
(let-values (((ynew maps)
(gen-syntax src y r maps ellipsis? vec?)))
(values (gen-cons e x y xnew ynew) maps))))
(#(ls ...)
(let-values (((lsnew maps)
(gen-syntax src ls r maps ellipsis? #t)))
(values (gen-vector e ls lsnew) maps)))
(_ (values `(quote ,e) maps)))))
(define gen-ref
(lambda (src var level maps)
(if (= level 0)
(values var maps)
(if (null? maps)
(stx-error src "missing ellipsis in syntax form")
(let-values (((outer-var outer-maps)
(gen-ref src var (- level 1) (cdr maps))))
(cond
((assq outer-var (car maps)) =>
(lambda (b) (values (cdr b) maps)))
(else
(let ((inner-var (gen-lexical 'tmp)))
(values
inner-var
(cons
(cons (cons outer-var inner-var) (car maps))
outer-maps))))))))))
(define gen-append
(lambda (x y)
(if (equal? y '(quote ())) x `(append ,x ,y))))
(define gen-mappend
(lambda (e map-env)
`(apply (primitive append) ,(gen-map e map-env))))
(define gen-map
(lambda (e map-env)
(let ((formals (map cdr map-env))
(actuals (map (lambda (x) `(ref ,(car x))) map-env)))
(cond
; identity map equivalence:
; (map (lambda (x) x) y) == y
((eq? (car e) 'ref)
(car actuals))
; eta map equivalence:
; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
((for-all
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
(cdr e))
(let ((args (map (let ((r (map cons formals actuals)))
(lambda (x) (cdr (assq (cadr x) r))))
(cdr e))))
`(map (primitive ,(car e)) . ,args)))
(else (cons* 'map (list 'lambda formals e) actuals))))))
(define gen-cons
(lambda (e x y xnew ynew)
(case (car ynew)
((quote)
(if (eq? (car xnew) 'quote)
(let ((xnew (cadr xnew)) (ynew (cadr ynew)))
(if (and (eq? xnew x) (eq? ynew y))
`(quote ,e)
`(quote ,(cons xnew ynew))))
(if (null? (cadr ynew))
`(list ,xnew)
`(cons ,xnew ,ynew))))
((list) `(list ,xnew . ,(cdr ynew)))
(else `(cons ,xnew ,ynew)))))
(define gen-vector
(lambda (e ls lsnew)
(cond
((eq? (car lsnew) 'quote)
(if (eq? (cadr lsnew) ls)
`(quote ,e)
`(quote #(,@(cadr lsnew)))))
((eq? (car lsnew) 'list)
`(vector . ,(cdr lsnew)))
(else `(list->vector ,lsnew)))))
(define regen
(lambda (x)
(case (car x)
((ref) (build-lexical-reference no-source (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
((map)
(let ((ls (map regen (cdr x))))
(build-application no-source
(build-primref no-source 'map)
ls)))
(else
(build-application no-source
(build-primref no-source (car x))
(map regen (cdr x)))))))
(lambda (e r mr)
(syntax-match e () (syntax-match e ()
((_ x) (dots (ellipsis? dots)
(let-values (((e maps) (gen-syntax e x r '() ellipsis? #f))) (stx-error src "misplaced ellipsis in syntax form"))
(regen e))))))) (id (id? id)
(let* ((label (id->label e))
(b (label->binding label r)))
(if (eq? (binding-type b) 'syntax)
(let-values (((var maps)
(let ((var.lev (binding-value b)))
(gen-ref src (car var.lev) (cdr var.lev) maps))))
(values (list 'ref var) maps))
(values (list 'quote e) maps))))
((dots e) (ellipsis? dots)
(if vec?
(stx-error src "misplaced ellipsis in syntax form")
(gen-syntax src e r maps (lambda (x) #f) #f)))
((x dots . y) (ellipsis? dots)
(let f ((y y)
(k (lambda (maps)
(let-values (((x maps)
(gen-syntax src x r
(cons '() maps) ellipsis? #f)))
(if (null? (car maps))
(stx-error src
"extra ellipsis in syntax form")
(values (gen-map x (car maps)) (cdr maps)))))))
(syntax-match y ()
(() (k maps))
((dots . y) (ellipsis? dots)
(f y
(lambda (maps)
(let-values (((x maps) (k (cons '() maps))))
(if (null? (car maps))
(stx-error src "extra ellipsis in syntax form")
(values (gen-mappend x (car maps)) (cdr maps)))))))
(_
(let-values (((y maps)
(gen-syntax src y r maps ellipsis? vec?)))
(let-values (((x maps) (k maps)))
(values (gen-append x y) maps)))))))
((x . y)
(let-values (((xnew maps)
(gen-syntax src x r maps ellipsis? #f)))
(let-values (((ynew maps)
(gen-syntax src y r maps ellipsis? vec?)))
(values (gen-cons e x y xnew ynew) maps))))
(#(ls ...)
(let-values (((lsnew maps)
(gen-syntax src ls r maps ellipsis? #t)))
(values (gen-vector e ls lsnew) maps)))
(_ (values `(quote ,e) maps)))))
(define gen-ref
(lambda (src var level maps)
(if (= level 0)
(values var maps)
(if (null? maps)
(stx-error src "missing ellipsis in syntax form")
(let-values (((outer-var outer-maps)
(gen-ref src var (- level 1) (cdr maps))))
(cond
((assq outer-var (car maps)) =>
(lambda (b) (values (cdr b) maps)))
(else
(let ((inner-var (gen-lexical 'tmp)))
(values
inner-var
(cons
(cons (cons outer-var inner-var) (car maps))
outer-maps))))))))))
(define gen-append
(lambda (x y)
(if (equal? y '(quote ())) x `(append ,x ,y))))
(define gen-mappend
(lambda (e map-env)
`(apply (primitive append) ,(gen-map e map-env))))
(define gen-map
(lambda (e map-env)
(let ((formals (map cdr map-env))
(actuals (map (lambda (x) `(ref ,(car x))) map-env)))
(cond
; identity map equivalence:
; (map (lambda (x) x) y) == y
((eq? (car e) 'ref)
(car actuals))
; eta map equivalence:
; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
((for-all
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
(cdr e))
(let ((args (map (let ((r (map cons formals actuals)))
(lambda (x) (cdr (assq (cadr x) r))))
(cdr e))))
`(map (primitive ,(car e)) . ,args)))
(else (cons* 'map (list 'lambda formals e) actuals))))))
(define gen-cons
(lambda (e x y xnew ynew)
(case (car ynew)
((quote)
(if (eq? (car xnew) 'quote)
(let ((xnew (cadr xnew)) (ynew (cadr ynew)))
(if (and (eq? xnew x) (eq? ynew y))
`(quote ,e)
`(quote ,(cons xnew ynew))))
(if (null? (cadr ynew))
`(list ,xnew)
`(cons ,xnew ,ynew))))
((list) `(list ,xnew . ,(cdr ynew)))
(else `(cons ,xnew ,ynew)))))
(define gen-vector
(lambda (e ls lsnew)
(cond
((eq? (car lsnew) 'quote)
(if (eq? (cadr lsnew) ls)
`(quote ,e)
`(quote #(,@(cadr lsnew)))))
((eq? (car lsnew) 'list)
`(vector . ,(cdr lsnew)))
(else `(list->vector ,lsnew)))))
(define regen
(lambda (x)
(case (car x)
((ref) (build-lexical-reference no-source (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
((map)
(let ((ls (map regen (cdr x))))
(build-application no-source
(build-primref no-source 'ellipsis-map)
ls)))
(else
(build-application no-source
(build-primref no-source (car x))
(map regen (cdr x)))))))
(lambda (e r mr)
(syntax-match e ()
((_ x)
(let-values (((e maps) (gen-syntax e x r '() ellipsis? #f)))
(regen e)))))))
(define core-macro-transformer (define core-macro-transformer
(lambda (name) (lambda (name)