Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 13:49:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge pull request #449 from Hamayama/syntax

Browse source 
Several changes of syntax-rules in init-7.scm
This commit is contained in:
Alex Shinn 2018-01-11 22:02:04 +09:00 • committed by GitHub
commit 08a6962c98
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
2 changed files with 52 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
lib/init-7.scm
View file

@ -728,18 +728,22 @@
_let (list (list v x)) _let (list (list v x))
(cond (cond
((identifier? p) ((identifier? p)
(if (memq p lits) (cond
((ellipsis-mark? p)
(error "bad ellipsis" p))
((memq p lits)
(list _and (list _and
(list _compare v (list _rename (list _quote p))) (list _compare v (list _rename (list _quote p)))
(k vars)))
((compare p _underscore)
(k vars)) (k vars))
(if (compare p _underscore) (else
(k vars)
(list _let (list (list p v)) (k (cons (cons p dim) vars)))))) (list _let (list (list p v)) (k (cons (cons p dim) vars))))))
((ellipsis? p) ((ellipsis? p)
(cond (cond
((not (null? (cdr (cdr p)))) ((not (null? (cdr (cdr p))))
(cond (cond
((any (lambda (x) (and (identifier? x) (compare x ellipsis))) ((any (lambda (x) (and (identifier? x) (ellipsis-mark? x)))
(cddr p)) (cddr p))
(error "multiple ellipses" p)) (error "multiple ellipses" p))
(else (else
@ -815,9 +819,17 @@
(lp (vector->list p) (list _vector->list v) dim vars k))) (lp (vector->list p) (list _vector->list v) dim vars k)))
((null? p) (list _and (list _null? v) (k vars))) ((null? p) (list _and (list _null? v) (k vars)))
(else (list _and (list _equal? v p) (k vars)))))))) (else (list _and (list _equal? v p) (k vars))))))))
(define (ellipsis-escape? x) (and (pair? x) (compare ellipsis (car x)))) (define ellipsis-mark?
(if (if ellipsis-specified?
(memq ellipsis lits)
(any (lambda (x) (compare ellipsis x)) lits))
(lambda (x) #f)
(if ellipsis-specified?
(lambda (x) (eq? ellipsis x))
(lambda (x) (compare ellipsis x)))))
(define (ellipsis-escape? x) (and (pair? x) (ellipsis-mark? (car x))))
(define (ellipsis? x) (define (ellipsis? x)
(and (pair? x) (pair? (cdr x)) (compare ellipsis (cadr x)))) (and (pair? x) (pair? (cdr x)) (ellipsis-mark? (cadr x))))
(define (ellipsis-depth x) (define (ellipsis-depth x)
(if (ellipsis? x) (if (ellipsis? x)
(+ 1 (ellipsis-depth (cdr x))) (+ 1 (ellipsis-depth (cdr x)))
@ -915,16 +927,10 @@
(list (rename 'strip-syntactic-closures) _expr)) (list (rename 'strip-syntactic-closures) _expr))
#f))))))))) #f)))))))))
(define-syntax syntax-rules/aux
(er-macro-transformer syntax-rules-transformer))
(define-syntax syntax-rules (define-syntax syntax-rules
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(if (identifier? (cadr expr)) (syntax-rules-transformer expr rename compare))))
(list (rename 'let) (list (list (cadr expr) #t))
(cons (rename 'syntax-rules/aux) (cdr expr)))
(syntax-rules-transformer expr rename compare)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; additional syntax ;; additional syntax

29
tests/r7rs-tests.scm
View file

@ -565,6 +565,35 @@
(n z)))))) (n z))))))
(test 'bound-identifier=? (m k))) (test 'bound-identifier=? (m k)))
;; literal has priority to ellipsis (R7RS 4.3.2)
(let ()
(define-syntax elli-lit-1
(syntax-rules ... (...)
((_ x)
'(x ...))))
(test '(100 ...) (elli-lit-1 100)))
;; bad ellipsis
#|
(test 'error
(guard (exn (else 'error))
(eval
'(define-syntax bad-elli-1
(syntax-rules ()
((_ ... x)
'(... x))))
(interaction-environment))))
(test 'error
(guard (exn (else 'error))
(eval
'(define-syntax bad-elli-2
(syntax-rules ()
((_ (... x))
'(... x))))
(interaction-environment))))
|#
(test-end) (test-end)
(test-begin "5 Program structure") (test-begin "5 Program structure")