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

Merge branch 'master' into rspi 

Conflicts:
	src/read.c
This commit is contained in:
Sunrim KIM on Raspberry Pi 2014-07-27 18:51:12 +09:00
parent ebb2dd1d6e 28c486261c
commit 39a4a12a10
4 changed files with 41 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
piclib/picrin/test.scm
View File

@ -83,10 +83,4 @@
(syntax-rules ()
((_) (syntax-error "invalid use of test-syntax-error"))))
;; (define (test-read-error str)
;; (test-assert
;; (guard (exn (else #t))
;; (read (open-input-string str))
;; #f)))
(export test test-begin test-end test-values test-exit test-syntax-error))

2
src/read.c
View File

@ -668,6 +668,8 @@ read_nullable(pic_state *pic, struct pic_port *port, int c)
}
switch ((char)c) {
case ')':
read_error(pic, "unmatched parenthesis");
case ';':
return read_comment(pic, port, c);
case '#':

14
src/vm.c
View File

@ -495,14 +495,14 @@ vm_push_env(pic_state *pic)
}
static void
vm_tear_off(pic_state *pic)
vm_tear_off(pic_callinfo *ci)
{
struct pic_env *env;
int i;
assert(pic->ci->env != NULL);
assert(ci->env != NULL);
env = pic->ci->env;
env = ci->env;
if (env->regs == env->storage) {
return; /* is torn off */
@ -519,8 +519,8 @@ pic_vm_tear_off(pic_state *pic)
pic_callinfo *ci;
for (ci = pic->ci; ci > pic->cibase; ci--) {
if (pic->ci->env != NULL) {
vm_tear_off(pic);
if (ci->env != NULL) {
vm_tear_off(ci);
}
}
}
@ -844,7 +844,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
pic_callinfo *ci;
if (pic->ci->env != NULL) {
vm_tear_off(pic);
vm_tear_off(pic->ci);
}
if (c.u.i == -1) {
@ -870,7 +870,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
pic_callinfo *ci;
if (pic->ci->env != NULL) {
vm_tear_off(pic);
vm_tear_off(pic->ci);
}
pic->ci->retc = c.u.i;

58
t/r7rs-tests.scm
View File

@ -1627,10 +1627,10 @@
(test #t
(error-object? (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
;; (test "BOOM!"
;; (error-object-message (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
;; (test '(1 2 3)
;; (error-object-irritants (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
(test "BOOM!"
(error-object-message (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
(test '(1 2 3)
(error-object-irritants (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
(test #f
(file-error? (guard (exn (else exn)) (error "BOOM!"))))
@ -1737,30 +1737,30 @@
(test "reraised 0!" (get-output-string out))
(test 'zero value))
;; ;; From SRFI-34 "Examples" section - #8
;; (test 42
;; (guard (condition
;; ((assq 'a condition) => cdr)
;; ((assq 'b condition)))
;; (raise (list (cons 'a 42)))))
;; From SRFI-34 "Examples" section - #8
(test 42
(guard (condition
((assq 'a condition) => cdr)
((assq 'b condition)))
(raise (list (cons 'a 42)))))
;; ;; From SRFI-34 "Examples" section - #9
;; (test '(b . 23)
;; (guard (condition
;; ((assq 'a condition) => cdr)
;; ((assq 'b condition)))
;; (raise (list (cons 'b 23)))))
;; From SRFI-34 "Examples" section - #9
(test '(b . 23)
(guard (condition
((assq 'a condition) => cdr)
((assq 'b condition)))
(raise (list (cons 'b 23)))))
;; (test 'caught-d
;; (guard (condition
;; ((assq 'c condition) 'caught-c)
;; ((assq 'd condition) 'caught-d))
;; (list
;; (sqrt 8)
;; (guard (condition
;; ((assq 'a condition) => cdr)
;; ((assq 'b condition)))
;; (raise (list (cons 'd 24)))))))
(test 'caught-d
(guard (condition
((assq 'c condition) 'caught-c)
((assq 'd condition) 'caught-d))
(list
(sqrt 8)
(guard (condition
((assq 'a condition) => cdr)
((assq 'b condition)))
(raise (list (cons 'd 24)))))))
(test-end)
@ -2025,6 +2025,12 @@
(test '(a . c) (read (open-input-string "(a . #;b c)")))
(test '(a . b) (read (open-input-string "(a . b #;c)")))
;; (define (test-read-error str)
;; (test #t
;; (guard (exn (else #t))
;; (read (open-input-string str))
;; #f)))
;; (test-read-error "(#;a . b)")
;; (test-read-error "(a . #;b)")
;; (test-read-error "(a #;. b)")