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

Several changes of syntax-rules in init-7.scm

Browse source
This commit is contained in:
Hamayama 2017-12-30 09:46:51 +09:00
parent 3aeb753fd8
commit ae85ef2980
2 changed files with 52 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

40
lib/init-7.scm
View file

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

29
tests/r7rs-tests.scm
View file

@ -565,6 +565,35 @@
(n z))))))
(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-begin "5 Program structure")