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

fixing identifier comparison bugs

Browse source
This commit is contained in:
Derick Eddington 2009-12-06 21:34:30 -08:00
parent f969364176
commit 14c99c4729
3 changed files with 24 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
init.scm
View file

@ -124,11 +124,11 @@
(if (null? (cdr expr))
#f
((lambda (cl)
(if (compare 'else (car cl))
(if (compare (rename 'else) (car cl))
(if (pair? (cddr expr))
(error "non-final else in cond" expr)
(cons (rename 'begin) (cdr cl)))
(if (if (null? (cdr cl)) #t (compare '=> (cadr cl)))
(if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl)))
(list (list (rename 'lambda) (list (rename 'tmp))
(list (rename 'if) (rename 'tmp)
(if (null? (cdr cl))
@ -169,20 +169,20 @@
(cond
((pair? x)
(cond
((eq? 'unquote (car x))
((compare (rename 'unquote) (car x))
(if (<= d 0)
(cadr x)
(list (rename 'list) (list (rename 'quote) 'unquote)
(qq (cadr x) (- d 1)))))
((eq? 'unquote-splicing (car x))
((compare (rename 'unquote-splicing) (car x))
(if (<= d 0)
(list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
(list (rename 'list) (list (rename 'quote) 'unquote-splicing)
(qq (cadr x) (- d 1)))))
((eq? 'quasiquote (car x))
((compare (rename 'quasiquote) (car x))
(list (rename 'list) (list (rename 'quote) 'quasiquote)
(qq (cadr x) (+ d 1))))
((and (<= d 0) (pair? (car x)) (eq? 'unquote-splicing (caar x)))
((and (<= d 0) (pair? (car x)) (compare (rename 'unquote-splicing) (caar x)))
(if (null? (cdr x))
(cadar x)
(list (rename 'append) (cadar x) (qq (cdr x) d))))
@ -243,7 +243,7 @@
(define (clause ls)
(cond
((null? ls) #f)
((compare 'else (caar ls))
((compare (rename 'else) (caar ls))
`(,(rename 'begin) ,@(cdar ls)))
(else
(if (and (pair? (caar ls)) (null? (cdaar ls)))
@ -669,7 +669,7 @@
((null? p) (list _and (list _null? v) (k vars)))
(else (list _and (list _equal? v p) (k vars))))))))
(define (ellipse? x)
(and (pair? x) (pair? (cdr x)) (compare '... (cadr x))))
(and (pair? x) (pair? (cdr x)) (compare (rename '...) (cadr x))))
(define (ellipse-depth x)
(if (ellipse? x)
(+ 1 (ellipse-depth (cdr x)))

2
lib/chibi/loop/loop.scm
View file

@ -69,7 +69,7 @@
;; (er-macro-transformer
;; (lambda (expr rename compare)
;; (receive (named posns)
;; (partition (lambda (x) (and (list? x) (compare (car x) '=>)))
;; (partition (lambda (x) (and (list? x) (compare (car x) (rename '=>))))
;; (cdr expr))
;; (let lp ((ls '((arg default) ...)) (posns posns) (args '()))
;; (cond

15
tests/r5rs-tests.scm
View file

@ -386,6 +386,21 @@
(test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p))))
(test 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad))))
(test 'ok (let ((=> 1)) (cond (#t => 'ok))))
(test '(,foo) (let ((unquote 1)) `(,foo)))
(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo)))
(test 'ok
(let ((... 2))
(let-syntax ((s (syntax-rules ()
((_ x ...) 'bad)
((_ . r) 'ok))))
(s a b c))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(test-report)