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

fixes bug 173369: errors are supposed to be &assertion

This commit is contained in:
Abdulaziz Ghuloum 2007-12-15 08:22:49 -05:00
parent d6efe68274
commit 8c0563b2d3
44 changed files with 1592 additions and 1587 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
scheme/ikarus.apply.ss
View File

@ -25,8 +25,8 @@
(let ()
(define (err f ls)
(if (procedure? f)
(error 'apply "not a list" ls)
(error 'apply "not a procedure" f)))
(die 'apply "not a list" ls)
(die 'apply "not a procedure" f)))
(define (fixandgo f a0 a1 ls p d)
(cond
[(null? ($cdr d))

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

326
scheme/ikarus.bytevectors.ss
View File

@ -88,18 +88,18 @@
[(k)
(if (and (fixnum? k) ($fx>= k 0))
($make-bytevector k)
(error 'make-bytevector "not a valid size" k))]
(die 'make-bytevector "not a valid size" k))]
[(k fill)
(if (and (fixnum? fill) ($fx<= -128 fill) ($fx<= fill 255))
($bytevector-fill (make-bytevector k) 0 k fill)
(error 'make-bytevector "not a valid fill" fill))]))
(die 'make-bytevector "not a valid fill" fill))]))
(define bytevector-fill!
(lambda (x fill)
(unless (bytevector? x)
(error 'bytevector-fill! "not a bytevector" x))
(die 'bytevector-fill! "not a bytevector" x))
(unless (and (fixnum? fill) ($fx<= -128 fill) ($fx<= fill 255))
(error 'bytevector-fill! "not a valid fill" fill))
(die 'bytevector-fill! "not a valid fill" fill))
($bytevector-fill x 0 ($bytevector-length x) fill)))
@ -107,23 +107,23 @@
(lambda (x)
(if (bytevector? x)
($bytevector-length x)
(error 'bytevector-length "not a bytevector" x))))
(die 'bytevector-length "not a bytevector" x))))
(define bytevector-s8-ref
(lambda (x i)
(if (bytevector? x)
(if (and (fixnum? i) ($fx<= 0 i) ($fx< i ($bytevector-length x)))
($bytevector-s8-ref x i)
(error 'bytevector-s8-ref "invalid index" i x))
(error 'bytevector-s8-ref "not a bytevector" x))))
(die 'bytevector-s8-ref "invalid index" i x))
(die 'bytevector-s8-ref "not a bytevector" x))))
(define bytevector-u8-ref
(lambda (x i)
(if (bytevector? x)
(if (and (fixnum? i) ($fx<= 0 i) ($fx< i ($bytevector-length x)))
($bytevector-u8-ref x i)
(error 'bytevector-u8-ref "invalid index" i x))
(error 'bytevector-u8-ref "not a bytevector" x))))
(die 'bytevector-u8-ref "invalid index" i x))
(die 'bytevector-u8-ref "not a bytevector" x))))
(define bytevector-s8-set!
@ -132,9 +132,9 @@
(if (and (fixnum? i) ($fx<= 0 i) ($fx< i ($bytevector-length x)))
(if (and (fixnum? v) ($fx<= -128 v) ($fx<= v 127))
($bytevector-set! x i v)
(error 'bytevector-s8-set! "not a byte" v))
(error 'bytevector-s8-set! "invalid index" i x))
(error 'bytevector-s8-set! "not a bytevector" x))))
(die 'bytevector-s8-set! "not a byte" v))
(die 'bytevector-s8-set! "invalid index" i x))
(die 'bytevector-s8-set! "not a bytevector" x))))
(define bytevector-u8-set!
(lambda (x i v)
@ -142,9 +142,9 @@
(if (and (fixnum? i) ($fx<= 0 i) ($fx< i ($bytevector-length x)))
(if (and (fixnum? v) ($fx<= 0 v) ($fx<= v 255))
($bytevector-set! x i v)
(error 'bytevector-u8-set! "not an octet" v))
(error 'bytevector-u8-set! "invalid index" i x))
(error 'bytevector-u8-set! "not a bytevector" x))))
(die 'bytevector-u8-set! "not an octet" v))
(die 'bytevector-u8-set! "invalid index" i x))
(die 'bytevector-u8-set! "not a bytevector" x))))
(define bytevector-u16-native-ref ;;; HARDCODED
(lambda (x i)
@ -156,8 +156,8 @@
($fxlogor
($fxsll ($bytevector-u8-ref x i) 8)
($bytevector-u8-ref x ($fxadd1 i)))
(error 'bytevector-u16-native-ref "invalid index" i))
(error 'bytevector-u16-native-ref "not a bytevector" x))))
(die 'bytevector-u16-native-ref "invalid index" i))
(die 'bytevector-u16-native-ref "not a bytevector" x))))
(define bytevector-u16-native-set! ;;; HARDCODED
@ -173,9 +173,9 @@
(begin
($bytevector-set! x i ($fxsra n 8))
($bytevector-set! x ($fxadd1 i) n))
(error 'bytevector-u16-native-set! "invalid index" i))
(error 'bytevector-u16-native-set! "invalid value" n))
(error 'bytevector-u16-native-set! "not a bytevector" x))))
(die 'bytevector-u16-native-set! "invalid index" i))
(die 'bytevector-u16-native-set! "invalid value" n))
(die 'bytevector-u16-native-set! "not a bytevector" x))))
(define bytevector-s16-native-set! ;;; HARDCODED
(lambda (x i n)
@ -190,9 +190,9 @@
(begin
($bytevector-set! x i ($fxsra n 8))
($bytevector-set! x ($fxadd1 i) n))
(error 'bytevector-s16-native-set! "invalid index" i))
(error 'bytevector-s16-native-set! "invalid value" n))
(error 'bytevector-s16-native-set! "not a bytevector" x))))
(die 'bytevector-s16-native-set! "invalid index" i))
(die 'bytevector-s16-native-set! "invalid value" n))
(die 'bytevector-s16-native-set! "not a bytevector" x))))
(define bytevector-s16-native-ref ;;; HARDCODED
(lambda (x i)
@ -204,8 +204,8 @@
($fxlogor
($fxsll ($bytevector-s8-ref x i) 8)
($bytevector-u8-ref x ($fxadd1 i)))
(error 'bytevector-s16-native-ref "invalid index" i))
(error 'bytevector-s16-native-ref "not a bytevector" x))))
(die 'bytevector-s16-native-ref "invalid index" i))
(die 'bytevector-s16-native-ref "not a bytevector" x))))
(define bytevector-u16-ref
(lambda (x i end)
@ -222,9 +222,9 @@
($fxlogor
($fxsll ($bytevector-u8-ref x (fxadd1 i)) 8)
($bytevector-u8-ref x i))]
[else (error 'bytevector-u16-ref "invalid endianness" end)])
(error 'bytevector-u16-ref "invalid index" i))
(error 'bytevector-u16-ref "not a bytevector" x))))
[else (die 'bytevector-u16-ref "invalid endianness" end)])
(die 'bytevector-u16-ref "invalid index" i))
(die 'bytevector-u16-ref "not a bytevector" x))))
(define bytevector-u32-ref
(lambda (x i end)
@ -247,9 +247,9 @@
($fxlogor
($fxsll ($bytevector-u8-ref x ($fx+ i 1)) 8)
($bytevector-u8-ref x i))))]
[else (error 'bytevector-u32-ref "invalid endianness" end)])
(error 'bytevector-u32-ref "invalid index" i))
(error 'bytevector-u32-ref "not a bytevector" x))))
[else (die 'bytevector-u32-ref "invalid endianness" end)])
(die 'bytevector-u32-ref "invalid index" i))
(die 'bytevector-u32-ref "not a bytevector" x))))
(define bytevector-u32-native-ref
(lambda (x i)
@ -264,8 +264,8 @@
($fxlogor
($fxsll ($bytevector-u8-ref x ($fx+ i 2)) 8)
($bytevector-u8-ref x ($fx+ i 3)))))
(error 'bytevector-u32-native-ref "invalid index" i))
(error 'bytevector-u32-native-ref "not a bytevector" x))))
(die 'bytevector-u32-native-ref "invalid index" i))
(die 'bytevector-u32-native-ref "not a bytevector" x))))
(define bytevector-s32-ref
(lambda (x i end)
@ -288,9 +288,9 @@
($fxlogor
($fxsll ($bytevector-u8-ref x ($fx+ i 1)) 8)
($bytevector-u8-ref x i))))]
[else (error 'bytevector-s32-ref "invalid endianness" end)])
(error 'bytevector-s32-ref "invalid index" i))
(error 'bytevector-s32-ref "not a bytevector" x))))
[else (die 'bytevector-s32-ref "invalid endianness" end)])
(die 'bytevector-s32-ref "invalid index" i))
(die 'bytevector-s32-ref "not a bytevector" x))))
(define bytevector-s32-native-ref
(lambda (x i)
@ -305,8 +305,8 @@
($fxlogor
($fxsll ($bytevector-u8-ref x ($fx+ i 2)) 8)
($bytevector-u8-ref x ($fx+ i 3)))))
(error 'bytevector-s32-native-ref "invalid index" i))
(error 'bytevector-s32-native-ref "not a bytevector" x))))
(die 'bytevector-s32-native-ref "invalid index" i))
(die 'bytevector-s32-native-ref "not a bytevector" x))))
(define bytevector-u16-set!
(lambda (x i n end)
@ -324,10 +324,10 @@
[(little)
($bytevector-set! x i n)
($bytevector-set! x ($fxadd1 i) (fxsra n 8))]
[else (error 'bytevector-u16-ref "invalid endianness" end)])
(error 'bytevector-u16-set! "invalid index" i))
(error 'bytevector-u16-set! "invalid value" n))
(error 'bytevector-u16-set! "not a bytevector" x))))
[else (die 'bytevector-u16-ref "invalid endianness" end)])
(die 'bytevector-u16-set! "invalid index" i))
(die 'bytevector-u16-set! "invalid value" n))
(die 'bytevector-u16-set! "not a bytevector" x))))
(define bytevector-u32-set!
@ -356,10 +356,10 @@
(let ([b (bitwise-and n #xFFFF)])
($bytevector-set! x ($fx+ i 1) ($fxsra b 8))
($bytevector-set! x i b))]
[else (error 'bytevector-u32-ref "invalid endianness" end)])
(error 'bytevector-u32-set! "invalid index" i))
(error 'bytevector-u32-set! "invalid value" n))
(error 'bytevector-u32-set! "not a bytevector" x))))
[else (die 'bytevector-u32-ref "invalid endianness" end)])
(die 'bytevector-u32-set! "invalid index" i))
(die 'bytevector-u32-set! "invalid value" n))
(die 'bytevector-u32-set! "not a bytevector" x))))
(define bytevector-u32-native-set!
(lambda (x i n)
@ -380,9 +380,9 @@
(let ([b (bitwise-and n #xFFFF)])
($bytevector-set! x ($fx+ i 2) ($fxsra b 8))
($bytevector-set! x ($fx+ i 3) b)))
(error 'bytevector-u32-native-set! "invalid index" i))
(error 'bytevector-u32-native-set! "invalid value" n))
(error 'bytevector-u32-native-set! "not a bytevector" x))))
(die 'bytevector-u32-native-set! "invalid index" i))
(die 'bytevector-u32-native-set! "invalid value" n))
(die 'bytevector-u32-native-set! "not a bytevector" x))))
(define bytevector-s32-native-set!
@ -404,9 +404,9 @@
(let ([b (bitwise-and n #xFFFF)])
($bytevector-set! x ($fx+ i 2) ($fxsra b 8))
($bytevector-set! x ($fx+ i 3) b)))
(error 'bytevector-s32-native-set! "invalid index" i))
(error 'bytevector-s32-native-set! "invalid value" n))
(error 'bytevector-s32-native-set! "not a bytevector" x))))
(die 'bytevector-s32-native-set! "invalid index" i))
(die 'bytevector-s32-native-set! "invalid value" n))
(die 'bytevector-s32-native-set! "not a bytevector" x))))
(define bytevector-s32-set!
(lambda (x i n end)
@ -434,10 +434,10 @@
(let ([b (bitwise-and n #xFFFF)])
($bytevector-set! x ($fx+ i 1) ($fxsra b 8))
($bytevector-set! x i b))]
[else (error 'bytevector-s32-ref "invalid endianness" end)])
(error 'bytevector-s32-set! "invalid index" i))
(error 'bytevector-s32-set! "invalid value" n))
(error 'bytevector-s32-set! "not a bytevector" x))))
[else (die 'bytevector-s32-ref "invalid endianness" end)])
(die 'bytevector-s32-set! "invalid index" i))
(die 'bytevector-s32-set! "invalid value" n))
(die 'bytevector-s32-set! "not a bytevector" x))))
(define bytevector-s16-ref
(lambda (x i end)
@ -454,9 +454,9 @@
($fxlogor
($fxsll ($bytevector-s8-ref x (fxadd1 i)) 8)
($bytevector-u8-ref x i))]
[else (error 'bytevector-s16-ref "invalid endianness" end)])
(error 'bytevector-s16-ref "invalid index" i))
(error 'bytevector-s16-ref "not a bytevector" x))))
[else (die 'bytevector-s16-ref "invalid endianness" end)])
(die 'bytevector-s16-ref "invalid index" i))
(die 'bytevector-s16-ref "not a bytevector" x))))
(define bytevector-s16-set!
(lambda (x i n end)
@ -474,15 +474,15 @@
[(little)
($bytevector-set! x i n)
($bytevector-set! x ($fxadd1 i) (fxsra n 8))]
[else (error 'bytevector-s16-ref "invalid endianness" end)])
(error 'bytevector-s16-set! "invalid index" i))
(error 'bytevector-s16-set! "invalid value" n))
(error 'bytevector-s16-set! "not a bytevector" x))))
[else (die 'bytevector-s16-ref "invalid endianness" end)])
(die 'bytevector-s16-set! "invalid index" i))
(die 'bytevector-s16-set! "invalid value" n))
(die 'bytevector-s16-set! "not a bytevector" x))))
(define bytevector->u8-list
(lambda (x)
(unless (bytevector? x)
(error 'bytevector->u8-list "not a bytevector" x))
(die 'bytevector->u8-list "not a bytevector" x))
(let f ([x x] [i ($bytevector-length x)] [ac '()])
(cond
[($fx= i 0) ac]
@ -498,13 +498,13 @@
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'u8-list->bytevector "circular list" ls))
(die 'u8-list->bytevector "circular list" ls))
(if (null? h)
($fx+ n 1)
(error 'u8-list->bytevector "not a proper list" ls))))
(die 'u8-list->bytevector "not a proper list" ls))))
(if (null? h)
n
(error 'u8-list->bytevector "not a proper list" ls))))]
(die 'u8-list->bytevector "not a proper list" ls))))]
[fill
(lambda (s i ls)
(cond
@ -512,7 +512,7 @@
[else
(let ([c ($car ls)])
(unless (and (fixnum? c) ($fx<= 0 c) ($fx<= c 255))
(error 'u8-list->bytevector "not an octet" c))
(die 'u8-list->bytevector "not an octet" c))
($bytevector-set! s i c)
(fill s ($fxadd1 i) (cdr ls)))]))])
(lambda (ls)
@ -523,7 +523,7 @@
(define bytevector-copy
(lambda (src)
(unless (bytevector? src)
(error 'bytevector-copy "not a bytevector" src))
(die 'bytevector-copy "not a bytevector" src))
(let ([n ($bytevector-length src)])
(let f ([src src] [dst ($make-bytevector n)] [i 0] [n n])
(cond
@ -535,9 +535,9 @@
(define bytevector=?
(lambda (x y)
(unless (bytevector? x)
(error 'bytevector=? "not a bytevector" x))
(die 'bytevector=? "not a bytevector" x))
(unless (bytevector? y)
(error 'bytevector=? "not a bytevector" y))
(die 'bytevector=? "not a bytevector" y))
(let ([n ($bytevector-length x)])
(and ($fx= n ($bytevector-length y))
(let f ([x x] [y y] [i 0] [n n])
@ -550,21 +550,21 @@
(lambda (src src-start dst dst-start k)
(cond
[(or (not (fixnum? src-start)) ($fx< src-start 0))
(error 'bytevector-copy! "not a valid starting index" src-start)]
(die 'bytevector-copy! "not a valid starting index" src-start)]
[(or (not (fixnum? dst-start)) ($fx< dst-start 0))
(error 'bytevector-copy! "not a valid starting index" dst-start)]
(die 'bytevector-copy! "not a valid starting index" dst-start)]
[(or (not (fixnum? k)) ($fx< k 0))
(error 'bytevector-copy! "not a valid length" k)]
(die 'bytevector-copy! "not a valid length" k)]
[(not (bytevector? src))
(error 'bytevector-copy! "not a bytevector" src)]
(die 'bytevector-copy! "not a bytevector" src)]
[(not (bytevector? dst))
(error 'bytevector-copy! "not a bytevector" dst)]
(die 'bytevector-copy! "not a bytevector" dst)]
[(let ([n ($fx+ src-start k)])
(or ($fx< n 0) ($fx> n ($bytevector-length src))))
(error 'bytevector-copy! "out of range" src-start k)]
(die 'bytevector-copy! "out of range" src-start k)]
[(let ([n ($fx+ dst-start k)])
(or ($fx< n 0) ($fx> n ($bytevector-length dst))))
(error 'bytevector-copy! "out of range" dst-start k)]
(die 'bytevector-copy! "out of range" dst-start k)]
[(eq? src dst)
(cond
[($fx< dst-start src-start)
@ -672,33 +672,33 @@
(define bytevector-sint-ref
(lambda (x k endianness size)
(define who 'bytevector-sint-ref)
(unless (bytevector? x) (error who "not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (error who "invalid index" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size" size))
(unless (bytevector? x) (die who "not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (die who "invalid index" k))
(unless (and (fixnum? size) ($fx>= size 1)) (die who "invalid size" size))
(let ([n ($bytevector-length x)])
(unless ($fx< k n) (error who "index is out of range" k))
(unless ($fx< k n) (die who "index is out of range" k))
(let ([end ($fx+ k size)])
(unless (and ($fx>= end 0) ($fx<= end n))
(error who "out of range" k size))
(die who "out of range" k size))
(case endianness
[(little) (sref-little x k end)]
[(big) (sref-big x k end)]
[else (error who "invalid endianness" endianness)])))))
[else (die who "invalid endianness" endianness)])))))
(define bytevector-uint-ref
(lambda (x k endianness size)
(define who 'bytevector-uint-ref)
(unless (bytevector? x) (error who "not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (error who "invalid index" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size" size))
(unless (bytevector? x) (die who "not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (die who "invalid index" k))
(unless (and (fixnum? size) ($fx>= size 1)) (die who "invalid size" size))
(let ([n ($bytevector-length x)])
(unless ($fx< k n) (error who "index is out of range" k))
(unless ($fx< k n) (die who "index is out of range" k))
(let ([end ($fx+ k size)])
(unless (and ($fx>= end 0) ($fx<= end n))
(error who "out of range" k size))
(die who "out of range" k size))
(case endianness
[(little) (uref-little x k end)]
[(big) (uref-big x k end)]
[else (error who "invalid endianness" endianness)])))))
[else (die who "invalid endianness" endianness)])))))
(define (bytevector->some-list x k n ls proc who)
(cond
[($fx= n 0) ls]
@ -708,36 +708,36 @@
[($fx>= i 0)
(bytevector->some-list x k i (cons (proc x i n) ls) proc who)]
[else
(error who "invalid size" k)]))]))
(die who "invalid size" k)]))]))
(define bytevector->uint-list
(lambda (x endianness size)
(define who 'bytevector->uint-list)
(unless (bytevector? x) (error who "not a bytevector" x))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size" size))
(unless (bytevector? x) (die who "not a bytevector" x))
(unless (and (fixnum? size) ($fx>= size 1)) (die who "invalid size" size))
(case endianness
[(little) (bytevector->some-list x size ($bytevector-length x)
'() uref-little 'bytevector->uint-list)]
[(big) (bytevector->some-list x size ($bytevector-length x)
'() uref-big 'bytevector->uint-list)]
[else (error who "invalid endianness" endianness)])))
[else (die who "invalid endianness" endianness)])))
(define bytevector->sint-list
(lambda (x endianness size)
(define who 'bytevector->sint-list)
(unless (bytevector? x) (error who "not a bytevector" x))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size" size))
(unless (bytevector? x) (die who "not a bytevector" x))
(unless (and (fixnum? size) ($fx>= size 1)) (die who "invalid size" size))
(case endianness
[(little) (bytevector->some-list x size ($bytevector-length x)
'() sref-little 'bytevector->sint-list)]
[(big) (bytevector->some-list x size ($bytevector-length x)
'() sref-big 'bytevector->sint-list)]
[else (error who "invalid endianness" endianness)]))))
[else (die who "invalid endianness" endianness)]))))
(module (bytevector-uint-set! bytevector-sint-set!)
(define (lufx-set! x k1 n k2 who no)
(cond
[($fx= k1 k2)
(unless ($fxzero? n)
(error who "number does not fit" no))]
(die who "number does not fit" no))]
[else
(lufx-set! x ($fxadd1 k1) ($fxsra n 8) k2 who no)
($bytevector-set! x k1 ($fxlogand n 255))]))
@ -745,7 +745,7 @@
(cond
[($fx= k1 k2)
(unless ($fx= n -1) ;;; BUG: does not catch all errors
(error who "number does not fit" no))]
(die who "number does not fit" no))]
[else
(lsfx-set! x ($fxadd1 k1) ($fxsra n 8) k2 who no)
($bytevector-set! x k1 ($fxlogand n 255))]))
@ -753,7 +753,7 @@
(cond
[($fx= k1 k2)
(unless ($fxzero? n)
(error who "number does not fit" no))]
(die who "number does not fit" no))]
[else
(let ([k2 ($fxsub1 k2)])
(bufx-set! x k1 ($fxsra n 8) k2 who no)
@ -762,7 +762,7 @@
(cond
[($fx= k1 k2)
(unless ($fx= n -1)
(error who "number does not fit" no))]
(die who "number does not fit" no))]
[else
(let ([k2 ($fxsub1 k2)])
(bsfx-set! x k1 ($fxsra n 8) k2 who no)
@ -790,8 +790,8 @@
[(#x00) ;;; borrow is 0, last byte was positive
(if ($fx< xi xj)
(bv-neg-zero! x xi xj)
(error who "number does not fit" n))]
[else (error 'lbn-neg-copy! "BUG: not handled" c)])]
(die who "number does not fit" n))]
[else (die 'lbn-neg-copy! "BUG: not handled" c)])]
[else
(let ([c ($fx- ($fx+ 255 ($fxsra c 8)) ($bignum-byte-ref n ni))])
(lbn-neg-copy! x ($fxadd1 xi) n ($fxadd1 ni) xj nj c)
@ -807,8 +807,8 @@
[(#x00) ;;; borrow is 0, last byte was positive
(if ($fx< xi xj)
(bv-neg-zero! x xi xj)
(error who "number does not fit" n))]
[else (error 'bbn-neg-copy! "BUG: not handled" c)])]
(die who "number does not fit" n))]
[else (die 'bbn-neg-copy! "BUG: not handled" c)])]
[else
(let ([c ($fx- ($fx+ 255 ($fxsra c 8)) ($bignum-byte-ref n ni))]
[xj ($fxsub1 xj)])
@ -824,7 +824,7 @@
;;; last byte was positive
(bv-zero! x xi xj)]
[else
(error who "number does not fit" n)])]
(die who "number does not fit" n)])]
[else
(let ([c ($bignum-byte-ref n ni)])
(lbn-pos-copy! x ($fxadd1 xi) n ($fxadd1 ni) nj xj c)
@ -839,7 +839,7 @@
;;; last byte was positive
(bv-zero! x xi xj)]
[else
(error who "number does not fit" n)])]
(die who "number does not fit" n)])]
[else
(let ([c ($bignum-byte-ref n ni)]
[xj ($fxsub1 xj)])
@ -860,16 +860,16 @@
(if ($fxzero? ($bignum-byte-ref n i-3))
(let ([i-4 ($fxsub1 i-3)])
(if ($fxzero? ($bignum-byte-ref n i-4))
(error 'bignum-bytes "BUG: malformed bignum")
(die 'bignum-bytes "BUG: malformed bignum")
i-3))
i-2))
i-1))
i))))
(define (make-bytevector-uint-set! who)
(lambda (x k n endianness size)
(unless (bytevector? x) (error who "not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (error who "invalid index" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size" size))
(unless (bytevector? x) (die who "not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (die who "invalid index" k))
(unless (and (fixnum? size) ($fx>= size 1)) (die who "invalid size" size))
(case endianness
[(little)
(cond
@ -883,9 +883,9 @@
[($fx< sz size)
(lbn-copy! x k n 0 sz)
(bv-zero! x ($fx+ k sz) ($fx+ k size))]
[else (error who "number does not fit" n)]))
(error who "value must be positive" n))]
[else (error who "invalid value argument" n)])]
[else (die who "number does not fit" n)]))
(die who "value must be positive" n))]
[else (die who "invalid value argument" n)])]
[(big)
(cond
[(fixnum? n) (bufx-set! x k n ($fx+ k size) who n)]
@ -898,10 +898,10 @@
[($fx< sz size)
(bbn-copy! x ($fx+ k size) n 0 sz)
(bv-zero! x k ($fx+ k ($fx- size sz)))]
[else (error who "number does not fit" n)]))
(error who "value must be positive" n))]
[else (error who "invalid value argument" n)])]
[else (error who "invalid endianness" endianness)])))
[else (die who "number does not fit" n)]))
(die who "value must be positive" n))]
[else (die who "invalid value argument" n)])]
[else (die who "invalid endianness" endianness)])))
(define bytevector-uint-set! (make-bytevector-uint-set! 'bytevector-uint-set!))
(define (make-bytevector-sint-set! who)
(define bbn-neg-copy! (make-bbn-neg-copy! who))
@ -909,9 +909,9 @@
(define lbn-neg-copy! (make-lbn-neg-copy! who))
(define lbn-pos-copy! (make-lbn-pos-copy! who))
(lambda (x k n endianness size)
(unless (bytevector? x) (error who "not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (error who "invalid index" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size" size))
(unless (bytevector? x) (die who "not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (die who "invalid index" k))
(unless (and (fixnum? size) ($fx>= size 1)) (die who "invalid size" size))
(case endianness
[(little)
(cond
@ -922,13 +922,13 @@
(cond
[($fx<= sz size)
(lbn-pos-copy! x k n 0 size sz 255)]
[else (error who "number does not fit" n)]))
[else (die who "number does not fit" n)]))
(let ([sz (bignum-bytes n)])
(cond
[($fx<= sz size)
(lbn-neg-copy! x k n 0 size sz 256)]
[else (error who "number does not fit" n)])))]
[else (error who "invalid value argument" n)])]
[else (die who "number does not fit" n)])))]
[else (die who "invalid value argument" n)])]
[(big)
(cond
[(fixnum? n) (bsfx-set! x k n ($fx+ k size) who n)]
@ -938,14 +938,14 @@
(cond
[($fx<= sz size)
(bbn-pos-copy! x k n 0 size sz 255)]
[else (error who "number does not fit" n)]))
[else (die who "number does not fit" n)]))
(let ([sz (bignum-bytes n)])
(cond
[($fx<= sz size)
(bbn-neg-copy! x k n 0 size sz 256)]
[else (error who "number does not fit" n)])))]
[else (error who "invalid value argument" n)])]
[else (error who "invalid endianness" endianness)])))
[else (die who "number does not fit" n)])))]
[else (die who "invalid value argument" n)])]
[else (die who "invalid endianness" endianness)])))
(define bytevector-sint-set! (make-bytevector-sint-set! 'bytevector-sint-set!)))
(module (uint-list->bytevector sint-list->bytevector)
@ -961,15 +961,15 @@
(bv-set! bv idx a endianness size)
(bv-set! bv ($fx+ idx size) ($car h) endianness size)
bv)
(error who "circular list" ls))
(die who "circular list" ls))
(if (null? h)
(let ([bv (make-bytevector ($fx+ idx size))])
(bv-set! bv idx a endianness size)
bv)
(error who "not a proper list" ls))))
(die who "not a proper list" ls))))
(if (null? h)
(make-bytevector idx)
(error who "not a proper list" ls))))
(die who "not a proper list" ls))))
(lambda (ls endianness size)
(race ls ls ls 0 endianness size)))
(define uint-list->bytevector
@ -986,8 +986,8 @@
($fxzero? ($fxlogand i 7))
($fx< i ($bytevector-length bv)))
($bytevector-ieee-double-native-ref bv i)
(error 'bytevector-ieee-double-native-ref "invalid index" i))
(error 'bytevector-ieee-double-native-ref "not a bytevector" bv)))
(die 'bytevector-ieee-double-native-ref "invalid index" i))
(die 'bytevector-ieee-double-native-ref "not a bytevector" bv)))
(define (bytevector-ieee-single-native-ref bv i)
(if (bytevector? bv)
@ -996,8 +996,8 @@
($fxzero? ($fxlogand i 3))
($fx< i ($bytevector-length bv)))
($bytevector-ieee-single-native-ref bv i)
(error 'bytevector-ieee-single-native-ref "invalid index" i))
(error 'bytevector-ieee-single-native-ref "not a bytevector" bv)))
(die 'bytevector-ieee-single-native-ref "invalid index" i))
(die 'bytevector-ieee-single-native-ref "not a bytevector" bv)))
(define (bytevector-ieee-double-native-set! bv i x)
(if (bytevector? bv)
@ -1007,9 +1007,9 @@
($fx< i ($bytevector-length bv)))
(if (flonum? x)
($bytevector-ieee-double-native-set! bv i x)
(error 'bytevector-ieee-double-native-set! "not a flonum" x))
(error 'bytevector-ieee-double-native-set! "invalid index" i))
(error 'bytevector-ieee-double-native-set! "not a bytevector" bv)))
(die 'bytevector-ieee-double-native-set! "not a flonum" x))
(die 'bytevector-ieee-double-native-set! "invalid index" i))
(die 'bytevector-ieee-double-native-set! "not a bytevector" bv)))
(define (bytevector-ieee-single-native-set! bv i x)
(if (bytevector? bv)
@ -1019,9 +1019,9 @@
($fx< i ($bytevector-length bv)))
(if (flonum? x)
($bytevector-ieee-single-native-set! bv i x)
(error 'bytevector-ieee-single-native-set! "not a flonum" x))
(error 'bytevector-ieee-single-native-set! "invalid index" i))
(error 'bytevector-ieee-single-native-set! "not a bytevector" bv)))
(die 'bytevector-ieee-single-native-set! "not a flonum" x))
(die 'bytevector-ieee-single-native-set! "invalid index" i))
(die 'bytevector-ieee-single-native-set! "not a bytevector" bv)))
(define (bytevector-ieee-double-ref bv i endianness)
(if (bytevector? bv)
@ -1032,10 +1032,10 @@
(case endianness
[(little) ($bytevector-ieee-double-native-ref bv i)]
[(big) ($bytevector-ieee-double-nonnative-ref bv i)]
[else (error 'bytevector-ieee-double-ref
[else (die 'bytevector-ieee-double-ref
"invalid endianness" endianness)])
(error 'bytevector-ieee-double-ref "invalid index" i))
(error 'bytevector-ieee-double-ref "not a bytevector" bv)))
(die 'bytevector-ieee-double-ref "invalid index" i))
(die 'bytevector-ieee-double-ref "not a bytevector" bv)))
(define (bytevector-ieee-single-ref bv i endianness)
(if (bytevector? bv)
@ -1046,10 +1046,10 @@
(case endianness
[(little) ($bytevector-ieee-single-native-ref bv i)]
[(big) ($bytevector-ieee-single-nonnative-ref bv i)]
[else (error 'bytevector-ieee-single-ref
[else (die 'bytevector-ieee-single-ref
"invalid endianness" endianness)])
(error 'bytevector-ieee-single-ref "invalid index" i))
(error 'bytevector-ieee-single-ref "not a bytevector" bv)))
(die 'bytevector-ieee-single-ref "invalid index" i))
(die 'bytevector-ieee-single-ref "not a bytevector" bv)))
(define (bytevector-ieee-double-set! bv i x endianness)
(if (bytevector? bv)
@ -1061,11 +1061,11 @@
(case endianness
[(little) ($bytevector-ieee-double-native-set! bv i x)]
[(big) ($bytevector-ieee-double-nonnative-set! bv i x)]
[else (error 'bytevector-ieee-double-set!
[else (die 'bytevector-ieee-double-set!
"invalid endianness" endianness)])
(error 'bytevector-ieee-double-set! "not a flonum" x))
(error 'bytevector-ieee-double-set! "invalid index" i))
(error 'bytevector-ieee-double-set! "not a bytevector" bv)))
(die 'bytevector-ieee-double-set! "not a flonum" x))
(die 'bytevector-ieee-double-set! "invalid index" i))
(die 'bytevector-ieee-double-set! "not a bytevector" bv)))
(define (bytevector-ieee-single-set! bv i x endianness)
(if (bytevector? bv)
@ -1077,11 +1077,11 @@
(case endianness
[(little) ($bytevector-ieee-single-native-set! bv i x)]
[(big) ($bytevector-ieee-single-nonnative-set! bv i x)]
[else (error 'bytevector-ieee-single-set!
[else (die 'bytevector-ieee-single-set!
"invalid endianness" endianness)])
(error 'bytevector-ieee-single-set! "not a flonum" x))
(error 'bytevector-ieee-single-set! "invalid index" i))
(error 'bytevector-ieee-single-set! "not a bytevector" bv)))
(die 'bytevector-ieee-single-set! "not a flonum" x))
(die 'bytevector-ieee-single-set! "invalid index" i))
(die 'bytevector-ieee-single-set! "not a bytevector" bv)))
(define ($bytevector-ref/64 bv i who decoder endianness)
@ -1093,9 +1093,9 @@
(case endianness
[(little big)
(decoder bv i endianness 8)]
[else (error who "invalid endianness" endianness)])
(error who "invalid index" i))
(error who "not a bytevector" bv)))
[else (die who "invalid endianness" endianness)])
(die who "invalid index" i))
(die who "not a bytevector" bv)))
(define (bytevector-u64-native-ref bv i)
($bytevector-ref/64 bv i 'bytevector-u64-native-ref
@ -1119,17 +1119,17 @@
(case endianness
[(little big)
(unless (or (fixnum? n) (bignum? n))
(error who
(die who
(if (number? n)
"number is not exact"
"not a number")
n))
(unless (and (<= lo n) (< n hi))
(error who "number out of range" n))
(die who "number out of range" n))
(setter bv i n endianness 8)]
[else (error who "invalid endianness" endianness)])
(error who "invalid index" i))
(error who "not a bytevector" bv)))
[else (die who "invalid endianness" endianness)])
(die who "invalid index" i))
(die who "not a bytevector" bv)))
(define (bytevector-u64-native-set! bv i n)
($bytevector-set/64 bv i n 0 (expt 2 64)

6
scheme/ikarus.cafe.ss
View File

@ -31,8 +31,8 @@ description:
Input and output performed by the cafe can be changed by the
console-input-port and console-output-port parameters.
If an error occurs during reading, evaluating, or printing an
expression, then the error is printed to the error-port and the
If an die occurs during reading, evaluating, or printing an
expression, then the die is printed to the error-port and the
operations of the cafe resume as normal.|#
#|FIXME:new-cafe
Be specific about what the error-port is |#
@ -112,7 +112,7 @@ description:
[() (do-new-cafe default-cafe-eval)]
[(p)
(unless (procedure? p)
(error 'new-cafe "not a procedure" p))
(die 'new-cafe "not a procedure" p))
(do-new-cafe p)]))
)

20
scheme/ikarus.chars.ss
View File

@ -26,26 +26,26 @@
(define integer->char
(lambda (n)
(cond
[(not (fixnum? n)) (error 'integer->char "invalid argument" n)]
[($fx< n 0) (error 'integer->char "negative" n)]
[(not (fixnum? n)) (die 'integer->char "invalid argument" n)]
[($fx< n 0) (die 'integer->char "negative" n)]
[($fx<= n #xD7FF) ($fixnum->char n)]
[($fx< n #xE000)
(error 'integer->char "integer does not have a unicode representation" n)]
(die 'integer->char "integer does not have a unicode representation" n)]
[($fx<= n #x10FFFF) ($fixnum->char n)]
[else (error 'integer->char
[else (die 'integer->char
"integer does not have a unicode representation" n)])))
(define char->integer
(lambda (x)
(unless (char? x)
(error 'char->integer "not a character" x))
(die 'char->integer "not a character" x))
($char->fixnum x)))
;;; FIXME: this file is embarrasing
(define char=?
(let ()
(define (err x)
(error 'char=? "not a character" x))
(die 'char=? "not a character" x))
(case-lambda
[(c1 c2)
(if (char? c1)
@ -82,7 +82,7 @@
(define char<?
(let ()
(define (err x)
(error 'char<? "not a character" x))
(die 'char<? "not a character" x))
(case-lambda
[(c1 c2)
(if (char? c1)
@ -119,7 +119,7 @@
(define char<=?
(let ()
(define (err x)
(error 'char<=? "not a character" x))
(die 'char<=? "not a character" x))
(case-lambda
[(c1 c2)
(if (char? c1)
@ -156,7 +156,7 @@
(define char>?
(let ()
(define (err x)
(error 'char>? "not a character" x))
(die 'char>? "not a character" x))
(case-lambda
[(c1 c2)
(if (char? c1)
@ -193,7 +193,7 @@
(define char>=?
(let ()
(define (err x)
(error 'char>=? "not a character" x))
(die 'char>=? "not a character" x))
(case-lambda
[(c1 c2)
(if (char? c1)

32
scheme/ikarus.code-objects.ss
View File

@ -31,75 +31,75 @@
(define make-code
(lambda (code-size freevars)
(unless (and (fixnum? code-size) ($fx>= code-size 0))
(error 'make-code "not a valid code size" code-size))
(die 'make-code "not a valid code size" code-size))
(unless (and (fixnum? freevars) ($fx>= freevars 0))
(error 'make-code "not a valid number of free vars" freevars))
(die 'make-code "not a valid number of free vars" freevars))
(foreign-call "ikrt_make_code" code-size freevars '#())))
(define code-reloc-vector
(lambda (x)
(unless (code? x) (error 'code-reloc-vector "not a code" x))
(unless (code? x) (die 'code-reloc-vector "not a code" x))
($code-reloc-vector x)))
(define code-freevars
(lambda (x)
(unless (code? x) (error 'code-closure-size "not a code" x))
(unless (code? x) (die 'code-closure-size "not a code" x))
($code-freevars x)))
(define code-size
(lambda (x)
(unless (code? x) (error 'code-size "not a code" x))
(unless (code? x) (die 'code-size "not a code" x))
($code-size x)))
(define code-set!
(lambda (x i v)
(unless (code? x) (error 'code-set! "not a code" x))
(unless (code? x) (die 'code-set! "not a code" x))
(unless (and (fixnum? i)
($fx>= i 0)
($fx< i ($code-size x)))
(error 'code-set! "not a valid index" i))
(die 'code-set! "not a valid index" i))
(unless (and (fixnum? v)
($fx>= v 0)
($fx< v 256))
(error 'code-set! "not a valid byte" v))
(die 'code-set! "not a valid byte" v))
($code-set! x i v)))
(define code-ref
(lambda (x i)
(unless (code? x) (error 'code-ref "not a code" x))
(unless (code? x) (die 'code-ref "not a code" x))
(unless (and (fixnum? i)
($fx>= i 0)
($fx< i ($code-size x)))
(error 'code-ref "not a valid index" i))
(die 'code-ref "not a valid index" i))
($code-ref x i)))
(define set-code-reloc-vector!
(lambda (x v)
(unless (code? x)
(error 'set-code-reloc-vector! "not a code" x))
(die 'set-code-reloc-vector! "not a code" x))
(unless (vector? v)
(error 'set-code-reloc-vector! "not a vector" v))
(die 'set-code-reloc-vector! "not a vector" v))
(foreign-call "ikrt_set_code_reloc_vector" x v)))
(define set-code-annotation!
(lambda (x v)
(unless (code? x)
(error 'set-code-annotation! "not a code" x))
(die 'set-code-annotation! "not a code" x))
(foreign-call "ikrt_set_code_annotation" x v)))
(define code->thunk
(lambda (x)
(unless (code? x)
(error 'code->thunk "not a a code object" x))
(die 'code->thunk "not a a code object" x))
(unless ($fxzero? ($code-freevars x))
(error 'code->thunk "has free variables" x))
(die 'code->thunk "has free variables" x))
($code->closure x)))
(define (procedure-annotation x)
(if (procedure? x)
($code-annotation ($closure-code x))
(error 'procedure-annotation "not a procedure" x)))
(die 'procedure-annotation "not a procedure" x)))
)

20
scheme/ikarus.codecs.ss
View File

@ -61,17 +61,17 @@
(define (codec->fixnum x who)
(cond
[(assq x codec-alist) => cdr]
[else (error who "not a valid coded" x)]))
[else (die who "not a valid coded" x)]))
(define (eol-style->fixnum x who)
(cond
[(assq x eol-style-alist) => cdr]
[else (error who "not a valid eol-style" x)]))
[else (die who "not a valid eol-style" x)]))
(define (error-handling-mode->fixnum x who)
(cond
[(assq x error-handling-mode-alist) => cdr]
[else (error who "not a valid error-handling mode" x)]))
[else (die who "not a valid error-handling mode" x)]))
(define make-transcoder
(case-lambda
@ -94,24 +94,24 @@
(if (transcoder? x)
(let ([tag (fxlogand ($transcoder->data x) codec-mask)])
(or (rev-lookup tag codec-alist)
(error who "transcoder has no codec" x)))
(error who "not a transcoder" x)))
(die who "transcoder has no codec" x)))
(die who "not a transcoder" x)))
(define (transcoder-eol-style x)
(define who 'transcoder-eol-style)
(if (transcoder? x)
(let ([tag (fxlogand ($transcoder->data x) eol-style-mask)])
(or (rev-lookup tag eol-style-alist)
(error who "transcoder has no eol-style" x)))
(error who "not a transcoder" x)))
(die who "transcoder has no eol-style" x)))
(die who "not a transcoder" x)))
(define (transcoder-error-handling-mode x)
(define who 'transcoder-error-handling-mode)
(if (transcoder? x)
(let ([tag (fxlogand ($transcoder->data x) error-handling-mode-mask)])
(or (rev-lookup tag error-handling-mode-alist)
(error who "transcoder has no error-handling mode" x)))
(error who "not a transcoder" x)))
(die who "transcoder has no error-handling mode" x)))
(die who "not a transcoder" x)))
(define (buffer-mode? x)
(and (memq x '(none line block)) #t))
@ -133,7 +133,7 @@
(define (file-options-spec ls)
(unless (list? ls)
(error 'file-options-spec "not a list" ls))
(die 'file-options-spec "not a list" ls))
(let f ([ls ls] [n 0])
(cond
[(null? ls) (vector-ref file-options-vec n)]

2
scheme/ikarus.command-line.ss
View File

@ -26,6 +26,6 @@
(lambda (x)
(if (and (list? x) (andmap string? x))
x
(error 'command-list
(die 'command-list
"invalid command-line-arguments ~s\n" x))))))

22
scheme/ikarus.conditions.ss
View File

@ -148,7 +148,7 @@
[(x)
(if (condition? x)
x
(error 'condition "not a condition type" x))]
(die 'condition "not a condition type" x))]
[x*
(let ([ls
(let f ([x* x*])
@ -158,7 +158,7 @@
(cons (car x*) (f (cdr x*)))]
[(compound-condition? (car x*))
(append (simple-conditions (car x*)) (f (cdr x*)))]
[else (error 'condition "not a condition" (car x*))]))])
[else (die 'condition "not a condition" (car x*))]))])
(cond
[(null? ls) (make-compound-condition '())]
[(null? (cdr ls)) (car ls)]
@ -168,13 +168,13 @@
(cond
[(compound-condition? x) (compound-condition-components x)]
[(&condition? x) (list x)]
[else (error 'simple-conditions "not a condition" x)]))
[else (die 'simple-conditions "not a condition" x)]))
(define (condition-predicate rtd)
(unless (rtd? rtd)
(error 'condition-predicate "not a record type descriptor" rtd))
(die 'condition-predicate "not a record type descriptor" rtd))
(unless (rtd-subtype? rtd (record-type-descriptor &condition))
(error 'condition-predicate "not a descendant of &condition" rtd))
(die 'condition-predicate "not a descendant of &condition" rtd))
(let ([p? (record-predicate rtd)])
(lambda (x)
(or (p? x)
@ -186,11 +186,11 @@
(define (condition-accessor rtd proc)
(unless (rtd? rtd)
(error 'condition-accessor "not a record type descriptor" rtd))
(die 'condition-accessor "not a record type descriptor" rtd))
(unless (procedure? proc)
(error 'condition-accessor "not a procedure" proc))
(die 'condition-accessor "not a procedure" proc))
(unless (rtd-subtype? rtd (record-type-descriptor &condition))
(error 'condition-accessor "not a descendant of &condition" rtd))
(die 'condition-accessor "not a descendant of &condition" rtd))
(let ([p? (record-predicate rtd)])
(lambda (x)
(cond
@ -203,9 +203,9 @@
(proc (car ls))
(f (cdr ls)))]
[else
(error 'condition-accessor "not a condition of correct type" x rtd)]))]
(die 'condition-accessor "not a condition of correct type" x rtd)]))]
[else
(error 'condition-accessor "not a condition of correct type" x rtd)]))))
(die 'condition-accessor "not a condition of correct type" x rtd)]))))
(define-syntax define-condition-type
(lambda (x)
@ -381,7 +381,7 @@
[(x port)
(if (output-port? port)
(print-condition x port)
(error 'print-condition "not an output port" port))])))
(die 'print-condition "not an output port" port))])))
;(let ([p
; (lambda (x p)

12
scheme/ikarus.control.ss
View File

@ -32,7 +32,7 @@
(lambda (f)
(if (procedure? f)
(primitive-call/cf f)
(error 'call/cf "not a procedure" f))))
(die 'call/cf "not a procedure" f))))
(define primitive-call/cc
(lambda (f)
@ -92,7 +92,7 @@
(define call/cc
(lambda (f)
(unless (procedure? f)
(error 'call/cc "not a procedure" f))
(die 'call/cc "not a procedure" f))
(primitive-call/cc
(lambda (k)
(let ([save winders])
@ -106,18 +106,18 @@
(define call-with-current-continuation
(lambda (f)
(unless (procedure? f)
(error 'call-with-current-continuation
(die 'call-with-current-continuation
"not a procedure" f))
(call/cc f)))
(define dynamic-wind
(lambda (in body out)
(unless (procedure? in)
(error 'dynamic-wind "not a procedure" in))
(die 'dynamic-wind "not a procedure" in))
(unless (procedure? body)
(error 'dynamic-wind "not a procedure" body))
(die 'dynamic-wind "not a procedure" body))
(unless (procedure? out)
(error 'dynamic-wind "not a procedure" out))
(die 'dynamic-wind "not a procedure" out))
(in)
(set! winders (cons (cons in out) winders))
(call-with-values

40
scheme/ikarus.enumerations.ss
View File

@ -33,20 +33,20 @@
(define (make-enumeration ls)
(unless (and (list? ls) (for-all symbol? ls))
(error 'make-enumeration "~s is not a list of symbols" ls))
(die 'make-enumeration "~s is not a list of symbols" ls))
(make-enum (gensym) ls ls))
(define (enum-set-universe x)
(unless (enum? x)
(error 'enum-set-universe "~s is not an enumeration" x))
(die 'enum-set-universe "~s is not an enumeration" x))
(enum-univ x))
(define (enum-set-indexer x)
(unless (enum? x)
(error 'enum-set-indexer "~s is not an enumeration" x))
(die 'enum-set-indexer "~s is not an enumeration" x))
(lambda (s)
(unless (symbol? s)
(error 'enum-set-indexer "~s is not a symbol" s))
(die 'enum-set-indexer "~s is not a symbol" s))
(let f ([s s] [i 0] [ls (enum-univ x)])
(cond
[(pair? ls)
@ -57,15 +57,15 @@
(define (enum-set-constructor x)
(unless (enum? x)
(error 'enum-set-constructor "~s is not an enumeration" x))
(die 'enum-set-constructor "~s is not an enumeration" x))
(let ([idx (enum-set-indexer x)])
(lambda (ls)
(unless (and (list? ls) (for-all symbol? ls))
(error 'enum-set-constructor "~s is not a list of symbols" ls))
(die 'enum-set-constructor "~s is not a list of symbols" ls))
(for-each
(lambda (s)
(unless (memq s (enum-univ x))
(error 'enum-set-constructor "~s is not in the universe of ~s" s x)))
(die 'enum-set-constructor "~s is not in the universe of ~s" s x)))
ls)
(make-enum (enum-g x) (enum-univ x)
(map car
@ -75,7 +75,7 @@
(define (enum-set->list x)
(unless (enum? x)
(error 'enum-set->list "~s is not an enumeration" x))
(die 'enum-set->list "~s is not an enumeration" x))
(map values (enum-values x)))
(define (enum-set-member? s x)
@ -84,8 +84,8 @@
#t
(if (symbol? s)
#f
(error 'enum-set-member? "not a symbol" s)))
(error 'enum-set-member? "not an enumeration" x)))
(die 'enum-set-member? "not a symbol" s)))
(die 'enum-set-member? "not an enumeration" x)))
(define (enum-set-subset? x1 x2)
(define (subset? s1 s2)
@ -97,8 +97,8 @@
(and (subset? (enum-values x1) (enum-values x2))
(or (eq? (enum-g x1) (enum-g x2))
(subset? (enum-univ x1) (enum-univ x2))))
(error 'enum-set-subset? "not an enumeration" x2))
(error 'enum-set-subset? "not an enumeration" x1)))
(die 'enum-set-subset? "not an enumeration" x2))
(die 'enum-set-subset? "not an enumeration" x1)))
(define (enum-set=? x1 x2)
(define (subset? s1 s2)
@ -112,8 +112,8 @@
(or (eq? (enum-g x1) (enum-g x2))
(and (subset? (enum-univ x1) (enum-univ x2))
(subset? (enum-univ x2) (enum-univ x1)))))
(error 'enum-set=? "not an enumeration" x2))
(error 'enum-set=? "not an enumeration" x1)))
(die 'enum-set=? "not an enumeration" x2))
(die 'enum-set=? "not an enumeration" x1)))
(define (enum-set-op x1 x2 who combine)
(if (enum? x1)
@ -121,10 +121,10 @@
(let ([g (enum-g x1)] [u (enum-univ x1)])
(if (eq? g (enum-g x2))
(make-enum g u (combine u (enum-values x1) (enum-values x2)))
(error who
(die who
"enum sets have different enumeration types" x1 x2)))
(error who "not an enumeration" x2))
(error who "not an enumeration" x1)))
(die who "not an enumeration" x2))
(die who "not an enumeration" x1)))
(define (enum-set-union x1 x2)
(define (union u s1 s2)
@ -183,7 +183,7 @@
(if (enum? x)
(let ([g (enum-g x)] [u (enum-univ x)])
(make-enum g u (complement u (enum-values x))))
(error 'enum-set-complement "not an enumeration" x)))
(die 'enum-set-complement "not an enumeration" x)))
(define (enum-set-projection x1 x2)
(define (combine u s)
@ -202,8 +202,8 @@
(if (null? s)
(make-enum g u '())
(make-enum g u (combine u s))))))
(error 'enum-set-projection "not an enumeration" x2))
(error 'enum-set-projection "not an enumeration" x1)))
(die 'enum-set-projection "not an enumeration" x2))
(die 'enum-set-projection "not an enumeration" x1)))
)
#!eof

13
scheme/ikarus.exceptions.ss
View File

@ -16,14 +16,14 @@
(library (ikarus exceptions)
(export with-exception-handler raise raise-continuable
error assertion-violation)
error assertion-violation die)
(import
(only (rnrs) condition make-non-continuable-violation
make-message-condition make-error make-who-condition
make-irritants-condition make-assertion-violation)
(except (ikarus)
with-exception-handler raise raise-continuable
error assertion-violation))
error assertion-violation die))
(define handlers
(make-parameter
@ -35,10 +35,10 @@
(define (with-exception-handler handler proc2)
(unless (procedure? handler)
(error 'with-exception-handler
(assertion-violation 'with-exception-handler
"handler is not a procedure" handler))
(unless (procedure? proc2)
(error 'with-exception-handler "not a procedure" proc2))
(assertion-violation 'with-exception-handler "not a procedure" proc2))
(parameterize ([handlers (cons handler (handlers))])
(proc2)))
@ -60,7 +60,7 @@
(define (error who msg . irritants)
(unless (string? msg)
(error 'error "message is not a string" msg))
(assertion-violation 'error "message is not a string" msg))
(raise
(condition
(make-error)
@ -82,5 +82,8 @@
(condition)
(make-irritants-condition irritants)))))
(define die assertion-violation)
)

20
scheme/ikarus.fasl.ss
View File

@ -63,12 +63,12 @@
(define who 'fasl-read)
(define (assert-eq? x y)
(unless (eq? x y)
(error who
(die who
(format "Expected ~s, got ~s\n" y x))))
(define (char->int x)
(if (char? x)
(char->integer x)
(error who "unexpected eof inside a fasl object")))
(die who "unexpected eof inside a fasl object")))
(define (read-fixnum p)
(let ([c0 (char->int (read-char p))]
[c1 (char->int (read-char p))]
@ -115,7 +115,7 @@
(cond
[(fx< m (vector-length marks))
(when (vector-ref marks m)
(error 'fasl-read "mark set twice" m))
(die 'fasl-read "mark set twice" m))
(vector-set! marks m obj)]
[else
(let ([n (vector-length marks)])
@ -158,7 +158,7 @@
[(#\<)
(let ([cm (read-int p)])
(unless (fx< cm (vector-length marks))
(error who "invalid mark" m))
(die who "invalid mark" m))
(let ([code (vector-ref marks cm)])
(let ([proc ($code->closure code)])
(when m (put-mark m proc))
@ -168,10 +168,10 @@
(assert-eq? (read-char p) #\x)
(let ([code (read-code cm m)])
(if m (vector-ref marks m) ($code->closure code))))]
[else (error who "invalid code header" c)])))
[else (die who "invalid code header" c)])))
(define (read/mark m)
(define (nom)
(when m (error who "unhandled mark")))
(when m (die who "unhandled mark")))
(let ([h (read-char p)])
(case h
[(#\I)
@ -253,17 +253,17 @@
(cond
[(char? c) c]
[else
(error who "invalid eof inside a fasl object")]))]
(die who "invalid eof inside a fasl object")]))]
[(#\>)
(let ([m (read-int p)])
(read/mark m))]
[(#\<)
(let ([m (read-int p)])
(unless (fx< m (vector-length marks))
(error who "invalid mark" m))
(die who "invalid mark" m))
(vector-ref marks m))]
[else
(error who "Unexpected char as a fasl object header" h)])))
(die who "Unexpected char as a fasl object header" h)])))
(read))
(define $fasl-read
(lambda (p)
@ -279,7 +279,7 @@
[(p)
(if (input-port? p)
($fasl-read p)
(error 'fasl-read "not an input port" p))]))
(die 'fasl-read "not an input port" p))]))
)

20
scheme/ikarus.fasl.write.ss
View File

@ -40,14 +40,14 @@
(define write-fixnum
(lambda (x p)
(unless (fixnum? x) (error 'write-fixnum "not a fixnum" x))
(unless (fixnum? x) (die 'write-fixnum "not a fixnum" x))
(write-byte (fxsll (fxlogand x #x3F) 2) p)
(write-byte (fxlogand (fxsra x 6) #xFF) p)
(write-byte (fxlogand (fxsra x 14) #xFF) p)
(write-byte (fxlogand (fxsra x 22) #xFF) p)))
(define write-int
(lambda (x p)
(unless (fixnum? x) (error 'write-int "not a fixnum" x))
(unless (fixnum? x) (die 'write-int "not a fixnum" x))
(write-byte (fxlogand x #xFF) p)
(write-byte (fxlogand (fxsra x 8) #xFF) p)
(write-byte (fxlogand (fxsra x 16) #xFF) p)
@ -72,7 +72,7 @@
(put-tag (if x #\T #\F) p)]
[(eof-object? x) (put-tag #\E p)]
[(eq? x (void)) (put-tag #\U p)]
[else (error 'fasl-write "not a fasl-writable immediate" x)])))
[else (die 'fasl-write "not a fasl-writable immediate" x)])))
(define (ascii-string? s)
(let f ([s s] [i 0] [n (string-length s)])
@ -222,7 +222,7 @@
(write-byte ($bignum-byte-ref x i) p)
(f (fxadd1 i)))))
m]
[else (error 'fasl-write "not fasl-writable" x)])))
[else (die 'fasl-write "not fasl-writable" x)])))
(define (write-bytevector x i j p)
(unless ($fx= i j)
(write-byte ($bytevector-u8-ref x i) p)
@ -234,7 +234,7 @@
[(hashtable-ref h x #f) =>
(lambda (mark)
(unless (fixnum? mark)
(error 'fasl-write "BUG: invalid mark" mark))
(die 'fasl-write "BUG: invalid mark" mark))
(cond
[(fx= mark 0) ; singly referenced
(do-write x p h m)]
@ -247,7 +247,7 @@
(put-tag #\< p)
(write-int (fx- 0 mark) p)
m]))]
[else (error 'fasl-write "BUG: not in hash table" x)])))
[else (die 'fasl-write "BUG: not in hash table" x)])))
(define make-graph
(lambda (x h)
(unless (immediate? x)
@ -275,7 +275,7 @@
(make-graph (code-reloc-vector x) h)]
[(struct? x)
(when (eq? x (base-rtd))
(error 'fasl-write "base-rtd is not writable"))
(die 'fasl-write "base-rtd is not writable"))
(let ([rtd (struct-type-descriptor x)])
(cond
[(eq? rtd (base-rtd))
@ -294,7 +294,7 @@
[(procedure? x)
(let ([code ($closure-code x)])
(unless (fxzero? (code-freevars code))
(error 'fasl-write
(die 'fasl-write
"Cannot write a non-thunk procedure; \
the one given has free vars"
(code-freevars code)))
@ -305,7 +305,7 @@
[(ratnum? x)
(make-graph (numerator x) h)
(make-graph (denominator x) h)]
[else (error 'fasl-write "not fasl-writable" x)])]))))
[else (die 'fasl-write "not fasl-writable" x)])]))))
(define fasl-write-to-port
(lambda (x port)
(let ([h (make-eq-hashtable)])
@ -322,5 +322,5 @@
(case-lambda
[(x port)
(unless (and (output-port? port) (binary-port? port))
(error 'fasl-write "not an output port" port))
(die 'fasl-write "not an output port" port))
(fasl-write-to-port x port)])))

178
scheme/ikarus.fixnums.ss
View File

@ -50,39 +50,39 @@
(cond
[(eq? x 0) #t]
[(fixnum? x) #f]
[else (error 'fxzero? "not a fixnum" x)])))
[else (die 'fxzero? "not a fixnum" x)])))
(define fxadd1
(lambda (n)
(if (fixnum? n)
($fxadd1 n)
(error 'fxadd1 "not a fixnum" n))))
(die 'fxadd1 "not a fixnum" n))))
(define fxsub1
(lambda (n)
(if (fixnum? n)
($fxsub1 n)
(error 'fxsub1 "not a fixnum" n))))
(die 'fxsub1 "not a fixnum" n))))
(define fxlognot
(lambda (x)
(unless (fixnum? x)
(error 'fxlognot "not a fixnum" x))
(die 'fxlognot "not a fixnum" x))
($fxlognot x)))
(define fxnot
(lambda (x)
(unless (fixnum? x)
(error 'fxnot "not a fixnum" x))
(die 'fxnot "not a fixnum" x))
($fxlognot x)))
(define error@fx+
(lambda (x y)
(if (fixnum? x)
(if (fixnum? y)
(error 'fx+ "overflow when adding numbers" x y)
(error 'fx+ "not a fixnum" y))
(error 'fx+ "not a fixnum" x))))
(die 'fx+ "overflow when adding numbers" x y)
(die 'fx+ "not a fixnum" y))
(die 'fx+ "not a fixnum" x))))
(define fx+
(lambda (x y)
@ -91,17 +91,17 @@
(define fx-
(lambda (x y)
(unless (fixnum? x)
(error 'fx- "not a fixnum" x))
(die 'fx- "not a fixnum" x))
(unless (fixnum? y)
(error 'fx- "not a fixnum" y))
(die 'fx- "not a fixnum" y))
($fx- x y)))
(define fx*
(lambda (x y)
(unless (fixnum? x)
(error 'fx* "not a fixnum" x))
(die 'fx* "not a fixnum" x))
(unless (fixnum? y)
(error 'fx* "not a fixnum" y))
(die 'fx* "not a fixnum" y))
($fx* x y)))
@ -110,7 +110,7 @@
(if (pair? ls)
(if (fixnum? ($car ls))
(false-loop who ($cdr ls))
(error who "not a fixnum" ($car ls)))
(die who "not a fixnum" ($car ls)))
#f)))
(define-syntax fxcmp
@ -119,9 +119,9 @@
(case-lambda
[(x y)
(unless (fixnum? x)
(error 'who "not a fixnum" x))
(die 'who "not a fixnum" x))
(unless (fixnum? y)
(error 'who "not a fixnum" y))
(die 'who "not a fixnum" y))
($op x y)]
[(x y . ls)
(if (fixnum? x)
@ -134,13 +134,13 @@
(if ($op x y)
(f y ls)
(false-loop 'who ls))
(error 'who "not a fixnum" y)))
(die 'who "not a fixnum" y)))
#t))
(false-loop 'who ls))
(error 'who "not a fixnum" y))
(error 'who "not a fixnum" x))]
(die 'who "not a fixnum" y))
(die 'who "not a fixnum" x))]
[(x)
(if (fixnum? x) #t (error 'who "not a fixnum" x))])]))
(if (fixnum? x) #t (die 'who "not a fixnum" x))])]))
(define fx= (fxcmp fx= $fx=))
(define fx< (fxcmp fx< $fx<))
@ -157,32 +157,32 @@
(define fxquotient
(lambda (x y)
(unless (fixnum? x)
(error 'fxquotient "not a fixnum" x))
(die 'fxquotient "not a fixnum" x))
(unless (fixnum? y)
(error 'fxquotient "not a fixnum" y))
(die 'fxquotient "not a fixnum" y))
(when ($fxzero? y)
(error 'fxquotient "zero dividend" y))
(die 'fxquotient "zero dividend" y))
($fxquotient x y)))
(define fxremainder
(lambda (x y)
(unless (fixnum? x)
(error 'fxremainder "not a fixnum" x))
(die 'fxremainder "not a fixnum" x))
(unless (fixnum? y)
(error 'fxremainder "not a fixnum" y))
(die 'fxremainder "not a fixnum" y))
(when ($fxzero? y)
(error 'fxremainder "zero dividend" y))
(die 'fxremainder "zero dividend" y))
(let ([q ($fxquotient x y)])
($fx- x ($fx* q y)))))
(define fxmodulo
(lambda (x y)
(unless (fixnum? x)
(error 'fxmodulo "not a fixnum" x))
(die 'fxmodulo "not a fixnum" x))
(unless (fixnum? y)
(error 'fxmodulo "not a fixnum" y))
(die 'fxmodulo "not a fixnum" y))
(when ($fxzero? y)
(error 'fxmodulo "zero dividend" y))
(die 'fxmodulo "zero dividend" y))
($fxmodulo x y)))
(define-syntax fxbitop
@ -193,8 +193,8 @@
(if (fixnum? x)
(if (fixnum? y)
($op x y)
(error 'who "not a fixnum" y))
(error 'who "not a fixnum" x))]
(die 'who "not a fixnum" y))
(die 'who "not a fixnum" x))]
[(x y . ls)
(if (fixnum? x)
(if (fixnum? y)
@ -204,11 +204,11 @@
(let ([b ($car ls)])
(if (fixnum? b)
(f ($op a b) ($cdr ls))
(error 'who "not a fixnum" b)))]
(die 'who "not a fixnum" b)))]
[else a]))
(error 'who "not a fixnum" y))
(error 'who "not a fixnum" x))]
[(x) (if (fixnum? x) x (error 'who "not a fixnum" x))]
(die 'who "not a fixnum" y))
(die 'who "not a fixnum" x))]
[(x) (if (fixnum? x) x (die 'who "not a fixnum" x))]
[() identity])]))
(define fxlogor (fxbitop fxlogor $fxlogor 0))
@ -225,58 +225,58 @@
($fxlogor
($fxlogand x y)
($fxlogand ($fxlognot x) z))
(error 'fxif "not a fixnum" z))
(error 'fxif "not a fixnum" y))
(error 'fxif "not a fixnum" x)))
(die 'fxif "not a fixnum" z))
(die 'fxif "not a fixnum" y))
(die 'fxif "not a fixnum" x)))
(define fxsra
(lambda (x y)
(unless (fixnum? x)
(error 'fxsra "not a fixnum" x))
(die 'fxsra "not a fixnum" x))
(unless (fixnum? y)
(error 'fxsra "not a fixnum" y))
(die 'fxsra "not a fixnum" y))
(unless ($fx>= y 0)
(error 'fxsra "negative shift not allowed" y))
(die 'fxsra "negative shift not allowed" y))
($fxsra x y)))
(define fxarithmetic-shift-right
(lambda (x y)
(unless (fixnum? x)
(error 'fxarithmetic-shift-right "not a fixnum" x))
(die 'fxarithmetic-shift-right "not a fixnum" x))
(unless (fixnum? y)
(error 'fxarithmetic-shift-right "not a fixnum" y))
(die 'fxarithmetic-shift-right "not a fixnum" y))
(unless ($fx>= y 0)
(error 'fxarithmetic-shift-right "negative shift not allowed" y))
(die 'fxarithmetic-shift-right "negative shift not allowed" y))
($fxsra x y)))
(define fxsll
(lambda (x y)
(unless (fixnum? x)
(error 'fxsll "not a fixnum" x))
(die 'fxsll "not a fixnum" x))
(unless (fixnum? y)
(error 'fxsll "not a fixnum" y))
(die 'fxsll "not a fixnum" y))
(unless ($fx>= y 0)
(error 'fxsll "negative shift not allowed" y))
(die 'fxsll "negative shift not allowed" y))
($fxsll x y)))
(define fxarithmetic-shift-left
(lambda (x y)
(unless (fixnum? x)
(error 'fxarithmetic-shift-left "not a fixnum" x))
(die 'fxarithmetic-shift-left "not a fixnum" x))
(unless (fixnum? y)
(error 'fxarithmetic-shift-left "not a fixnum" y))
(die 'fxarithmetic-shift-left "not a fixnum" y))
(unless ($fx>= y 0)
(error 'fxarithmetic-shift-left "negative shift not allowed" y))
(die 'fxarithmetic-shift-left "negative shift not allowed" y))
($fxsll x y)))
(define fxarithmetic-shift
(lambda (x y)
(unless (fixnum? x)
(error 'fxarithmetic-shift "not a fixnum" x))
(die 'fxarithmetic-shift "not a fixnum" x))
(unless (fixnum? y)
(error 'fxarithmetic-shift "not a fixnum" y))
(die 'fxarithmetic-shift "not a fixnum" y))
(if ($fx>= y 0)
($fxsll x y)
(if ($fx< x -100) ;;; arbitrary number < (fixnum-width)
@ -286,22 +286,22 @@
(define (fxpositive? x)
(if (fixnum? x)
($fx> x 0)
(error 'fxpositive? "not a fixnum" x)))
(die 'fxpositive? "not a fixnum" x)))
(define (fxnegative? x)
(if (fixnum? x)
($fx< x 0)
(error 'fxnegative? "not a fixnum" x)))
(die 'fxnegative? "not a fixnum" x)))
(define (fxeven? x)
(if (fixnum? x)
($fxzero? ($fxlogand x 1))
(error 'fxeven? "not a fixnum" x)))
(die 'fxeven? "not a fixnum" x)))
(define (fxodd? x)
(if (fixnum? x)
(not ($fxzero? ($fxlogand x 1)))
(error 'fxodd? "not a fixnum" x)))
(die 'fxodd? "not a fixnum" x)))
(define fxmin
(case-lambda
@ -309,8 +309,8 @@
(if (fixnum? x)
(if (fixnum? y)
(if ($fx< x y) x y)
(error 'fxmin "not a fixnum" y))
(error 'fxmin "not a fixnum" x))]
(die 'fxmin "not a fixnum" y))
(die 'fxmin "not a fixnum" x))]
[(x y z . ls)
(fxmin (fxmin x y)
(if (fixnum? z)
@ -322,9 +322,9 @@
(if ($fx< a z)
(f a ($cdr ls))
(f z ($cdr ls)))
(error 'fxmin "not a fixnum" a)))))
(error 'fxmin "not a fixnum" z)))]
[(x) (if (fixnum? x) x (error 'fxmin "not a fixnum" x))]))
(die 'fxmin "not a fixnum" a)))))
(die 'fxmin "not a fixnum" z)))]
[(x) (if (fixnum? x) x (die 'fxmin "not a fixnum" x))]))
(define fxmax
(case-lambda
@ -332,8 +332,8 @@
(if (fixnum? x)
(if (fixnum? y)
(if ($fx> x y) x y)
(error 'fxmax "not a fixnum" y))
(error 'fxmax "not a fixnum" x))]
(die 'fxmax "not a fixnum" y))
(die 'fxmax "not a fixnum" x))]
[(x y z . ls)
(fxmax (fxmax x y)
(if (fixnum? z)
@ -345,9 +345,9 @@
(if ($fx> a z)
(f a ($cdr ls))
(f z ($cdr ls)))
(error 'fxmax "not a fixnum" a)))))
(error 'fxmax "not a fixnum" z)))]
[(x) (if (fixnum? x) x (error 'fxmax "not a fixnum" x))]))
(die 'fxmax "not a fixnum" a)))))
(die 'fxmax "not a fixnum" z)))]
[(x) (if (fixnum? x) x (die 'fxmax "not a fixnum" x))]))
(define (fx*/carry fx1 fx2 fx3)
(let ([s0 ($fx+ ($fx* fx1 fx2) fx3)])
@ -404,16 +404,16 @@
(define fixnum->string
(case-lambda
[(x)
(unless (fixnum? x) (error 'fixnum->string "not a fixnum" x))
(unless (fixnum? x) (die 'fixnum->string "not a fixnum" x))
($fixnum->string x 10)]
[(x r)
(unless (fixnum? x) (error 'fixnum->string "not a fixnum" x))
(unless (fixnum? x) (die 'fixnum->string "not a fixnum" x))
(case r
[(2) ($fixnum->string x 2)]
[(8) ($fixnum->string x 8)]
[(10) ($fixnum->string x 10)]
[(16) ($fixnum->string x 16)]
[else (error 'fixnum->string "invalid radix" r)])])))
[else (die 'fixnum->string "invalid radix" r)])])))
)
@ -454,28 +454,28 @@
(if (fixnum? x)
(if (fixnum? y)
(if ($fx= y 0)
(error 'fxdiv-and-mod "division by 0")
(die 'fxdiv-and-mod "division by 0")
($fxdiv-and-mod x y))
(error 'fxdiv-and-mod "not a fixnum" y))
(error 'fxdiv-and-mod "not a fixnum" x)))
(die 'fxdiv-and-mod "not a fixnum" y))
(die 'fxdiv-and-mod "not a fixnum" x)))
(define (fxdiv x y)
(if (fixnum? x)
(if (fixnum? y)
(if ($fx= y 0)
(error 'fxdiv "division by 0")
(die 'fxdiv "division by 0")
($fxdiv x y))
(error 'fxdiv "not a fixnum" y))
(error 'fxdiv "not a fixnum" x)))
(die 'fxdiv "not a fixnum" y))
(die 'fxdiv "not a fixnum" x)))
(define (fxmod x y)
(if (fixnum? x)
(if (fixnum? y)
(if ($fx= y 0)
(error 'fxmod "modision by 0")
(die 'fxmod "modision by 0")
($fxmod x y))
(error 'fxmod "not a fixnum" y))
(error 'fxmod "not a fixnum" x)))
(die 'fxmod "not a fixnum" y))
(die 'fxmod "not a fixnum" x)))
(define ($fxdiv0-and-mod0 n m)
(let ([d0 (quotient n m)])
@ -526,43 +526,43 @@
(if (fixnum? x)
(if (fixnum? y)
(if ($fx= y 0)
(error 'fxdiv0-and-mod0 "division by 0")
(die 'fxdiv0-and-mod0 "division by 0")
(let-values ([(d m) ($fxdiv0-and-mod0 x y)])
(if (and (fixnum? d) (fixnum? m))
(values d m)
(error 'fxdiv0-and-mod0
(die 'fxdiv0-and-mod0
"results not representable as fixnums"
x y))))
(error 'fxdiv0-and-mod0 "not a fixnum" y))
(error 'fxdiv0-and-mod0 "not a fixnum" x)))
(die 'fxdiv0-and-mod0 "not a fixnum" y))
(die 'fxdiv0-and-mod0 "not a fixnum" x)))
(define (fxdiv0 x y)
(if (fixnum? x)
(if (fixnum? y)
(if ($fx= y 0)
(error 'fxdiv0 "division by 0")
(die 'fxdiv0 "division by 0")
(let ([d ($fxdiv0 x y)])
(if (fixnum? d)
d
(error 'fxdiv0
(die 'fxdiv0
"result not representable as fixnum"
x y))))
(error 'fxdiv0 "not a fixnum" y))
(error 'fxdiv0 "not a fixnum" x)))
(die 'fxdiv0 "not a fixnum" y))
(die 'fxdiv0 "not a fixnum" x)))
(define (fxmod0 x y)
(if (fixnum? x)
(if (fixnum? y)
(if ($fx= y 0)
(error 'fxmod0 "division by 0")
(die 'fxmod0 "division by 0")
(let ([d ($fxmod0 x y)])
(if (fixnum? d)
d
(error 'fxmod0
(die 'fxmod0
"result not representable as fixnum"
x y))))
(error 'fxmod0 "not a fixnum" y))
(error 'fxmod0 "not a fixnum" x)))
(die 'fxmod0 "not a fixnum" y))
(die 'fxmod0 "not a fixnum" x)))
)

36
scheme/ikarus.handlers.ss
View File

@ -25,7 +25,7 @@
[(v) (set! x v)])]
[(x guard)
(unless (procedure? guard)
(error 'make-parameter "not a procedure" guard))
(die 'make-parameter "not a procedure" guard))
(set! x (guard x))
(case-lambda
[() x]
@ -55,19 +55,19 @@
(lambda (x)
(if (procedure? x)
x
(error 'interrupt-handler "not a procedure" x)))))
(die 'interrupt-handler "not a procedure" x)))))
(define $apply-nonprocedure-error-handler
(lambda (x)
(error 'apply "not a procedure" x)))
(die 'apply "not a procedure" x)))
(define $incorrect-args-error-handler
(lambda (p n)
(error 'apply "incorrect number of arguments" n p)))
(die 'apply "incorrect number of arguments" n p)))
(define $multiple-values-error
(lambda args
(error 'apply
(die 'apply
"incorrect number of values returned to single value context"
args)))
@ -84,47 +84,47 @@
(cond
[(symbol? x)
(if (symbol-bound? x)
(error 'top-level-value-error "BUG: should not happen" x)
(error #f "unbound" (string->symbol (symbol->string x))))]
(die 'top-level-value-error "BUG: should not happen" x)
(die #f "unbound" (string->symbol (symbol->string x))))]
[else
(error 'top-level-value "not a symbol" x)])))
(die 'top-level-value "not a symbol" x)])))
(define car-error
(lambda (x)
(error 'car "not a pair" x)))
(die 'car "not a pair" x)))
(define cdr-error
(lambda (x)
(error 'cdr "not a pair" x)))
(die 'cdr "not a pair" x)))
(define fxadd1-error
(lambda (x)
(if (fixnum? x)
(error 'fxadd1 "overflow")
(error 'fxadd1 "not a fixnum" x))))
(die 'fxadd1 "overflow")
(die 'fxadd1 "not a fixnum" x))))
(define fxsub1-error
(lambda (x)
(if (fixnum? x)
(error 'fxsub1 "underflow")
(error 'fxsub1 "not a fixnum" x))))
(die 'fxsub1 "underflow")
(die 'fxsub1 "not a fixnum" x))))
(define cadr-error
(lambda (x)
(error 'cadr "invalid list structure" x)))
(die 'cadr "invalid list structure" x)))
(define fx+-type-error
(lambda (x)
(error 'fx+ "not a fixnum" x)))
(die 'fx+ "not a fixnum" x)))
(define fx+-types-error
(lambda (x y)
(error 'fx+ "not a fixnum"
(die 'fx+ "not a fixnum"
(if (fixnum? x) y x))))
(define fx+-overflow-error
(lambda (x y)
(error 'fx+ "overflow")))
(die 'fx+ "overflow")))
(define $do-event
(lambda ()

42
scheme/ikarus.hash-tables.ss
View File

@ -311,28 +311,28 @@
(if (and (or (fixnum? k) (bignum? k))
(>= k 0))
(make-eq-hashtable)
(error 'make-eq-hashtable
(die 'make-eq-hashtable
"invalid initial capacity" k))]))
(define hashtable-ref
(lambda (h x v)
(if (hasht? h)
(get-hash h x v)
(error 'hashtable-ref "not a hash table" h))))
(die 'hashtable-ref "not a hash table" h))))
(define hashtable-contains?
(lambda (h x)
(if (hasht? h)
(in-hash? h x)
(error 'hashtable-contains? "not a hash table" h))))
(die 'hashtable-contains? "not a hash table" h))))
(define hashtable-set!
(lambda (h x v)
(if (hasht? h)
(if (hasht-mutable? h)
(put-hash! h x v)
(error 'hashtable-set! "hashtable is immutable" h))
(error 'hashtable-set! "not a hash table" h))))
(die 'hashtable-set! "hashtable is immutable" h))
(die 'hashtable-set! "not a hash table" h))))
(define hashtable-update!
(lambda (h x proc default)
@ -340,15 +340,15 @@
(if (hasht-mutable? h)
(if (procedure? proc)
(update-hash! h x proc default)
(error 'hashtable-update! "not a procedure" proc))
(error 'hashtable-update! "hashtable is immutable" h))
(error 'hashtable-update! "not a hash table" h))))
(die 'hashtable-update! "not a procedure" proc))
(die 'hashtable-update! "hashtable is immutable" h))
(die 'hashtable-update! "not a hash table" h))))
(define hashtable-size
(lambda (h)
(if (hasht? h)
(hasht-count h)
(error 'hashtable-size "not a hash table" h))))
(die 'hashtable-size "not a hash table" h))))
(define hashtable-delete!
(lambda (h x)
@ -357,30 +357,30 @@
(if (hasht? h)
(if (hasht-mutable? h)
(del-hash h x)
(error 'hashtable-delete! "hashtable is immutable" h))
(error 'hashtable-delete! "not a hash table" h))))
(die 'hashtable-delete! "hashtable is immutable" h))
(die 'hashtable-delete! "not a hash table" h))))
(define (hashtable-entries h)
(if (hasht? h)
(get-entries h)
(error 'hashtable-entries "not a hash table" h)))
(die 'hashtable-entries "not a hash table" h)))
(define (hashtable-keys h)
(if (hasht? h)
(get-keys h)
(error 'hashtable-keys "not a hash table" h)))
(die 'hashtable-keys "not a hash table" h)))
(define (hashtable-mutable? h)
(if (hasht? h)
(hasht-mutable? h)
(error 'hashtable-mutable? "not a hash table" h)))
(die 'hashtable-mutable? "not a hash table" h)))
(define (hashtable-clear! h)
(if (hasht? h)
(if (hasht-mutable? h)
(clear-hash! h)
(error 'hashtable-clear! "hashtable is immutable" h))
(error 'hashtable-clear! "not a hash table" h)))
(die 'hashtable-clear! "hashtable is immutable" h))
(die 'hashtable-clear! "not a hash table" h)))
(define hashtable-copy
(case-lambda
@ -389,28 +389,28 @@
(if (hasht-mutable? h)
(hasht-copy h #f)
h)
(error 'hashtable-copy "not a hash table" h))]
(die 'hashtable-copy "not a hash table" h))]
[(h mutable?)
(if (hasht? h)
(if (or mutable? (hasht-mutable? h))
(hasht-copy h (and mutable? #t))
h)
(error 'hashtable-copy "not a hash table" h))]))
(die 'hashtable-copy "not a hash table" h))]))
(define (string-hash s)
(if (string? s)
(foreign-call "ikrt_string_hash" s)
(error 'string-hash "not a string" s)))
(die 'string-hash "not a string" s)))
(define (string-ci-hash s)
(if (string? s)
(foreign-call "ikrt_string_hash"
(string-foldcase s))
(error 'string-ci-hash "not a string" s)))
(die 'string-ci-hash "not a string" s)))
(define (symbol-hash s)
(if (symbol? s)
(foreign-call "ikrt_string_hash" (symbol->string s))
(error 'symbol-hash "not a symbol" s)))
(die 'symbol-hash "not a symbol" s)))
)

178
scheme/ikarus.intel-assembler.ss
View File

@ -73,7 +73,7 @@
(lambda (x)
(cond
[(assq x register-mapping) => caddr]
[else (error 'register-index "not a register" x)])))
[else (die 'register-index "not a register" x)])))
(define reg32?
(lambda (x)
@ -117,10 +117,10 @@
(let ([a1 ($car t)])
(if (null? ($cdr t))
(let () b b* ...)
(error 'with-args "too many args")))
(error 'with-args "too few args")))
(error 'with-args "too few args")))
(error 'with-args "too few args")))]))
(die 'with-args "too many args")))
(die 'with-args "too few args")))
(die 'with-args "too few args")))
(die 'with-args "too few args")))]))
@ -209,7 +209,7 @@
(cons (cons 'label-addr (label-name n)) ac)]
[(foreign? n)
(cons (cons 'foreign-label (label-name n)) ac)]
[else (error 'IMM32 "invalid" n)])))
[else (die 'IMM32 "invalid" n)])))
(define IMM8
@ -217,7 +217,7 @@
(cond
[(int? n)
(cons* (byte n) ac)]
[else (error 'IMM8 "invalid" n)])))
[else (die 'IMM8 "invalid" n)])))
(define imm?
@ -244,7 +244,7 @@
(let ([d (cdr x)])
(unless (and (null? (cdr d))
(symbol? (car d)))
(error 'assemble "invalid label" x)))
(die 'assemble "invalid label" x)))
#t]
[else #f])))
@ -256,7 +256,7 @@
(unless (and (null? (cdr d))
(or (symbol? (car d))
(string? (car d))))
(error 'assemble "invalid label-address" x)))
(die 'assemble "invalid label-address" x)))
#t]
[else #f])))
@ -280,7 +280,7 @@
(CODE c (ModRM 1 d s (IMM8 i ac)))]
[(imm? i)
(CODE c (ModRM 2 d s (IMM32 i ac)))]
[else (error 'CODErri "invalid i" i)])))
[else (die 'CODErri "invalid i" i)])))
(define CODErr
(lambda (c d s ac)
@ -294,8 +294,8 @@
(define RegReg
(lambda (r1 r2 r3 ac)
(cond
[(eq? r3 '%esp) (error 'assembler "BUG: invalid src %esp")]
[(eq? r1 '%ebp) (error 'assembler "BUG: invalid src %ebp")]
[(eq? r3 '%esp) (die 'assembler "BUG: invalid src %esp")]
[(eq? r1 '%ebp) (die 'assembler "BUG: invalid src %ebp")]
[else
(cons*
(byte (fxlogor 4 (fxsll (register-index r1) 3)))
@ -314,7 +314,7 @@
[(and (int? i1) (int? i2))
;FIXME
(IMM32 i1 (IMM32 i2 ac))]
[else (error 'assemble "invalid IMM32*2" i1 i2)])))
[else (die 'assemble "invalid IMM32*2" i1 i2)])))
(define CODErd
(lambda (c r1 disp ac)
@ -331,7 +331,7 @@
(CODE c
(ModRM 0 r1 '/5
(IMM32*2 a1 a2 ac)))]
[else (error 'CODErd "unhandled" disp)])))))
[else (die 'CODErd "unhandled" disp)])))))
(define CODEdi
(lambda (c /? disp n ac)
@ -339,14 +339,14 @@
(lambda (a1 a2)
(cond
[(and (reg? a1) (reg? a2))
(error 'CODEdi "unsupported1" disp)]
(die 'CODEdi "unsupported1" disp)]
[(and (imm? a1) (reg? a2))
(CODErri c /? a2 a1 (IMM32 n ac))]
[(and (imm? a2) (reg? a1))
(CODErri c /? a1 a2 (IMM32 n ac))]
[(and (imm? a1) (imm? a2))
(error 'CODEdi "unsupported2" disp)]
[else (error 'CODEdi "unhandled" disp)])))))
(die 'CODEdi "unsupported2" disp)]
[else (die 'CODEdi "unhandled" disp)])))))
(define (SIB s i b ac)
(cons (byte
@ -376,8 +376,8 @@
(CODE c (ModRM 1 /d '/4 (SIB 0 a0 a1 (IMM8 0 ac))))]
[(and (imm? a0) (imm? a1))
(CODE c (ModRM 0 /d '/5 (IMM32*2 a0 a1 ac)))]
[else (error 'CODE/digit "unhandled" a0 a1)])))]
[else (error 'CODE/digit "unhandled" dst)])))
[else (die 'CODE/digit "unhandled" a0 a1)])))]
[else (die 'CODE/digit "unhandled" dst)])))
(define CODEid
(lambda (c /? n disp ac)
@ -385,16 +385,16 @@
(lambda (a1 a2)
(cond
[(and (reg? a1) (reg? a2))
(error 'CODEid "unsupported1" disp)]
(die 'CODEid "unsupported1" disp)]
[(and (imm? a1) (reg? a2))
(error 'CODEid "unsupported2")
(die 'CODEid "unsupported2")
(CODErri c /? a2 a1 (IMM32 n ac))]
[(and (imm? a2) (reg? a1))
(error 'CODEid "unsupported3")
(die 'CODEid "unsupported3")
(CODErri c /? a1 a2 (IMM32 n ac))]
[(and (imm? a1) (imm? a2))
(error 'CODEid "unsupported4")]
[else (error 'CODEid "unhandled" disp)])))))
(die 'CODEid "unsupported4")]
[else (die 'CODEid "unhandled" disp)])))))
(define CODEdi8
(lambda (c /? disp n ac)
@ -426,20 +426,20 @@
[(fx= n 2)
(if (fx= (length args) 2)
(proc a ac (car args) (cadr args))
(error 'convert-instruction "incorrect args" a))]
(die 'convert-instruction "incorrect args" a))]
[(fx= n 1)
(if (fx= (length args) 1)
(proc a ac (car args))
(error 'convert-instruction "incorrect args" a))]
(die 'convert-instruction "incorrect args" a))]
[(fx= n 0)
(if (fx= (length args) 0)
(proc a ac)
(error 'convert-instruction "incorrect args" a))]
(die 'convert-instruction "incorrect args" a))]
[else
(if (fx= (length args) n)
(apply proc a ac args)
(error 'convert-instruction "incorrect args" a))])))]
[else (error 'convert-instruction "unknown instruction" a)]))
(die 'convert-instruction "incorrect args" a))])))]
[else (die 'convert-instruction "unknown instruction" a)]))
@ -449,17 +449,17 @@
(cond
[(reg? arg2) (CODEri ircode arg2 arg1 ac)]
[(mem? arg2) (CODEdi imcode '/0 arg2 arg1 ac)]
[else (error 'instr/2 "invalid args" arg1 arg2)])]
[else (die 'instr/2 "invalid args" arg1 arg2)])]
[(reg? arg1)
(cond
[(reg? arg2) (CODErr rrcode arg1 arg2 ac)]
[(mem? arg2) (CODErd rmcode arg1 arg2 ac)]
[else (error 'instr/2 "invalid args" arg1 arg2)])]
[else (die 'instr/2 "invalid args" arg1 arg2)])]
[(mem? arg1)
(cond
[(reg? arg2) (CODErd mrcode arg2 arg1 ac)]
[else (error 'instr/2 "invalid args" arg1 arg2)])]
[else (error 'instr/2 "invalid args" arg1 arg2)]))
[else (die 'instr/2 "invalid args" arg1 arg2)])]
[else (die 'instr/2 "invalid args" arg1 arg2)]))
(module ()
(define who 'assembler)
@ -468,7 +468,7 @@
(cond
[(reg8? dst)
(CODE #x0F (CODE c (ModRM 3 '/0 dst ac)))]
[else (error who "invalid condition-set" dst)]))
[else (die who "invalid condition-set" dst)]))
(define (conditional-jump c dst ac)
(cond
@ -476,7 +476,7 @@
(CODE #x0F (CODE c (IMM32 dst ac)))]
[(label? dst)
(CODE #x0F (CODE c (cons (cons 'relative (label-name dst)) ac)))]
[else (error who "invalid conditional jump target" dst)]))
[else (die who "invalid conditional jump target" dst)]))
(add-instructions instr ac
[(ret) (CODE #xC3 ac)]
@ -489,67 +489,67 @@
((CODE/digit #xC6 '/0) dst (IMM8 src ac))]
[(and (reg8? src) (mem? dst)) (CODErd #x88 src dst ac)]
[(and (mem? src) (reg8? dst)) (CODErd #x8A dst src ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(movsd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x10 dst) src ac)))]
[(and (xmmreg? src) (or (xmmreg? dst) (mem? dst)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x11 src) dst ac)))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(cvtsi2sd src dst)
(cond
[(and (xmmreg? dst) (reg? src))
(CODE #xF2 (CODE #x0F (CODE #x2A (ModRM 3 src dst ac))))]
[(and (xmmreg? dst) (mem? src))
(CODE #xF2 (CODE #x0F ((CODE/digit #x2A dst) src ac)))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(cvtsd2ss src dst)
(cond
[(and (xmmreg? dst) (reg? src))
(CODE #xF2 (CODE #x0F (CODE #x5A (ModRM 3 src dst ac))))]
;[(and (xmmreg? dst) (mem? src))
; (CODE #xF2 (CODE #x0F ((CODE/digit #x5A dst) src ac)))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(cvtss2sd src dst)
(cond
[(and (xmmreg? dst) (reg? src))
(CODE #xF3 (CODE #x0F (CODE #x5A (ModRM 3 src dst ac))))]
;[(and (xmmreg? dst) (mem? src))
; (CODE #xF3 (CODE #x0F ((CODE/digit #x5A dst) src ac)))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(movss src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #xF3 (CODE #x0F ((CODE/digit #x10 dst) src ac)))]
[(and (xmmreg? src) (or (xmmreg? dst) (mem? dst)))
(CODE #xF3 (CODE #x0F ((CODE/digit #x11 src) dst ac)))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(addsd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x58 dst) src ac)))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(subsd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x5C dst) src ac)))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(mulsd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x59 dst) src ac)))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(divsd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #xF2 (CODE #x0F ((CODE/digit #x5E dst) src ac)))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(ucomisd src dst)
(cond
[(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
(CODE #x66 (CODE #x0F ((CODE/digit #x2E dst) src ac)))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
;[(pshufb src dst)
; ;;; unfortunately, this is an SSE3 instr.
; (cond
@ -557,7 +557,7 @@
; (CODE #x0F
; (CODE #x38
; ((CODE/digit #x00 dst) src ac)))]
; [else (error who "invalid" instr)])]
; [else (die who "invalid" instr)])]
[(addl src dst)
(cond
[(and (imm8? src) (reg? dst))
@ -574,7 +574,7 @@
((CODE/digit #x81 '/0) dst (IMM32 src ac))]
[(and (reg? src) (mem? dst))
((CODE/digit #x01 src) dst ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(subl src dst)
(cond
[(and (imm8? src) (reg? dst))
@ -591,7 +591,7 @@
((CODE/digit #x81 '/5) dst (IMM32 src ac))]
[(and (reg? src) (mem? dst))
((CODE/digit #x29 src) dst ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(sall src dst)
(cond
[(and (equal? 1 src) (reg? dst))
@ -604,7 +604,7 @@
(CODE #xD3 (ModRM 3 '/4 dst ac))]
[(and (eq? src '%cl) (mem? dst))
((CODE/digit #xD3 '/4) dst ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(shrl src dst)
(cond
[(and (equal? 1 src) (reg? dst))
@ -617,7 +617,7 @@
((CODE/digit #xC1 '/5) dst (IMM8 src ac))]
[(and (eq? src '%cl) (mem? dst))
((CODE/digit #xD3 '/5) dst ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(sarl src dst)
(cond
[(and (equal? 1 src) (reg? dst))
@ -630,7 +630,7 @@
(CODE #xD3 (ModRM 3 '/7 dst ac))]
[(and (eq? src '%cl) (mem? dst))
((CODE/digit #xD3 '/7) dst ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(andl src dst)
(cond
[(and (imm? src) (mem? dst))
@ -647,7 +647,7 @@
((CODE/digit #x21 src) dst ac)]
[(and (mem? src) (reg? dst))
(CODErd #x23 dst src ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(orl src dst)
(cond
[(and (imm? src) (mem? dst))
@ -664,7 +664,7 @@
(CODE #x09 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x0B dst src ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(xorl src dst)
(cond
[(and (imm8? src) (reg? dst))
@ -681,12 +681,12 @@
((CODE/digit #x31 src) dst ac)]
;[(and (imm? src) (mem? dst))
; ((CODE/digit #x81 '/6) dst (IMM32 src ac))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(leal src dst)
(cond
[(and (mem? src) (reg? dst))
(CODErd #x8D dst src ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(cmpl src dst)
(cond
[(and (imm8? src) (reg? dst))
@ -700,12 +700,12 @@
[(and (mem? src) (reg? dst))
(CODErd #x3B dst src ac)]
[(and (imm8? src) (mem? dst))
;;; maybe error
;;; maybe die
(CODErd #x83 '/7 dst (IMM8 src ac))]
[(and (imm? src) (mem? dst))
;;; maybe error
;;; maybe die
(CODErd #x81 '/7 dst (IMM32 src ac))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(imull src dst)
(cond
[(and (imm8? src) (reg? dst))
@ -716,15 +716,15 @@
(CODE #x0F (CODE #xAF (ModRM 3 dst src ac)))]
[(and (mem? src) (reg? dst))
(CODE #x0F (CODErd #xAF dst src ac))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(idivl dst)
(cond
[(reg? dst)
(CODErr #xF7 '/7 dst ac)]
[(mem? dst)
;;; maybe error
;;; maybe die
(CODErd #xF7 '/7 dst ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(pushl dst)
(cond
[(imm8? dst)
@ -734,35 +734,35 @@
[(reg? dst)
(CODE+r #x50 dst ac)]
[(mem? dst)
;;; maybe error
;;; maybe die
(CODErd #xFF '/6 dst ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(popl dst)
(cond
[(reg? dst)
(CODE+r #x58 dst ac)]
[(mem? dst)
;;; maybe error
;;; maybe die
(CODErd #x8F '/0 dst ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(notl dst)
(cond
[(reg? dst)
(CODE #xF7 (ModRM 3 '/2 dst ac))]
[(mem? dst)
;;; maybe error
;;; maybe die
(CODErd #xF7 '/7 dst ac)]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(bswap dst)
(cond
[(reg? dst)
(CODE #x0F (CODE+r #xC8 dst ac))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(negl dst)
(cond
[(reg? dst)
(CODE #xF7 (ModRM 3 '/3 dst ac))]
[else (error who "invalid" instr)])]
[else (die who "invalid" instr)])]
[(jmp dst)
(cond
[(label? dst)
@ -770,9 +770,9 @@
[(imm? dst)
(CODE #xE9 (IMM32 dst ac))]
[(mem? dst)
;;; maybe error
;;; maybe die
(CODErd #xFF '/4 dst ac)]
[else (error who "invalid jmp target" dst)])]
[else (die who "invalid jmp target" dst)])]
[(call dst)
(cond
[(imm? dst)
@ -780,11 +780,11 @@
[(label? dst)
(CODE #xE8 (cons (cons 'relative (label-name dst)) ac))]
[(mem? dst)
;;; maybe error
;;; maybe die
(CODErd #xFF '/2 dst ac)]
[(reg? dst)
(CODE #xFF (ModRM 3 '/2 dst ac))]
[else (error who "invalid jmp target" dst)])]
[else (die who "invalid jmp target" dst)])]
[(seta dst) (conditional-set #x97 dst ac)]
[(setae dst) (conditional-set #x93 dst ac)]
[(setb dst) (conditional-set #x92 dst ac)]
@ -825,15 +825,15 @@
[(jp dst) (conditional-jump #x8A dst ac)]
[(jnp dst) (conditional-jump #x8B dst ac)]
[(byte x)
(unless (byte? x) (error who "not a byte" x))
(unless (byte? x) (die who "not a byte" x))
(cons (byte x) ac)]
[(byte-vector x) (append (map (lambda (x) (byte x)) (vector->list x)) ac)]
[(int a) (IMM32 a ac)]
[(label L)
(unless (symbol? L) (error who "label is not a symbol" L))
(unless (symbol? L) (die who "label is not a symbol" L))
(cons (cons 'label L) ac)]
[(label-address L)
(unless (symbol? L) (error who "label-address is not a symbol" L))
(unless (symbol? L) (die who "label-address is not a symbol" L))
(cons (cons 'label-addr L) ac)]
[(current-frame-offset)
(cons '(current-frame-offset) ac)]
@ -853,7 +853,7 @@
relative local-relative current-frame-offset)
(fx+ ac 4)]
[(label) ac]
[else (error 'compute-code-size "unknown instr" x)])))
[else (die 'compute-code-size "unknown instr" x)])))
0
ls)))
@ -861,13 +861,13 @@
(define set-label-loc!
(lambda (x loc)
(when (getprop x '*label-loc*)
(error 'compile "label is already defined" x))
(die 'compile "label is already defined" x))
(putprop x '*label-loc* loc)))
(define label-loc
(lambda (x)
(or (getprop x '*label-loc*)
(error 'compile "undefined label" x))))
(die 'compile "undefined label" x))))
(define unset-label-loc!
@ -883,7 +883,7 @@
(code-set! code (fx+ idx 1) (fxlogand (fxsra x 6) #xFF))
(code-set! code (fx+ idx 2) (fxlogand (fxsra x 14) #xFF))
(code-set! code (fx+ idx 3) (fxlogand (fxsra x 22) #xFF))]
[else (error 'set-code-word! "unhandled" x)])))
[else (die 'set-code-word! "unhandled" x)])))
(define (optimize-local-jumps ls)
(define locals '())
@ -937,7 +937,7 @@
(set-label-loc! (cdr a) (list x idx))
(f (cdr ls) idx reloc)]
[else
(error 'whack-instructions "unknown instr" a)])))])))
(die 'whack-instructions "unknown instr" a)])))])))
(f ls 0 '())))
(define wordsize 4)
@ -952,7 +952,7 @@
[(reloc-word foreign-label) (fx+ ac 2)]
[(relative reloc-word+ label-addr) (fx+ ac 3)]
[(word byte label current-frame-offset local-relative) ac]
[else (error 'compute-reloc-size "unknown instr" x)])))
[else (die 'compute-reloc-size "unknown instr" x)])))
0
ls)))
@ -972,7 +972,7 @@
(define code-entry-adjustment
(let ([v #f])
(case-lambda
[() (or v (error 'code-entry-adjustment "uninitialized"))]
[() (or v (die 'code-entry-adjustment "uninitialized"))]
[(x) (set! v x)])))
(define whack-reloc
@ -990,7 +990,7 @@
[(fx= (length p) 2)
(let ([code (car p)] [idx (cadr p)])
(unless (fx= idx 0)
(error 'whack-reloc
(die 'whack-reloc
"cannot create a thunk pointing"
idx))
(let ([thunk (code->thunk code)])
@ -1009,7 +1009,7 @@
(let ([name
(if (string? v)
(foreign-string->bytevector v)
(error 'whack-reloc "not a string" v))])
(die 'whack-reloc "not a string" v))])
(vector-set! vec reloc-idx (fxlogor 1 (fxsll idx 2)))
(vector-set! vec (fx+ reloc-idx 1) name)
(set! reloc-idx (fx+ reloc-idx 2)))]
@ -1031,7 +1031,7 @@
(let ([loc (label-loc v)])
(let ([obj (car loc)] [disp (cadr loc)])
(unless (eq? obj code)
(error 'whack-reloc "local-relative differ"))
(die 'whack-reloc "local-relative differ"))
(let ([rel (fx- disp (fx+ idx 4))])
(code-set! code (fx+ idx 0) (fxlogand rel #xFF))
(code-set! code (fx+ idx 1) (fxlogand (fxsra rel 8) #xFF))
@ -1041,13 +1041,13 @@
(let ([loc (label-loc v)])
(let ([obj (car loc)] [disp (cadr loc)])
(unless (and (code? obj) (fixnum? disp))
(error 'whack-reloc "invalid relative jump obj/disp" obj disp))
(die 'whack-reloc "invalid relative jump obj/disp" obj disp))
(vector-set! vec reloc-idx (fxlogor 3 (fxsll idx 2)))
(vector-set! vec (fx+ reloc-idx 1)
(fx+ disp (code-entry-adjustment)))
(vector-set! vec (fx+ reloc-idx 2) obj)))
(set! reloc-idx (fx+ reloc-idx 3))]
[else (error 'whack-reloc "invalid reloc type" type)]))
[else (die 'whack-reloc "invalid reloc type" type)]))
)))

271
scheme/ikarus.io.ss
View File

@ -164,7 +164,7 @@
(syntax-rules ()
[(_ name)
(define (name . args)
(apply error 'name "not implemented" args))]))
(apply die 'name "not implemented" args))]))
(define-syntax u8?
@ -223,17 +223,17 @@
(define (input-port-name p)
(if (input-port? p)
($port-id p)
(error 'input-port-name "not an input port" p)))
(die 'input-port-name "not an input port" p)))
(define (output-port-name p)
(if (output-port? p)
($port-id p)
(error 'output-port-name "not an output port" p)))
(die 'output-port-name "not an output port" p)))
(define (port-id p)
(if (port? p)
($port-id p)
(error 'port-id "not a port" p)))
(die 'port-id "not a port" p)))
(define guarded-port
(let ([G (make-guardian)])
@ -266,11 +266,11 @@
;;; FIXME: get-position and set-position! are ignored for now
(define who 'make-custom-binary-input-port)
(unless (string? id)
(error who "id is not a string" id))
(die who "id is not a string" id))
(unless (procedure? read!)
(error who "read! is not a procedure" read!))
(die who "read! is not a procedure" read!))
(unless (or (procedure? close) (not close))
(error who "close should be either a procedure or #f" close))
(die who "close should be either a procedure or #f" close))
($make-custom-binary-port
binary-input-port-bits
0
@ -282,11 +282,11 @@
;;; FIXME: get-position and set-position! are ignored for now
(define who 'make-custom-binary-output-port)
(unless (string? id)
(error who "id is not a string" id))
(die who "id is not a string" id))
(unless (procedure? write!)
(error who "write! is not a procedure" write!))
(die who "write! is not a procedure" write!))
(unless (or (procedure? close) (not close))
(error who "close should be either a procedure or #f" close))
(die who "close should be either a procedure or #f" close))
($make-custom-binary-port
binary-output-port-bits
256
@ -298,11 +298,11 @@
;;; FIXME: get-position and set-position! are ignored for now
(define who 'make-custom-textual-input-port)
(unless (string? id)
(error who "id is not a string" id))
(die who "id is not a string" id))
(unless (procedure? read!)
(error who "read! is not a procedure" read!))
(die who "read! is not a procedure" read!))
(unless (or (procedure? close) (not close))
(error who "close should be either a procedure or #f" close))
(die who "close should be either a procedure or #f" close))
($make-custom-textual-port
(fxior textual-input-port-bits fast-char-text-tag)
0
@ -314,11 +314,11 @@
;;; FIXME: get-position and set-position! are ignored for now
(define who 'make-custom-textual-output-port)
(unless (string? id)
(error who "id is not a string" id))
(die who "id is not a string" id))
(unless (procedure? write!)
(error who "write! is not a procedure" write!))
(die who "write! is not a procedure" write!))
(unless (or (procedure? close) (not close))
(error who "close should be either a procedure or #f" close))
(die who "close should be either a procedure or #f" close))
($make-custom-textual-port
(fxior textual-output-port-bits fast-char-text-tag)
256
@ -355,11 +355,11 @@
[(bv) (open-bytevector-input-port bv #f)]
[(bv maybe-transcoder)
(unless (bytevector? bv)
(error 'open-bytevector-input-port
(die 'open-bytevector-input-port
"not a bytevector" bv))
(when (and maybe-transcoder
(not (transcoder? maybe-transcoder)))
(error 'open-bytevector-input-port
(die 'open-bytevector-input-port
"not a transcoder" maybe-transcoder))
($make-port
(input-transcoder-attrs maybe-transcoder)
@ -379,7 +379,7 @@
[(transcoder)
(define who 'open-bytevector-output-port)
(unless (or (not transcoder) (transcoder? transcoder))
(error who "invalid transcoder value" transcoder))
(die who "invalid transcoder value" transcoder))
(let ([buf* '()] [buffer-size 256])
(let ([p
($make-port
@ -424,9 +424,9 @@
[(proc transcoder)
(define who 'call-with-bytevector-output-port)
(unless (procedure? proc)
(error who "not a procedure" proc))
(die who "not a procedure" proc))
(unless (or (not transcoder) (transcoder? transcoder))
(error who "invalid transcoder argument" transcoder))
(die who "invalid transcoder argument" transcoder))
(let-values ([(p extract)
(open-bytevector-output-port transcoder)])
(proc p)
@ -435,7 +435,7 @@
(define (call-with-string-output-port proc)
(define who 'call-with-string-output-port)
(unless (procedure? proc)
(error who "not a procedure" proc))
(die who "not a procedure" proc))
(let-values ([(p extract) (open-string-output-port)])
(proc p)
(extract)))
@ -482,7 +482,7 @@
(define (open-string-input-port str)
(unless (string? str)
(error 'open-string-input-port str))
(die 'open-string-input-port str))
($make-port
(fxior textual-input-port-bits fast-char-text-tag)
0 (string-length str) str
@ -499,10 +499,10 @@
(define (transcoded-port p transcoder)
(define who 'transcoded-port)
(unless (transcoder? transcoder)
(error who "not a transcoder" transcoder))
(unless (port? p) (error who "not a port" p))
(when ($port-transcoder p) (error who "not a binary port" p))
(when ($port-closed? p) (error who "cannot transcode closed port" p))
(die who "not a transcoder" transcoder))
(unless (port? p) (die who "not a port" p))
(when ($port-transcoder p) (die who "not a binary port" p))
(when ($port-closed? p) (die who "cannot transcode closed port" p))
(let ([read! ($port-read! p)]
[write! ($port-write! p)])
($mark-port-closed! p)
@ -512,7 +512,7 @@
[read! (input-transcoder-attrs transcoder)]
[write! (output-transcoder-attrs transcoder)]
[else
(error 'transcoded-port
(die 'transcoded-port
"port is neither input nor output!")])
($port-index p)
($port-size p)
@ -529,13 +529,13 @@
(define (reset-input-port! p)
(if (input-port? p)
($set-port-index! p ($port-size p))
(error 'reset-input-port! "not an input port" p)))
(die 'reset-input-port! "not an input port" p)))
(define (port-transcoder p)
(if (port? p)
(let ([tr ($port-transcoder p)])
(and (transcoder? tr) tr))
(error 'port-transcoder "not a port" p)))
(die 'port-transcoder "not a port" p)))
(define ($port-closed? p)
(not (fxzero? (fxand ($port-attrs p) closed-port-tag))))
@ -550,7 +550,7 @@
(if (fxzero? (fxand ($port-attrs p) r6rs-mode-tag))
'ikarus-mode
'r6rs-mode)
(error 'port-mode "not a port" p)))
(die 'port-mode "not a port" p)))
(define (set-port-mode! p mode)
(if (port? p)
@ -561,8 +561,8 @@
[(ikarus-mode)
($set-port-attrs! p
(fxand ($port-attrs p) (fxnot r6rs-mode-tag)))]
[else (error 'set-port-mode! "invalid mode" mode)])
(error 'set-port-mode! "not a port" p)))
[else (die 'set-port-mode! "invalid mode" mode)])
(die 'set-port-mode! "not a port" p)))
(define flush-output-port
@ -570,22 +570,22 @@
[() (flush-output-port (*the-output-port*))]
[(p)
(unless (output-port? p)
(error 'flush-output-port "not an output port" p))
(die 'flush-output-port "not an output port" p))
(when ($port-closed? p)
(error 'flush-output-port "port is closed" p))
(die 'flush-output-port "port is closed" p))
(let ([idx ($port-index p)]
[buf ($port-buffer p)])
(unless (fx= idx 0)
(let ([bytes (($port-write! p) buf 0 idx)])
(unless (and (fixnum? bytes) (fx>= bytes 0) (fx<= bytes idx))
(error 'flush-output-port
(die 'flush-output-port
"write! returned an invalid value"
bytes))
(cond
[(fx= bytes idx)
($set-port-index! p 0)]
[(fx= bytes 0)
(error 'flush-output-port "could not write bytes to sink")]
(die 'flush-output-port "could not write bytes to sink")]
[else
(bytevector-copy! buf bytes buf 0 (fx- idx bytes))
($set-port-index! p (fx- idx bytes))
@ -604,17 +604,17 @@
(define (close-port p)
(unless (port? p)
(error 'close-port "not a port" p))
(die 'close-port "not a port" p))
($close-port p))
(define (close-input-port p)
(unless (input-port? p)
(error 'close-input-port "not an input port" p))
(die 'close-input-port "not an input port" p))
($close-port p))
(define (close-output-port p)
(unless (output-port? p)
(error 'close-output-port "not an output port" p))
(die 'close-output-port "not an output port" p))
($close-port p))
;(define-rrr port-has-port-position?)
@ -626,39 +626,39 @@
(module (get-char lookahead-char)
(import UNSAFE)
(define (refill-bv-start p who)
(when ($port-closed? p) (error who "port is closed" p))
(when ($port-closed? p) (die who "port is closed" p))
(let* ([bv ($port-buffer p)]
[n (bytevector-length bv)])
(let ([j (($port-read! p) bv 0 n)])
(unless (fixnum? j)
(error who "invalid return value from read! procedure" j))
(die who "invalid return value from read! procedure" j))
(cond
[(fx>= j 0)
(unless (fx<= j n)
(error who "read! returned a value out of range" j))
(die who "read! returned a value out of range" j))
($set-port-index! p 0)
($set-port-size! p j)
j]
[else
(error who "read! returned a value out of range" j)]))))
(die who "read! returned a value out of range" j)]))))
(define (refill-bv-buffer p who)
(when ($port-closed? p) (error who "port is closed" p))
(when ($port-closed? p) (die who "port is closed" p))
(let ([bv ($port-buffer p)] [i ($port-index p)] [j ($port-size p)])
(let ([c0 (fx- j i)])
(bytevector-copy! bv i bv 0 c0)
(let* ([max (fx- (bytevector-length bv) c0)]
[c1 (($port-read! p) bv c0 max)])
(unless (fixnum? c1)
(error who "invalid return value from read! procedure" c1))
(die who "invalid return value from read! procedure" c1))
(cond
[(fx>= j 0)
(unless (fx<= j max)
(error who "read! returned a value out of range" j))
(die who "read! returned a value out of range" j))
($set-port-index! p c0)
($set-port-size! p (fx+ c1 c0))
c1]
[else
(error who "read! returned a value out of range" c1)])))))
(die who "read! returned a value out of range" c1)])))))
(define (get-char-latin-mode p who idx)
(let ([n (refill-bv-start p who)])
(cond
@ -674,7 +674,7 @@
[(replace) #\xFFFD]
[(raise)
(raise (make-i/o-decoding-error p))]
[else (error who "cannot happen")]))
[else (die who "cannot happen")]))
(let ([i ($port-index p)]
[j ($port-size p)]
[buf ($port-buffer p)])
@ -777,7 +777,7 @@
[(replace) #\xFFFD]
[(raise)
(raise (make-i/o-decoding-error p))]
[else (error who "cannot happen")]))
[else (die who "cannot happen")]))
(let ([i ($port-index p)]
[j ($port-size p)]
[buf ($port-buffer p)])
@ -890,26 +890,26 @@
(define (speedup-input-port p who)
;;; returns #t if port is eof, #f otherwise
(unless (input-port? p)
(error who "not an input port" p))
(die who "not an input port" p))
(let ([tr ($port-transcoder p)])
(unless tr
(error who "not a textual port" p))
(die who "not a textual port" p))
(case (transcoder-codec tr)
[(utf-8-codec)
;;;
($set-port-attrs! p
(fxior textual-input-port-bits fast-u7-text-tag))
(eof-object? (advance-bom p who '(#xEF #xBB #xBF)))]
[else (error 'slow-get-char "codec not handled")])))
[else (die 'slow-get-char "codec not handled")])))
(define (lookahead-char-char-mode p who)
(let ([str ($port-buffer p)]
[read! ($port-read! p)])
(let ([n (read! str 0 (string-length str))])
(unless (fixnum? n)
(error who "invalid return value from read!" n))
(die who "invalid return value from read!" n))
(unless (<= 0 n (string-length str))
(error who "return value from read! is out of range" n))
(die who "return value from read! is out of range" n))
($set-port-index! p 0)
($set-port-size! p n)
(cond
@ -957,9 +957,9 @@
[read! ($port-read! p)])
(let ([n (read! str 0 (string-length str))])
(unless (fixnum? n)
(error who "invalid return value from read!" n))
(die who "invalid return value from read!" n))
(unless (<= 0 n (string-length str))
(error who "return value from read! is out of range" n))
(die who "return value from read! is out of range" n))
($set-port-size! p n)
(cond
[(fx= n 0)
@ -1008,31 +1008,31 @@
;;; ----------------------------------------------------------
(define (assert-binary-input-port p who)
(unless (port? p) (error who "not a port" p))
(when ($port-closed? p) (error who "port is closed" p))
(when ($port-transcoder p) (error who "port is not binary" p))
(unless (port? p) (die who "not a port" p))
(when ($port-closed? p) (die who "port is closed" p))
(when ($port-transcoder p) (die who "port is not binary" p))
(unless ($port-read! p)
(error who "port is not an input port" p)))
(die who "port is not an input port" p)))
(module (get-u8 lookahead-u8)
(import UNSAFE)
(define (get-u8-byte-mode p who start)
(when ($port-closed? p) (error who "port is closed" p))
(when ($port-closed? p) (die who "port is closed" p))
(let* ([bv ($port-buffer p)]
[n (bytevector-length bv)])
(let ([j (($port-read! p) bv 0 n)])
(unless (fixnum? j)
(error who "invalid return value from read! procedure" j))
(die who "invalid return value from read! procedure" j))
(cond
[(fx> j 0)
(unless (fx<= j n)
(error who "read! returned a value out of range" j))
(die who "read! returned a value out of range" j))
($set-port-index! p start)
($set-port-size! p j)
(bytevector-u8-ref bv 0)]
[(fx= j 0) (eof-object)]
[else
(error who "read! returned a value out of range" j)]))))
(die who "read! returned a value out of range" j)]))))
(define (slow-get-u8 p who start)
(assert-binary-input-port p who)
($set-port-attrs! p fast-get-byte-tag)
@ -1075,14 +1075,14 @@
(eof-object? (lookahead-u8 p))))]
[(input-port? p)
(when ($port-closed? p)
(error 'port-eof? "port is closed" p))
(die 'port-eof? "port is closed" p))
(if (textual-port? p)
(eof-object? (lookahead-char p))
(eof-object? (lookahead-u8 p)))]
[else (error 'port-eof? "not an input port" p)])))
[else (die 'port-eof? "not an input port" p)])))
(define io-errors-vec
'#("unknown error"
'#("unknown die"
"bad file name"
"operation interrupted"
"not a directory"
@ -1098,7 +1098,7 @@
"operation not supported"
"not enough space on device"
"quota exceeded"
"io error"
"io die"
"device is busy"
"access fault"
"file already exists"
@ -1110,9 +1110,10 @@
(cond
[(fx< err (vector-length io-errors-vec))
(vector-ref io-errors-vec err)]
[else "unknown error"]))])
[else "unknown die"]))])
(raise
(condition
(make-error)
(make-who-condition who)
(make-message-condition msg)
(make-i/o-filename-error id)))))
@ -1186,7 +1187,7 @@
[(fo:no-truncate/no-create) 5]
[(fo:no-truncate/no-fail) 6]
[(fo:no-truncate/no-fail/no-create) 7]
[else (error who "invalid file option" file-options)])])
[else (die who "invalid file option" file-options)])])
(let ([fh (foreign-call "ikrt_open_output_fd"
(string->utf8 filename)
opt)])
@ -1204,9 +1205,9 @@
(open-file-input-port filename file-options buffer-mode #f)]
[(filename file-options buffer-mode transcoder)
(unless (string? filename)
(error 'open-file-input-port "invalid filename" filename))
(die 'open-file-input-port "invalid filename" filename))
(unless (or (not transcoder) (transcoder? transcoder))
(error 'open-file-input-port "invalid transcoder" transcoder))
(die 'open-file-input-port "invalid transcoder" transcoder))
; FIXME: file-options ignored
; FIXME: buffer-mode ignored
(fh->input-port
@ -1227,11 +1228,11 @@
(open-file-output-port filename file-options buffer-mode #f)]
[(filename file-options buffer-mode transcoder)
(unless (string? filename)
(error 'open-file-output-port "invalid filename" filename))
(die 'open-file-output-port "invalid filename" filename))
; FIXME: file-options ignored
; FIXME: buffer-mode ignored
(unless (or (not transcoder) (transcoder? transcoder))
(error 'open-file-output-port "invalid transcoder" transcoder))
(die 'open-file-output-port "invalid transcoder" transcoder))
(fh->output-port
(open-output-file-handle filename file-options
'open-file-output-port)
@ -1242,7 +1243,7 @@
(define (open-output-file filename)
(unless (string? filename)
(error 'open-output-file "invalid filename" filename))
(die 'open-output-file "invalid filename" filename))
(fh->output-port
(open-output-file-handle filename (file-options)
'open-input-file)
@ -1253,7 +1254,7 @@
(define (open-input-file filename)
(unless (string? filename)
(error 'open-input-file "invalid filename" filename))
(die 'open-input-file "invalid filename" filename))
(fh->input-port
(open-input-file-handle filename 'open-input-file)
filename
@ -1263,9 +1264,9 @@
(define (call-with-input-file filename proc)
(unless (string? filename)
(error 'call-with-input-file "invalid filename" filename))
(die 'call-with-input-file "invalid filename" filename))
(unless (procedure? proc)
(error 'call-with-input-file "not a procedure" proc))
(die 'call-with-input-file "not a procedure" proc))
(call-with-port
(fh->input-port
(open-input-file-handle filename 'call-with-input-file)
@ -1277,9 +1278,9 @@
(define (with-input-from-file filename proc)
(unless (string? filename)
(error 'with-input-from-file "invalid filename" filename))
(die 'with-input-from-file "invalid filename" filename))
(unless (procedure? proc)
(error 'with-input-from-file "not a procedure" proc))
(die 'with-input-from-file "not a procedure" proc))
(let ([p
(fh->input-port
(open-input-file-handle filename 'with-input-from-file)
@ -1340,8 +1341,8 @@
void
(lambda () (proc p))
(lambda () (close-port p)))
(error 'call-with-port "not a procedure" proc))
(error 'call-with-port "not a port" p)))
(die 'call-with-port "not a procedure" proc))
(die 'call-with-port "not a port" p)))
(define read-char
(case-lambda
@ -1350,8 +1351,8 @@
(if (input-port? p)
(if (textual-port? p)
(get-char p)
(error 'read-char "not a textual port" p))
(error 'read-char "not an input-port" p))]))
(die 'read-char "not a textual port" p))
(die 'read-char "not an input-port" p))]))
;;;
(define peek-char
(case-lambda
@ -1360,8 +1361,8 @@
(if (input-port? p)
(if (textual-port? p)
(lookahead-char p)
(error 'peek-char "not a textual port" p))
(error 'peek-char "not an input-port" p))]))
(die 'peek-char "not a textual port" p))
(die 'peek-char "not an input-port" p))]))
(define (get-bytevector-n p n)
(import (ikarus system $fx) (ikarus system $bytevectors))
@ -1374,11 +1375,11 @@
p
(f s n p))))))
(unless (input-port? p)
(error 'get-bytevector-n "not an input port" p))
(die 'get-bytevector-n "not an input port" p))
(unless (binary-port? p)
(error 'get-bytevector-n "not a binary port" p))
(die 'get-bytevector-n "not a binary port" p))
(unless (fixnum? n)
(error 'get-bytevector-n "count is not a fixnum" n))
(die 'get-bytevector-n "count is not a fixnum" n))
(cond
[($fx> n 0)
(let ([s ($make-bytevector n)])
@ -1396,30 +1397,30 @@
s
(f p n s i)))]))))]
[($fx= n 0) '#vu8()]
[else (error 'get-bytevector-n "count is negative" n)]))
[else (die 'get-bytevector-n "count is negative" n)]))
(define (get-bytevector-n! p s i c)
(import (ikarus system $fx) (ikarus system $bytevectors))
(unless (input-port? p)
(error 'get-bytevector-n! "not an input port" p))
(die 'get-bytevector-n! "not an input port" p))
(unless (binary-port? p)
(error 'get-bytevector-n! "not a binary port" p))
(die 'get-bytevector-n! "not a binary port" p))
(unless (bytevector? s)
(error 'get-bytevector-n! "not a bytevector" s))
(die 'get-bytevector-n! "not a bytevector" s))
(let ([len ($bytevector-length s)])
(unless (fixnum? i)
(error 'get-bytevector-n! "starting index is not a fixnum" i))
(die 'get-bytevector-n! "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'get-bytevector-n!
(die 'get-bytevector-n!
(format "starting index is out of range 0..~a" len)
i))
(unless (fixnum? c)
(error 'get-bytevector-n! "count is not a fixnum" c))
(die 'get-bytevector-n! "count is not a fixnum" c))
(cond
[($fx> c 0)
(let ([j (+ i c)])
(when (> j len)
(error 'get-bytevector-n!
(die 'get-bytevector-n!
(format "count is out of range 0..~a" (- len i))
c))
(let ([x (get-u8 p)])
@ -1438,7 +1439,7 @@
i
(f p s start i c)))])))])))]
[($fx= c 0) 0]
[else (error 'get-bytevector-n! "count is negative" c)])))
[else (die 'get-bytevector-n! "count is negative" c)])))
(define-rrr get-bytevector-some)
@ -1462,17 +1463,17 @@
(if (input-port? p)
(if (binary-port? p)
(get-it p)
(error 'get-bytevector-all "not a binary port" p))
(error 'get-bytevector-all "not an input port" p)))
(die 'get-bytevector-all "not a binary port" p))
(die 'get-bytevector-all "not an input port" p)))
(define (get-string-n p n)
(import (ikarus system $fx) (ikarus system $strings))
(unless (input-port? p)
(error 'get-string-n "not an input port" p))
(die 'get-string-n "not an input port" p))
(unless (textual-port? p)
(error 'get-string-n "not a textual port" p))
(die 'get-string-n "not a textual port" p))
(unless (fixnum? n)
(error 'get-string-n "count is not a fixnum" n))
(die 'get-string-n "count is not a fixnum" n))
(cond
[($fx> n 0)
(let ([s ($make-string n)])
@ -1490,30 +1491,30 @@
s
(f p n s i)))]))))]
[($fx= n 0) ""]
[else (error 'get-string-n "count is negative" n)]))
[else (die 'get-string-n "count is negative" n)]))
(define (get-string-n! p s i c)
(import (ikarus system $fx) (ikarus system $strings))
(unless (input-port? p)
(error 'get-string-n! "not an input port" p))
(die 'get-string-n! "not an input port" p))
(unless (textual-port? p)
(error 'get-string-n! "not a textual port" p))
(die 'get-string-n! "not a textual port" p))
(unless (string? s)
(error 'get-string-n! "not a string" s))
(die 'get-string-n! "not a string" s))
(let ([len ($string-length s)])
(unless (fixnum? i)
(error 'get-string-n! "starting index is not a fixnum" i))
(die 'get-string-n! "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'get-string-n!
(die 'get-string-n!
(format "starting index is out of range 0..~a" len)
i))
(unless (fixnum? c)
(error 'get-string-n! "count is not a fixnum" c))
(die 'get-string-n! "count is not a fixnum" c))
(cond
[($fx> c 0)
(let ([j (+ i c)])
(when (> j len)
(error 'get-string-n!
(die 'get-string-n!
(format "count is out of range 0..~a" (- len i))
c))
(let ([x (get-char p)])
@ -1532,7 +1533,7 @@
i
(f p s start i c)))])))])))]
[($fx= c 0) 0]
[else (error 'get-string-n! "count is negative" c)])))
[else (die 'get-string-n! "count is negative" c)])))
(define (get-line p)
(import UNSAFE)
@ -1555,8 +1556,8 @@
(if (input-port? p)
(if (textual-port? p)
(get-it p)
(error 'get-line "not a textual port" p))
(error 'get-line "not an input port" p)))
(die 'get-line "not a textual port" p))
(die 'get-line "not an input port" p)))
(define (get-string-all p)
@ -1579,8 +1580,8 @@
(if (input-port? p)
(if (textual-port? p)
(get-it p)
(error 'get-string-all "not a textual port" p))
(error 'get-string-all "not an input port" p)))
(die 'get-string-all "not a textual port" p))
(die 'get-string-all "not an input port" p)))
@ -1598,7 +1599,7 @@
(bytevector-u8-set! ($port-buffer p) i b)
($set-port-index! p (fx+ i 1))]
[else
(error who "insufficient space on port" p)]))]
(die who "insufficient space on port" p)]))]
[(fx<= b #x7FF)
(let ([i ($port-index p)]
[j ($port-size p)]
@ -1657,14 +1658,14 @@
(bytevector-u8-set! ($port-buffer p) i b)
($set-port-index! p (fx+ i 1))]
[else
(error who "insufficient space in port" p)]))]
(die who "insufficient space in port" p)]))]
[else
(case (transcoder-error-handling-mode (port-transcoder p))
[(ignore) (void)]
[(replace) (put-char p #\?)]
[(raise)
(raise (make-i/o-encoding-error p))]
[else (error who "BUG: invalid error handling mode" p)])]))
[else (die who "BUG: invalid die handling mode" p)])]))
(define (put-char-char-mode p c who)
(flush-output-port p)
(let ([i ($port-index p)] [j ($port-size p)])
@ -1673,7 +1674,7 @@
(string-set! ($port-buffer p) i c)
($set-port-index! p (fx+ i 1))]
[else
(error who "insufficient space in port" p)])))
(die who "insufficient space in port" p)])))
;;;
(define write-char
(case-lambda
@ -1682,17 +1683,17 @@
(define (put-char p c)
(do-put-char p c 'put-char))
(define (put-string p str)
(unless (string? str) (error 'put-string "not a string" str))
(unless (string? str) (die 'put-string "not a string" str))
(unless (output-port? p)
(error 'put-string "not an output port" p))
(die 'put-string "not an output port" p))
(unless (textual-port? p)
(error 'put-string "not a textual port" p))
(die 'put-string "not a textual port" p))
(let f ([i 0] [n (string-length str)])
(unless (fx= i n)
(do-put-char p (string-ref str i) 'put-string)
(f (fx+ i 1) n))))
(define (do-put-char p c who)
(unless (char? c) (error who "not a char" c))
(unless (char? c) (die who "not a char" c))
(let ([m ($port-fast-attrs p)])
(cond
[(eq? m fast-put-utf8-tag)
@ -1723,8 +1724,8 @@
(put-char-latin-mode p b who)])))]
[else
(if (output-port? p)
(error who "not a textual port" p)
(error who "not an output port" p))]))))
(die who "not a textual port" p)
(die who "not an output port" p))]))))
(define newline
(case-lambda
@ -1733,11 +1734,11 @@
(flush-output-port (*the-output-port*))]
[(p)
(unless (output-port? p)
(error 'newline "not an output port" p))
(die 'newline "not an output port" p))
(unless (textual-port? p)
(error 'newline "not a textual port" p))
(die 'newline "not a textual port" p))
(when ($port-closed? p)
(error 'newline "port is closed" p))
(die 'newline "port is closed" p))
(put-char p #\newline)
(flush-output-port p)]))
@ -1753,13 +1754,13 @@
(when (or (not (fixnum? bytes))
(fx< bytes 0)
(fx> bytes i))
(error who "write! returned an invalid value" bytes))
(die who "write! returned an invalid value" bytes))
(cond
[(fx= bytes i)
(bytevector-u8-set! buf 0 b)
($set-port-index! p 1)]
[(fx= bytes 0)
(error who "could not write bytes to sink")]
(die who "could not write bytes to sink")]
[else
(let ([i (fx- i bytes)])
(bytevector-copy! buf bytes buf 0 i)
@ -1768,7 +1769,7 @@
;;;
(define (put-u8 p b)
(define who 'put-u8)
(unless (u8? b) (error who "not a u8" b))
(unless (u8? b) (die who "not a u8" b))
(let ([m ($port-fast-attrs p)])
(cond
[(eq? m fast-put-byte-tag)
@ -1781,8 +1782,8 @@
(put-u8-byte-mode p b who)]))]
[else
(if (output-port? p)
(error who "not a binary port" p)
(error who "not an output port" p))]))))
(die who "not a binary port" p)
(die who "not an output port" p))]))))
)

348
scheme/ikarus.lists.ss
View File

@ -70,11 +70,11 @@
[(n)
(if (and (fixnum? n) ($fx>= n 0))
(f n (void) '())
(error 'make-list "not a valid length" n))]
(die 'make-list "not a valid length" n))]
[(n fill)
(if (and (fixnum? n) ($fx>= n 0))
(f n fill '())
(error 'make-list "not a valid length" n))])))
(die 'make-list "not a valid length" n))])))
(define length
@ -85,13 +85,13 @@
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'length "circular list" ls))
(die 'length "circular list" ls))
(if (null? h)
($fx+ n 1)
(error 'length "not a proper list" ls))))
(die 'length "not a proper list" ls))))
(if (null? h)
n
(error 'length "not a proper list" ls))))])
(die 'length "not a proper list" ls))))])
(lambda (ls)
(race ls ls ls 0))))
@ -103,14 +103,14 @@
[($fxzero? i)
(if (pair? ls)
($car ls)
(error 'list-ref "index is out of range" index list))]
(die 'list-ref "index is out of range" index list))]
[(pair? ls)
(f ($cdr ls) ($fxsub1 i))]
[(null? ls)
(error 'list-rec "index is out of range" index list)]
[else (error 'list-ref "not a list" list)])))
(die 'list-rec "index is out of range" index list)]
[else (die 'list-ref "not a list" list)])))
(unless (and (fixnum? index) ($fx>= index 0))
(error 'list-ref "not a valid index" index))
(die 'list-ref "not a valid index" index))
(f list index)))
@ -123,10 +123,10 @@
[(pair? ls)
(f ($cdr ls) ($fxsub1 i))]
[(null? ls)
(error 'list-tail "index is out of range" index list)]
[else (error 'list-tail "not a list" list)])))
(die 'list-tail "index is out of range" index list)]
[else (die 'list-tail "not a list" list)])))
(unless (and (fixnum? index) ($fx>= index 0))
(error 'list-tail "not a valid index" index))
(die 'list-tail "not a valid index" index))
(f list index)))
(module (append)
@ -138,13 +138,13 @@
(if (not (eq? h t))
(let ([a2 ($car h)])
(reverse ($cdr h) ($cdr t) ls (cons a2 (cons a1 ac))))
(error 'append "circular list" ls))
(die 'append "circular list" ls))
(if (null? h)
(cons a1 ac)
(error 'append "not a proper list" ls))))
(die 'append "not a proper list" ls))))
(if (null? h)
ac
(error 'append "not a proper list" ls)))))
(die 'append "not a proper list" ls)))))
(define revcons
(lambda (ls ac)
(cond
@ -173,13 +173,13 @@
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls (cons ($car h) ac))
(error 'reverse "circular list" ls))
(die 'reverse "circular list" ls))
(if (null? h)
ac
(error 'reverse "not a proper list" ls))))
(die 'reverse "not a proper list" ls))))
(if (null? h)
ac
(error 'reverse "not a proper list" ls))))])
(die 'reverse "not a proper list" ls))))])
(lambda (x)
(race x x x '()))))
@ -191,14 +191,14 @@
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls h)
(error 'last-pair "circular list" ls))
(die 'last-pair "circular list" ls))
last))
last))])
(lambda (x)
(if (pair? x)
(let ([d (cdr x)])
(race d d x x))
(error 'last-pair "not a pair" x)))))
(die 'last-pair "not a pair" x)))))
(define memq
(letrec ([race
@ -212,13 +212,13 @@
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'memq "circular list" ls)))
(die 'memq "circular list" ls)))
(if (null? h)
'#f
(error 'memq "not a proper list" ls)))))
(die 'memq "not a proper list" ls)))))
(if (null? h)
'#f
(error 'memq "not a proper list" ls))))])
(die 'memq "not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
@ -234,13 +234,13 @@
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'memv "circular list" ls)))
(die 'memv "circular list" ls)))
(if (null? h)
'#f
(error 'memv "not a proper list" ls)))))
(die 'memv "not a proper list" ls)))))
(if (null? h)
'#f
(error 'memv "not a proper list" ls))))])
(die 'memv "not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
@ -256,13 +256,13 @@
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'member "circular list" ls)))
(die 'member "circular list" ls)))
(if (null? h)
'#f
(error 'member "not a proper list" ls)))))
(die 'member "not a proper list" ls)))))
(if (null? h)
'#f
(error 'member "not a proper list" ls))))])
(die 'member "not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
@ -279,16 +279,16 @@
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls p)
(error 'memp "circular list" ls)))
(die 'memp "circular list" ls)))
(if (null? h)
'#f
(error 'memp "not a proper list" ls)))))
(die 'memp "not a proper list" ls)))))
(if (null? h)
'#f
(error 'memp "not a proper list" ls))))])
(die 'memp "not a proper list" ls))))])
(lambda (p ls)
(unless (procedure? p)
(error 'memp "not a procedure" p))
(die 'memp "not a procedure" p))
(race ls ls ls p))))
(define find
@ -305,16 +305,16 @@
a
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls p)
(error 'find "circular list" ls))))
(die 'find "circular list" ls))))
(if (null? h)
'#f
(error 'find "not a proper list" ls))))))
(die 'find "not a proper list" ls))))))
(if (null? h)
'#f
(error 'find "not a proper list" ls))))])
(die 'find "not a proper list" ls))))])
(lambda (p ls)
(unless (procedure? p)
(error 'find "not a procedure" p))
(die 'find "not a procedure" p))
(race ls ls ls p))))
(define assq
@ -332,16 +332,16 @@
(if (eq? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assq "malformed alist"
(die 'assq "malformed alist"
ls)))
(error 'assq "circular list" ls))
(die 'assq "circular list" ls))
(if (null? h)
#f
(error 'assq "not a proper list" ls))))
(error 'assq "malformed alist" ls)))
(die 'assq "not a proper list" ls))))
(die 'assq "malformed alist" ls)))
(if (null? h)
#f
(error 'assq "not a proper list" ls))))])
(die 'assq "not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
@ -361,19 +361,19 @@
(if (p ($car a))
a
(race p ($cdr h) ($cdr t) ls))
(error 'assp "malformed alist"
(die 'assp "malformed alist"
ls)))
(error 'assp "circular list" ls))
(die 'assp "circular list" ls))
(if (null? h)
#f
(error 'assp "not a proper list" ls))))
(error 'assp "malformed alist" ls)))
(die 'assp "not a proper list" ls))))
(die 'assp "malformed alist" ls)))
(if (null? h)
#f
(error 'assp "not a proper list" ls))))])
(die 'assp "not a proper list" ls))))])
(lambda (p ls)
(unless (procedure? p)
(error 'assp "not a procedure" p))
(die 'assp "not a procedure" p))
(race p ls ls ls))))
(define assv
@ -391,16 +391,16 @@
(if (eqv? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assv "malformed alist"
(die 'assv "malformed alist"
ls)))
(error 'assv "circular list" ls))
(die 'assv "circular list" ls))
(if (null? h)
#f
(error 'assv "not a proper list" ls))))
(error 'assv "malformed alist" ls)))
(die 'assv "not a proper list" ls))))
(die 'assv "malformed alist" ls)))
(if (null? h)
#f
(error 'assv "not a proper list" ls))))])
(die 'assv "not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
@ -419,16 +419,16 @@
(if (equal? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assoc "malformed alist"
(die 'assoc "malformed alist"
ls)))
(error 'assoc "circular list" ls))
(die 'assoc "circular list" ls))
(if (null? h)
#f
(error 'assoc "not a proper list" ls))))
(error 'assoc "malformed alist" ls)))
(die 'assoc "not a proper list" ls))))
(die 'assoc "malformed alist" ls)))
(if (null? h)
#f
(error 'assoc "not a proper list" ls))))])
(die 'assoc "not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
@ -448,23 +448,23 @@
(if (cmp ($car h) x)
(race ($cdr h) ($cdr t) ls x)
(cons ($car h) (race ($cdr h) ($cdr t) ls x)))
(error 'name "circular list" ls))
(die 'name "circular list" ls))
(if (null? h)
'()
(error 'name "not a proper list" ls))))
(die 'name "not a proper list" ls))))
(let ([a0 ($car h)] [h ($cdr h)])
(if (pair? h)
(if (not (eq? h t))
(if (cmp ($car h) x)
(cons a0 (race ($cdr h) ($cdr t) ls x))
(cons* a0 ($car h) (race ($cdr h) ($cdr t) ls x)))
(error 'name "circular list" ls))
(die 'name "circular list" ls))
(if (null? h)
(list a0)
(error 'name "not a proper list" ls)))))
(die 'name "not a proper list" ls)))))
(if (null? h)
'()
(error 'name "not a proper list" ls))))])
(die 'name "not a proper list" ls))))])
(lambda (x ls)
(check x ls)
(race ls ls ls x))))]))
@ -474,11 +474,11 @@
(define-remover remp (lambda (elt p) (p elt))
(lambda (x ls)
(unless (procedure? x)
(error 'remp "not a procedure" x))))
(die 'remp "not a procedure" x))))
(define-remover filter (lambda (elt p) (not (p elt)))
(lambda (x ls)
(unless (procedure? x)
(error 'filter "not a procedure" x)))))
(die 'filter "not a procedure" x)))))
(module (map)
@ -489,27 +489,27 @@
(let ([h ($cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "circular list")
(die who "circular list")
(len ($cdr h) ($cdr t) ($fx+ n 2)))
(if (null? h)
($fxadd1 n)
(error who "improper list"))))
(die who "improper list"))))
(if (null? h)
n
(error who "improper list")))))
(die who "improper list")))))
(define map1
(lambda (f a d n)
(cond
[(pair? d)
(if ($fxzero? n)
(error who "list was altered!")
(die who "list was altered!")
(cons (f a)
(map1 f ($car d) ($cdr d) ($fxsub1 n))))]
[(null? d)
(if ($fxzero? n)
(cons (f a) '())
(error who "list was altered"))]
[else (error who "list was altered")])))
(die who "list was altered"))]
[else (die who "list was altered")])))
(define map2
(lambda (f a1 a2 d1 d2 n)
(cond
@ -517,21 +517,21 @@
(cond
[(pair? d2)
(if ($fxzero? n)
(error who "list was altered")
(die who "list was altered")
(cons (f a1 a2)
(map2 f
($car d1) ($car d2)
($cdr d1) ($cdr d2)
($fxsub1 n))))]
[else (error who "length mismatch")])]
[else (die who "length mismatch")])]
[(null? d1)
(cond
[(null? d2)
(if ($fxzero? n)
(cons (f a1 a2) '())
(error who "list was altered"))]
[else (error who "length mismatch")])]
[else (error who "list was altered")])))
(die who "list was altered"))]
[else (die who "length mismatch")])]
[else (die who "list was altered")])))
(define cars
(lambda (ls*)
(cond
@ -542,7 +542,7 @@
[(pair? a)
(cons (car a) (cars (cdr ls*)))]
[else
(error 'map "length mismatch")]))])))
(die 'map "length mismatch")]))])))
(define cdrs
(lambda (ls*)
(cond
@ -553,7 +553,7 @@
[(pair? a)
(cons (cdr a) (cdrs (cdr ls*)))]
[else
(error 'map "length mismatch")]))])))
(die 'map "length mismatch")]))])))
(define mapm
(lambda (f ls ls* n)
(cond
@ -561,10 +561,10 @@
(if (andmap null? ls*)
(if (fxzero? n)
'()
(error 'map "lists were mutated during operation"))
(error 'map "length mismatch"))]
(die 'map "lists were mutated during operation"))
(die 'map "length mismatch"))]
[(fxzero? n)
(error 'map "lists were mutated during operation")]
(die 'map "lists were mutated during operation")]
[else
(cons
(apply f (car ls) (cars ls*))
@ -573,30 +573,30 @@
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(cond
[(pair? ls)
(let ([d ($cdr ls)])
(map1 f ($car ls) d (len d d 0)))]
[(null? ls) '()]
[else (error who "improper list")])]
[else (die who "improper list")])]
[(f ls ls2)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(cond
[(pair? ls)
(if (pair? ls2)
(let ([d ($cdr ls)])
(map2 f ($car ls) ($car ls2) d ($cdr ls2) (len d d 0)))
(error who "length mismatch"))]
(die who "length mismatch"))]
[(null? ls)
(if (null? ls2)
'()
(error who "length mismatch"))]
[else (error who "not a list")])]
(die who "length mismatch"))]
[else (die who "not a list")])]
[(f ls . ls*)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(cond
[(pair? ls)
(let ([n (len ls ls 0)])
@ -604,7 +604,7 @@
[(null? ls)
(if (andmap null? ls*)
'()
(error who "length mismatch"))])])))
(die who "length mismatch"))])])))
(module (for-each)
(define who 'for-each)
@ -614,28 +614,28 @@
(let ([h ($cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "circular list")
(die who "circular list")
(len ($cdr h) ($cdr t) ($fx+ n 2)))
(if (null? h)
($fxadd1 n)
(error who "improper list"))))
(die who "improper list"))))
(if (null? h)
n
(error who "improper list")))))
(die who "improper list")))))
(define for-each1
(lambda (f a d n)
(cond
[(pair? d)
(if ($fxzero? n)
(error who "list was altered!")
(die who "list was altered!")
(begin
(f a)
(for-each1 f ($car d) ($cdr d) ($fxsub1 n))))]
[(null? d)
(if ($fxzero? n)
(f a)
(error who "list was altered"))]
[else (error who "list was altered")])))
(die who "list was altered"))]
[else (die who "list was altered")])))
(define for-each2
(lambda (f a1 a2 d1 d2 n)
(cond
@ -643,67 +643,67 @@
(cond
[(pair? d2)
(if ($fxzero? n)
(error who "list was altered")
(die who "list was altered")
(begin
(f a1 a2)
(for-each2 f
($car d1) ($car d2)
($cdr d1) ($cdr d2)
($fxsub1 n))))]
[else (error who "length mismatch")])]
[else (die who "length mismatch")])]
[(null? d1)
(cond
[(null? d2)
(if ($fxzero? n)
(f a1 a2)
(error who "list was altered"))]
[else (error who "length mismatch")])]
[else (error who "list was altered")])))
(die who "list was altered"))]
[else (die who "length mismatch")])]
[else (die who "list was altered")])))
(define for-each
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(cond
[(pair? ls)
(let ([d ($cdr ls)])
(for-each1 f ($car ls) d (len d d 0)))]
[(null? ls) (void)]
[else (error who "improper list")])]
[else (die who "improper list")])]
[(f ls ls2)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(cond
[(pair? ls)
(if (pair? ls2)
(let ([d ($cdr ls)])
(for-each2 f
($car ls) ($car ls2) d ($cdr ls2) (len d d 0)))
(error who "length mismatch"))]
(die who "length mismatch"))]
[(null? ls)
(if (null? ls2)
(void)
(error who "length mismatch"))]
[else (error who "not a list")])]
(die who "length mismatch"))]
[else (die who "not a list")])]
[(f ls . ls*)
(unless (procedure? f)
(error 'for-each "not a procedure" f))
(die 'for-each "not a procedure" f))
(unless (list? ls)
(error 'for-each "not a list" ls))
(die 'for-each "not a list" ls))
(let ([n (length ls)])
(for-each
(lambda (x)
(unless (and (list? x) (= (length x) n))
(error 'for-each "not a list" x)))
(die 'for-each "not a list" x)))
ls*)
(let loop ([n (length ls)] [ls ls] [ls* ls*])
(cond
[($fx= n 0)
(unless (and (null? ls) (andmap null? ls*))
(error 'for-each "list modified" f))]
(die 'for-each "list modified" f))]
[else
(unless (and (pair? ls) (andmap pair? ls*))
(error 'for-each "list modified" f))
(die 'for-each "list modified" f))
(apply f (car ls) (map car ls*))
(loop (fx- n 1) (cdr ls) (map cdr ls*))])))])))
@ -715,27 +715,27 @@
(let ([h ($cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "circular list")
(die who "circular list")
(len ($cdr h) ($cdr t) ($fx+ n 2)))
(if (null? h)
($fxadd1 n)
(error who "improper list"))))
(die who "improper list"))))
(if (null? h)
n
(error who "improper list")))))
(die who "improper list")))))
(define andmap1
(lambda (f a d n)
(cond
[(pair? d)
(if ($fxzero? n)
(error who "list was altered!")
(die who "list was altered!")
(and (f a)
(andmap1 f ($car d) ($cdr d) ($fxsub1 n))))]
[(null? d)
(if ($fxzero? n)
(f a)
(error who "list was altered"))]
[else (error who "list was altered")])))
(die who "list was altered"))]
[else (die who "list was altered")])))
(define andmap2
(lambda (f a1 a2 d1 d2 n)
(cond
@ -743,52 +743,52 @@
(cond
[(pair? d2)
(if ($fxzero? n)
(error who "list was altered")
(die who "list was altered")
(and
(f a1 a2)
(andmap2 f
($car d1) ($car d2)
($cdr d1) ($cdr d2)
($fxsub1 n))))]
[else (error who "length mismatch")])]
[else (die who "length mismatch")])]
[(null? d1)
(cond
[(null? d2)
(if ($fxzero? n)
(f a1 a2)
(error who "list was altered"))]
[else (error who "length mismatch")])]
[else (error who "list was altered")])))
(die who "list was altered"))]
[else (die who "length mismatch")])]
[else (die who "list was altered")])))
(define andmap
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(cond
[(pair? ls)
(let ([d ($cdr ls)])
(andmap1 f ($car ls) d (len d d 0)))]
[(null? ls) #t]
[else (error who "improper list")])]
[else (die who "improper list")])]
[(f ls ls2)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(cond
[(pair? ls)
(if (pair? ls2)
(let ([d ($cdr ls)])
(andmap2 f
($car ls) ($car ls2) d ($cdr ls2) (len d d 0)))
(error who "length mismatch"))]
(die who "length mismatch"))]
[(null? ls)
(if (null? ls2)
#t
(error who "length mismatch"))]
[else (error who "not a list")])]
(die who "length mismatch"))]
[else (die who "not a list")])]
[(f ls . ls*)
(unless (procedure? f)
(error who "not a procedure" f))
(error who "vararg not yet supported")])))
(die who "not a procedure" f))
(die who "vararg not yet supported")])))
@ -801,39 +801,39 @@
(let ([h ($cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "circular list")
(die who "circular list")
(len ($cdr h) ($cdr t) ($fx+ n 2)))
(if (null? h)
($fxadd1 n)
(error who "improper list"))))
(die who "improper list"))))
(if (null? h)
n
(error who "improper list")))))
(die who "improper list")))))
(define ormap1
(lambda (f a d n)
(cond
[(pair? d)
(if ($fxzero? n)
(error who "list was altered!")
(die who "list was altered!")
(or (f a)
(ormap1 f ($car d) ($cdr d) ($fxsub1 n))))]
[(null? d)
(if ($fxzero? n)
(f a)
(error who "list was altered"))]
[else (error who "list was altered")])))
(die who "list was altered"))]
[else (die who "list was altered")])))
(define ormap
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(cond
[(pair? ls)
(let ([d ($cdr ls)])
(ormap1 f ($car ls) d (len d d 0)))]
[(null? ls) #f]
[else (error who "improper list")])]
[_ (error who "vararg not supported yet")])))
[else (die who "improper list")])]
[_ (die who "vararg not supported yet")])))
@ -844,7 +844,7 @@
(let ([a0 ($car h)] [h ($cdr h)])
(if (pair? h)
(if (eq? h t)
(error 'partition "circular list" ls)
(die 'partition "circular list" ls)
(let ([a1 ($car h)])
(let-values ([(a* b*) (race ($cdr h) ($cdr t) ls p)])
(if (p a0)
@ -858,13 +858,13 @@
(if (p a0)
(values (list a0) '())
(values '() (list a0)))
(error 'parititon "not a proper list" ls))))
(die 'parititon "not a proper list" ls))))
(if (null? h)
(values '() '())
(error 'parition "not a proper list" ls))))])
(die 'parition "not a proper list" ls))))])
(lambda (p ls)
(unless (procedure? p)
(error 'partition "not a procedure" p))
(die 'partition "not a procedure" p))
(race ls ls ls p))))
@ -878,10 +878,10 @@
(or (null? ls) (and (null? (car ls)) (null*? (cdr ls)))))
(define (err* ls*)
(if (null? ls*)
(error who "length mismatch")
(die who "length mismatch")
(if (list? (car ls*))
(err* (cdr ls*))
(error who "not a proper list" (car ls*)))))
(die who "not a proper list" (car ls*)))))
(define (cars+cdrs ls ls*)
(cond
[(null? ls) (values '() '())]
@ -891,23 +891,23 @@
(let-values ([(cars cdrs) (cars+cdrs (cdr ls) (cdr ls*))])
(values (cons (car a) cars) (cons (cdr a) cdrs)))
(if (list? (car ls*))
(error who "length mismatch")
(error who "not a proper list" (car ls*)))))]))
(die who "length mismatch")
(die who "not a proper list" (car ls*)))))]))
(define (loop1 f a h t ls)
(if (pair? h)
(let ([b (car h)] [h (cdr h)])
(combine (f a)
(if (pair? h)
(if (eq? h t)
(error who "circular" ls)
(die who "circular" ls)
(let ([c (car h)] [h (cdr h)])
(combine (f b) (loop1 f c h (cdr t) ls))))
(if (null? h)
(f b)
(combine (f b) (error who "not a proper list" ls))))))
(combine (f b) (die who "not a proper list" ls))))))
(if (null? h)
(f a)
(combine (f a) (error who "not a proper list" ls)))))
(combine (f a) (die who "not a proper list" ls)))))
(define (loopn f a a* h h* t ls ls*)
(if (pair? h)
(let-values ([(b* h*) (cars+cdrs h* ls*)])
@ -915,7 +915,7 @@
(combine (apply f a a*)
(if (pair? h)
(if (eq? h t)
(error who "circular" ls)
(die who "circular" ls)
(let-values ([(c* h*) (cars+cdrs h* ls*)])
(let ([c (car h)] [h (cdr h)])
(combine (apply f b b*)
@ -930,15 +930,15 @@
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(if (pair? ls)
(loop1 f (car ls) (cdr ls) (cdr ls) ls)
(if (null? ls)
(combine)
(error who "not a list" ls)))]
(die who "not a list" ls)))]
[(f ls . ls*)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(if (pair? ls)
(let-values ([(cars cdrs) (cars+cdrs ls* ls*)])
(loopn f (car ls) cars (cdr ls) cdrs (cdr ls) ls ls*))
@ -955,10 +955,10 @@
(or (null? ls) (and (null? (car ls)) (null*? (cdr ls)))))
(define (err* ls*)
(if (null? ls*)
(error who "length mismatch")
(die who "length mismatch")
(if (list? (car ls*))
(err* (cdr ls*))
(error who "not a proper list" (car ls*)))))
(die who "not a proper list" (car ls*)))))
(define (cars+cdrs ls ls*)
(cond
[(null? ls) (values '() '())]
@ -968,29 +968,29 @@
(let-values ([(cars cdrs) (cars+cdrs (cdr ls) (cdr ls*))])
(values (cons (car a) cars) (cons (cdr a) cdrs)))
(if (list? (car ls*))
(error who "length mismatch")
(error who "not a proper list" (car ls*)))))]))
(die who "length mismatch")
(die who "not a proper list" (car ls*)))))]))
(define (loop1 f nil h t ls)
(if (pair? h)
(let ([a (car h)] [h (cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "circular" ls)
(die who "circular" ls)
(let ([b (car h)] [h (cdr h)] [t (cdr t)])
(loop1 f (f (f nil a) b) h t ls)))
(if (null? h)
(f nil a)
(error who "not a proper list" ls))))
(die who "not a proper list" ls))))
(if (null? h)
nil
(error who "not a proper list" ls))))
(die who "not a proper list" ls))))
(define (loopn f nil h h* t ls ls*)
(if (pair? h)
(let-values ([(a* h*) (cars+cdrs h* ls*)])
(let ([a (car h)] [h (cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "circular" ls)
(die who "circular" ls)
(let-values ([(b* h*) (cars+cdrs h* ls*)])
(let ([b (car h)] [h (cdr h)] [t (cdr t)])
(loopn f
@ -1006,11 +1006,11 @@
(case-lambda
[(f nil ls)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(loop1 f nil ls ls ls)]
[(f nil ls . ls*)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(loopn f nil ls ls* ls ls ls*)])))
(module (fold-right)
@ -1019,10 +1019,10 @@
(or (null? ls) (and (null? (car ls)) (null*? (cdr ls)))))
(define (err* ls*)
(if (null? ls*)
(error who "length mismatch")
(die who "length mismatch")
(if (list? (car ls*))
(err* (cdr ls*))
(error who "not a proper list" (car ls*)))))
(die who "not a proper list" (car ls*)))))
(define (cars+cdrs ls ls*)
(cond
[(null? ls) (values '() '())]
@ -1032,29 +1032,29 @@
(let-values ([(cars cdrs) (cars+cdrs (cdr ls) (cdr ls*))])
(values (cons (car a) cars) (cons (cdr a) cdrs)))
(if (list? (car ls*))
(error who "length mismatch")
(error who "not a proper list" (car ls*)))))]))
(die who "length mismatch")
(die who "not a proper list" (car ls*)))))]))
(define (loop1 f nil h t ls)
(if (pair? h)
(let ([a (car h)] [h (cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "circular" ls)
(die who "circular" ls)
(let ([b (car h)] [h (cdr h)] [t (cdr t)])
(f a (f b (loop1 f nil h t ls)))))
(if (null? h)
(f a nil)
(error who "not a proper list" ls))))
(die who "not a proper list" ls))))
(if (null? h)
nil
(error who "not a proper list" ls))))
(die who "not a proper list" ls))))
(define (loopn f nil h h* t ls ls*)
(if (pair? h)
(let-values ([(a* h*) (cars+cdrs h* ls*)])
(let ([a (car h)] [h (cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "circular" ls)
(die who "circular" ls)
(let-values ([(b* h*) (cars+cdrs h* ls*)])
(let ([b (car h)] [h (cdr h)] [t (cdr t)])
(apply f a
@ -1073,11 +1073,11 @@
(case-lambda
[(f nil ls)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(loop1 f nil ls ls ls)]
[(f nil ls . ls*)
(unless (procedure? f)
(error who "not a procedure" f))
(die who "not a procedure" f))
(loopn f nil ls ls* ls ls ls*)]
)))

4
scheme/ikarus.load.ss
View File

@ -35,9 +35,9 @@
[(x) (load x load-handler)]
[(x eval-proc)
(unless (string? x)
(error 'load "not a string" x))
(die 'load "not a string" x))
(unless (procedure? eval-proc)
(error 'load "not a procedure" eval-proc))
(die 'load "not a procedure" eval-proc))
(let ([p (open-input-file x)])
(let ([x (read-initial p)])
(unless (eof-object? x)

4
scheme/ikarus.main.ss
View File

@ -77,14 +77,14 @@
(let ([d (cdr args)])
(cond
[(null? d)
(error 'ikarus "--script requires a script name")]
(die 'ikarus "--script requires a script name")]
[else
(values '() (car d) 'script (cdr d))]))]
[(string=? (car args) "--r6rs-script")
(let ([d (cdr args)])
(cond
[(null? d)
(error 'ikarus "--r6rs-script requires a script name")]
(die 'ikarus "--r6rs-script requires a script name")]
[else
(values '() (car d) 'r6rs-script (cdr d))]))]
[else

534
scheme/ikarus.numerics.ss
View File

File diff suppressed because it is too large Load Diff

6
scheme/ikarus.pairs.ss
View File

@ -39,13 +39,13 @@
(define set-car!
(lambda (x y)
(unless (pair? x)
(error 'set-car! "not a pair" x))
(die 'set-car! "not a pair" x))
($set-car! x y)))
(define set-cdr!
(lambda (x y)
(unless (pair? x)
(error 'set-cdr! "not a pair" x))
(die 'set-cdr! "not a pair" x))
($set-cdr! x y)))
(define-syntax cxr
@ -65,7 +65,7 @@
(begin
(define name*
(lambda (x)
((cxr (error 'name* "invalid list structure" x) ops** ...)
((cxr (die 'name* "invalid list structure" x) ops** ...)
x)))
...)]))

42
scheme/ikarus.posix.ss
View File

@ -33,55 +33,55 @@
(cond
[(fx= pid 0) (child-proc)]
[(fx= pid -1)
(error 'fork "failed")]
(die 'fork "failed")]
[else (parent-proc pid)]))))
(define waitpid
(lambda (pid)
(unless (fixnum? pid)
(error 'waitpid "not a fixnum" pid))
(die 'waitpid "not a fixnum" pid))
(foreign-call "ikrt_waitpid" pid)))
(define system
(lambda (x)
(unless (string? x)
(error 'system "not a string" x))
(die 'system "not a string" x))
(let ([rv (foreign-call "ik_system"
(string->utf8 x))])
(if (fx= rv -1)
(error 'system "failed")
(die 'system "failed")
rv))))
(define file-exists?
(lambda (x)
(unless (string? x)
(error 'file-exists? "filename is not a string" x))
(die 'file-exists? "filename is not a string" x))
(let ([v (foreign-call "ikrt_file_exists"
(string->utf8 x))])
(cond
[(boolean? v) v]
[else
(error 'file-exists?
(die 'file-exists?
(case v
[(1) "the path contains a non-directory"]
[(2) "the path is too long"]
[(3) "the path is not accessible"]
[(4) "the path contains too many symbolic links"]
[(5) "internal access error while accessing"]
[(6) "IO error encountered while accessing"]
[else "Unknown error"])
[(5) "internal access die while accessing"]
[(6) "IO die encountered while accessing"]
[else "Unknown die"])
x)]))))
(define delete-file
(lambda (x)
(unless (string? x)
(error 'delete-file "filename is not a string" x))
(die 'delete-file "filename is not a string" x))
(let ([v (foreign-call "ikrt_delete_file"
(string->utf8 x))])
(case v
[(0) (void)]
[else
(error 'delete-file
(die 'delete-file
(case v
[(1) "the path contains a non-directory"]
[(2) "the path is too long"]
@ -90,10 +90,10 @@
[(5) "the path contains too many symbolic links"]
[(6) "you do not have permissions to delete file"]
[(7) "device is busy"]
[(8) "IO error encountered while deleting"]
[(8) "IO die encountered while deleting"]
[(9) "is in a read-only file system"]
[(10) "internal access error while deleting"]
[else "Unknown error while deleting"])
[(10) "internal access die while deleting"]
[else "Unknown die while deleting"])
x)]))))
(define ($getenv-bv key)
@ -104,7 +104,7 @@
(define (getenv key)
(if (string? key)
($getenv-str key)
(error 'getenv "the key is not a string" key)))
(die 'getenv "the key is not a string" key)))
(define env
(let ()
@ -113,20 +113,20 @@
[(key)
(if (string? key)
(foreign-call "ikrt_getenv" key)
(error 'env "the key is not a string" key))]
(die 'env "the key is not a string" key))]
[(key val) (env key val #t)]
[(key val overwrite?)
(if (string? key)
(if (string? val)
(unless (foreign-call "ikrt_setenv" key val overwrite?)
(error 'env "failed" key val))
(error 'env "the value is not a string" val))
(error 'env "the key is not a string" key))]))
(define busted (lambda args (error 'env "BUG: busted!")))
(die 'env "failed" key val))
(die 'env "the value is not a string" val))
(die 'env "the key is not a string" key))]))
(define busted (lambda args (die 'env "BUG: busted!")))
busted))
(define environ (lambda args (error 'environ "busted!")))
(define environ (lambda args (die 'environ "busted!")))
(define environ^
(lambda ()
(map

18
scheme/ikarus.predicates.ss
View File

@ -121,7 +121,7 @@
[(sys:ratnum? x) #t]
[(sys:flonum? x) #f]
[else
(error 'exact? "not a number" x)])))
(die 'exact? "not a number" x)])))
(define inexact?
@ -132,7 +132,7 @@
[(sys:bignum? x) #f]
[(sys:ratnum? x) #f]
[else
(error 'inexact? "not a number" x)])))
(die 'inexact? "not a number" x)])))
(define finite?
(lambda (x)
@ -142,7 +142,7 @@
[(sys:bignum? x) #t]
[(sys:ratnum? x) #t]
[else
(error 'finite? "not a number" x)])))
(die 'finite? "not a number" x)])))
(define infinite?
(lambda (x)
@ -152,7 +152,7 @@
[(sys:bignum? x) #f]
[(sys:ratnum? x) #f]
[else
(error 'infinite? "not a number" x)])))
(die 'infinite? "not a number" x)])))
(define nan?
(lambda (x)
@ -162,7 +162,7 @@
[(sys:bignum? x) #f]
[(sys:ratnum? x) #f]
[else
(error 'nan? "not a number" x)])))
(die 'nan? "not a number" x)])))
@ -204,8 +204,8 @@
#t
(if (sys:boolean? y)
#f
(error 'boolean=? "not a boolean" y)))
(error 'boolean=? "not a boolean" x))))
(die 'boolean=? "not a boolean" y)))
(die 'boolean=? "not a boolean" x))))
(define symbol=?
@ -215,8 +215,8 @@
#t
(if (sys:symbol? y)
#f
(error 'symbol=? "not a symbol" y)))
(error 'symbol=? "not a symbol" x))))
(die 'symbol=? "not a symbol" y)))
(die 'symbol=? "not a symbol" x))))
(module (equal?)
(define vector-loop

12
scheme/ikarus.pretty-print.ss
View File

@ -31,7 +31,7 @@
(make-parameter 60
(lambda (x)
(unless (and (exact? x) (integer? x) (> x 0))
(error 'pretty-width "invalid argument" x))
(die 'pretty-width "invalid argument" x))
x)))
(define (pretty-indent) 1)
@ -48,7 +48,7 @@
[(mbox? x) (mbox-length x)]
[(vbox? x) (vbox-length x)]
[(fbox? x) (fbox-length x)]
[else (error 'boxify "invalid box" x)]))
[else (die 'boxify "invalid box" x)]))
(define (boxify x)
(define (conc . a*)
(let ([n
@ -459,7 +459,7 @@
[(mbox? x) (output-mbox x p col)]
[(vbox? x) (output-vbox x p col)]
[(fbox? x) (output-fbox x p col)]
[else (error 'pretty-print-output "invalid" x)]))
[else (die 'pretty-print-output "invalid" x)]))
(f x p 0)
(newline p))
;;;
@ -608,7 +608,7 @@
[(x p)
(if (output-port? p)
(pretty x p)
(error 'pretty-print "not an output port" p))]))
(die 'pretty-print "not an output port" p))]))
;;; standard formats
(set-fmt! 'quote '(read-macro . "'"))
(set-fmt! 'unquote '(read-macro . ","))
@ -675,7 +675,7 @@
[(x p)
(if (output-port? p)
(pretty x p)
(error 'pretty-print "not an output port" p))])))
(die 'pretty-print "not an output port" p))])))
(test '(384 7384 83947 893478 9137489 3894789 134789314 79817238
97314897 318947138974 981374 89137489 1374897 13498713
@ -706,5 +706,5 @@
(with-input-from-file fname read))])
(if (equal? x y)
(f (fxadd1 i))
(error 'test-file "mismatch" x y)))))))))
(die 'test-file "mismatch" x y)))))))))

4
scheme/ikarus.promises.ss
View File

@ -21,12 +21,12 @@
(define (force x)
(unless (procedure? x)
(error 'force "not a procedure" x))
(die 'force "not a procedure" x))
(x))
(define (make-promise proc)
(unless (procedure? proc)
(error 'make-promise "not a procedure" proc))
(die 'make-promise "not a procedure" proc))
(let ([results #f])
(lambda ()
(if results

184
scheme/ikarus.reader.ss
View File

@ -79,13 +79,13 @@
(read-char p)
(tokenize-backslash ls p)]
[else
(error 'tokenize "invalid identifier syntax"
(die 'tokenize "invalid identifier syntax"
(list->string (reverse (cons c ls))))]))))
(define (tokenize-string ls p)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof inside string")]
(die 'tokenize "invalid eof inside string")]
[else (tokenize-string-char ls p c)])))
(define (tokenize-string-char ls p c)
(define (intraline-whitespace? c)
@ -94,13 +94,13 @@
(define (tokenize-string-continue ls p c)
(cond
[(eof-object? c)
(error 'tokenize "invalid eof inside string")]
(die 'tokenize "invalid eof inside string")]
[(intraline-whitespace? c)
(let f ()
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof inside string")]
(die 'tokenize "invalid eof inside string")]
[(intraline-whitespace? c) (f)]
[else (tokenize-string-char ls p c)])))]
[else (tokenize-string-char ls p c)]))
@ -110,7 +110,7 @@
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof after string escape")]
(die 'tokenize "invalid eof after string escape")]
[($char= #\a c) (tokenize-string (cons #\x7 ls) p)]
[($char= #\b c) (tokenize-string (cons #\x8 ls) p)]
[($char= #\t c) (tokenize-string (cons #\x9 ls) p)]
@ -124,32 +124,32 @@
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof inside string")]
(die 'tokenize "invalid eof inside string")]
[(hex c) =>
(lambda (n)
(let f ([n n])
(let ([c (read-char p)])
(cond
[(eof-object? n)
(error 'tokenize "invalid eof inside string")]
(die 'tokenize "invalid eof inside string")]
[(hex c) =>
(lambda (v) (f (+ (* n 16) v)))]
[($char= c #\;)
(tokenize-string
(cons (integer->char n) ls) p)]
[else
(error 'tokenize
(die 'tokenize
"invalid char in escape sequence"
c)]))))]
[else
(error 'tokenize
(die 'tokenize
"invalid char in escape sequence" c)]))]
[(intraline-whitespace? c)
(let f ()
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof inside string")]
(die 'tokenize "invalid eof inside string")]
[(intraline-whitespace? c) (f)]
[(memv c '(#\xA #\x85 #\x2028))
(tokenize-string-continue ls p (read-char p))]
@ -161,7 +161,7 @@
[else
(tokenize-string-continue ls p c)]))]
[else
(error 'tokenize
(die 'tokenize
"non-whitespace character after escape")])))]
[(memv c '(#\xA #\x85 #\x2028))
(tokenize-string-continue ls p (read-char p))]
@ -172,7 +172,7 @@
(tokenize-string-continue ls p (read-char p))]
[else
(tokenize-string-continue ls p c)]))]
[else (error 'tokenize "invalid string escape" c)]))]
[else (die 'tokenize "invalid string escape" c)]))]
[(memv c '(#\xA #\x85 #\x2028))
(tokenize-string (cons #\linefeed ls) p)]
[(memv c '(#\xD))
@ -200,7 +200,7 @@
(let ([c (peek-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid syntax .. near end of file")]
(die 'tokenize "invalid syntax .. near end of file")]
[($char= c #\.) ; this is the third
(read-char p)
(let ([c (peek-char p)])
@ -208,10 +208,10 @@
[(eof-object? c) '(datum . ...)]
[(delimiter? c) '(datum . ...)]
[else
(error 'tokenize "invalid syntax"
(die 'tokenize "invalid syntax"
(string-append "..." (string c)))]))]
[else
(error 'tokenize "invalid syntax"
(die 'tokenize "invalid syntax"
(string-append ".." (string c)))]))]
[else
(cons 'datum
@ -224,17 +224,17 @@
(cond
[(eof-object? c) d]
[(delimiter? c) d]
[else (error 'tokenize "invalid character after sequence"
[else (die 'tokenize "invalid character after sequence"
(string-append (string c) str))]))]
[else
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof in the middle of expected sequence" str)]
(die 'tokenize "invalid eof in the middle of expected sequence" str)]
[($char= c (string-ref str i))
(tokenize-char* (fxadd1 i) str p d)]
[else
(error 'tokenize
(die 'tokenize
"invalid char while scanning string"
c str)]))])))
(define tokenize-char-seq
@ -246,14 +246,14 @@
[($char= (string-ref str 1) c)
(read-char p)
(tokenize-char* 2 str p d)]
[else (error 'tokenize "invalid syntax"
[else (die 'tokenize "invalid syntax"
(string-ref str 0) c)]))))
(define tokenize-char
(lambda (p)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid #\\ near end of file")]
(die 'tokenize "invalid #\\ near end of file")]
[(eqv? #\n c)
(let ([c (peek-char p)])
(cond
@ -269,7 +269,7 @@
[(delimiter? c)
'(datum . #\n)]
[else
(error 'tokenize "invalid syntax"
(die 'tokenize "invalid syntax"
(string #\# #\\ #\n c))]))]
[(eqv? #\a c)
(tokenize-char-seq p "alarm" '(datum . #\x7))]
@ -311,9 +311,9 @@
(read-char p)
(f (+ (* v 16) v0)))]
[else
(error 'tokenize "invalid character sequence")]))))]
(die 'tokenize "invalid character sequence")]))))]
[else
(error 'tokenize "invalid character sequence"
(die 'tokenize "invalid character sequence"
(string-append "#\\" (string n)))]))]
[else
(let ([n (peek-char p)])
@ -321,7 +321,7 @@
[(eof-object? n) (cons 'datum c)]
[(delimiter? n) (cons 'datum c)]
[else
(error 'tokenize "invalid syntax"
(die 'tokenize "invalid syntax"
(string-append "#\\" (string c n)))]))]))))
(define (hex x)
(cond
@ -336,7 +336,7 @@
[else #f]))
(define multiline-error
(lambda ()
(error 'tokenize
(die 'tokenize
"end of file encountered while inside a #|-style comment")))
(define apprev
(lambda (str i ac)
@ -379,27 +379,27 @@
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof inside" caller)]
(die 'tokenize "invalid eof inside" caller)]
[(char-whitespace? c)
(skip-whitespace p caller)]
[else c])))
(define tokenize-hash/c
(lambda (c p)
(cond
[(eof-object? c) (error 'tokenize "invalid # near end of file")]
[(eof-object? c) (die 'tokenize "invalid # near end of file")]
[(memq c '(#\t #\T))
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(datum . #t)]
[(delimiter? c) '(datum . #t)]
[else (error 'tokenize
[else (die 'tokenize
(format "invalid syntax near #~a" c))]))]
[(memq c '(#\f #\F))
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(datum . #f)]
[(delimiter? c) '(datum . #f)]
[else (error 'tokenize
[else (die 'tokenize
(format "invalid syntax near #~a" c))]))]
[($char= #\\ c) (tokenize-char p)]
[($char= #\( c) 'vparen]
@ -417,11 +417,11 @@
[($char= #\! c)
(let ([e (read-char p)])
(when (eof-object? e)
(error 'tokenize "invalid eof near #!"))
(die 'tokenize "invalid eof near #!"))
(case e
[(#\e)
(when (eq? (port-mode p) 'r6rs-mode)
(error 'tokenize "invalid syntax: #!e"))
(die 'tokenize "invalid syntax: #!e"))
(read-char* p '(#\e) "of" "eof sequence" #f #f)
(cons 'datum (eof-object))]
[(#\r)
@ -433,16 +433,16 @@
(set-port-mode! p 'ikarus-mode)
(tokenize p)]
[else
(error 'tokenize
(die 'tokenize
(format "invalid syntax near #!~a" e))]))]
[(digit? c)
(when (eq? (port-mode p) 'r6rs-mode)
(error 'tokenize "graph syntax is invalid in #!r6rs mode"
(die 'tokenize "graph syntax is invalid in #!r6rs mode"
(format "#~a" c)))
(tokenize-hashnum p (char->num c))]
[($char= #\: c)
(when (eq? (port-mode p) 'r6rs-mode)
(error 'tokenize "gensym syntax is invalid in #!r6rs mode"
(die 'tokenize "gensym syntax is invalid in #!r6rs mode"
(format "#~a" c)))
(let* ([c (skip-whitespace p "gensym")]
[id0
@ -454,12 +454,12 @@
(list->string
(reverse (tokenize-bar p '())))]
[else
(error 'tokenize
(die 'tokenize
"invalid char inside gensym" c)])])
(cons 'datum (gensym id0)))]
[($char= #\{ c)
(when (eq? (port-mode p) 'r6rs-mode)
(error 'tokenize "gensym syntax is invalid in #!r6rs mode"
(die 'tokenize "gensym syntax is invalid in #!r6rs mode"
(format "#~a" c)))
(let* ([c (skip-whitespace p "gensym")]
[id0
@ -471,7 +471,7 @@
(list->string
(reverse (tokenize-bar p '())))]
[else
(error 'tokenize
(die 'tokenize
"invalid char inside gensym" c)])]
[c (skip-whitespace p "gensym")])
(cond
@ -491,7 +491,7 @@
(list->string
(reverse (tokenize-bar p '())))]
[else
(error 'tokenize
(die 'tokenize
"invalid char inside gensym" c)])])
(let ([c (skip-whitespace p "gensym")])
(cond
@ -500,7 +500,7 @@
(foreign-call "ikrt_strings_to_gensym"
id0 id1))]
[else
(error 'tokenize
(die 'tokenize
"invalid char inside gensym" c)])))]))]
[($char= #\v c)
(let ([c (read-char p)])
@ -513,16 +513,16 @@
(cond
[($char= c #\() 'vu8]
[(eof-object? c)
(error 'tokenize "invalid eof object after #vu8")]
[else (error 'tokenize
(die 'tokenize "invalid eof object after #vu8")]
[else (die 'tokenize
(format "invalid sequence #vu8~a" c))]))]
[(eof-object? c)
(error 'tokenize "invalid eof object after #vu")]
[else (error 'tokenize
(die 'tokenize "invalid eof object after #vu")]
[else (die 'tokenize
(format "invalid sequence #vu~a" c))]))]
[(eof-object? c)
(error 'tokenize "invalid eof object after #v")]
[else (error 'tokenize
(die 'tokenize "invalid eof object after #v")]
[else (die 'tokenize
(format "invalid sequence #v~a" c))]))]
[(memq c '(#\e #\E))
(cons 'datum (tokenize-exactness-mark p (list c #\#) 'e))]
@ -538,12 +538,12 @@
(cons 'datum (tokenize-radix-mark p (list c #\#) 10))]
[($char= #\@ c)
(when (eq? (port-mode p) 'r6rs-mode)
(error 'tokenize "fasl syntax is invalid in #!r6rs mode"
(die 'tokenize "fasl syntax is invalid in #!r6rs mode"
(format "#~a" c)))
(error 'read "FIXME: fasl read disabled")
(die 'read "FIXME: fasl read disabled")
'(cons 'datum ($fasl-read p))]
[else
(error 'tokenize
(die 'tokenize
(format "invalid syntax #~a" c))])))
(define (tokenize-exactness-mark p ls exact?)
(let ([c (read-char p)])
@ -771,7 +771,7 @@
[(#\0) 0]
[(#\1) 1]
[else #f])]
[else (error 'radix-digit "invalid radix" radix)]))
[else (die 'radix-digit "invalid radix" radix)]))
(define (read-char* p ls str who ci? delimited?)
(let f ([i 0] [ls ls])
(cond
@ -779,20 +779,20 @@
(when delimited?
(let ([c (peek-char p)])
(when (and (not (eof-object? c)) (not (delimiter? c)))
(error 'tokenize
(die 'tokenize
(format "invalid ~a: ~s" who
(list->string (reverse (cons c ls))))))))]
[else
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize
(die 'tokenize
(format "invalid eof inside ~a" who))]
[(or (and (not ci?) (char=? c (string-ref str i)))
(and ci? (char=? (char-downcase c) (string-ref str i))))
(f (add1 i) (cons c ls))]
[else
(error 'tokenize
(die 'tokenize
(format "invalid ~a: ~s" who
(list->string (reverse (cons c ls)))))]))])))
(define (tokenize-integer/nan/inf-no-digits p ls)
@ -824,30 +824,30 @@
(tokenize-decimal-no-digits p (cons c ls) exact?)]
[else (num-error "invalid sequence" (cons c ls))])))
(define (num-error str ls)
(error 'read "invalid numeric sequence"
(die 'read "invalid numeric sequence"
(list->string (reverse ls))))
(define (tokenize-hashnum p n)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof inside #n mark/ref")]
(die 'tokenize "invalid eof inside #n mark/ref")]
[($char= #\= c) (cons 'mark n)]
[($char= #\# c) (cons 'ref n)]
[(digit? c)
(tokenize-hashnum p (fx+ (fx* n 10) (char->num c)))]
[else
(error 'tokenize "invalid char while inside a #n mark/ref" c)])))
(die 'tokenize "invalid char while inside a #n mark/ref" c)])))
(define tokenize-bar
(lambda (p ac)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "unexpected eof while reading symbol")]
(die 'tokenize "unexpected eof while reading symbol")]
[($char= #\\ c)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "unexpected eof while reading symbol")]
(die 'tokenize "unexpected eof while reading symbol")]
[else (tokenize-bar p (cons c ac))]))]
[($char= #\| c) ac]
[else (tokenize-bar p (cons c ac))]))))
@ -855,19 +855,19 @@
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof after symbol escape")]
(die 'tokenize "invalid eof after symbol escape")]
[($char= #\x c)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof after \\x")]
(die 'tokenize "invalid eof after \\x")]
[(hex c) =>
(lambda (v)
(let f ([v v] [ac `(,c #\x #\\)])
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize
(die 'tokenize
(format "invalid eof after ~a"
(list->string (reverse ac))))]
[($char= #\; c)
@ -876,13 +876,13 @@
(lambda (v0)
(f (+ (* v 16) v0) (cons c ac)))]
[else
(error 'tokenize "invalid sequence"
(die 'tokenize "invalid sequence"
(list->string (cons c (reverse ac))))]))))]
[else
(error 'tokenize
(die 'tokenize
(format "invalid sequence \\x~a" c))]))]
[else
(error 'tokenize
(die 'tokenize
(format "invalid sequence \\~a" c))])))
(define tokenize/c
(lambda (c p)
@ -942,7 +942,7 @@
(tokenize-dot p)]
[($char= #\| c)
(when (eq? (port-mode p) 'r6rs-mode)
(error 'tokenize "|symbol| syntax is invalid in #!r6rs mode"))
(die 'tokenize "|symbol| syntax is invalid in #!r6rs mode"))
(let ([ls (reverse (tokenize-bar p '()))])
(cons 'datum (string->symbol (list->string ls))))]
[($char= #\\ c)
@ -951,7 +951,7 @@
(list->string
(reverse (tokenize-backslash '() p)))))]
[else
(error 'tokenize "invalid syntax" c)])))
(die 'tokenize "invalid syntax" c)])))
(define tokenize
(lambda (p)
@ -966,7 +966,7 @@
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof after #")]
(die 'tokenize "invalid eof after #")]
[($char= #\! c)
(skip-comment p)
(tokenize p)]
@ -979,21 +979,21 @@
(let ([t (tokenize p)])
(cond
[(eof-object? t)
(error 'read "end of file encountered while reading list")]
(die 'read "end of file encountered while reading list")]
[(eq? t end) (values '() locs k)]
[(eq? t mis)
(error 'read "paren mismatch")]
(die 'read "paren mismatch")]
[(eq? t 'dot)
(let-values ([(d locs k) (read-expr p locs k)])
(let ([t (tokenize p)])
(cond
[(eq? t end) (values d locs k)]
[(eq? t mis)
(error 'read "paren mismatch")]
(die 'read "paren mismatch")]
[(eq? t 'dot)
(error 'read "cannot have two dots in a list")]
(die 'read "cannot have two dots in a list")]
[else
(error 'read
(die 'read
(format "expecting ~a, got ~a" end t))])))]
[(eq? t 'hash-semi)
(let-values ([(ignored locs k) (read-expr p locs k)])
@ -1011,12 +1011,12 @@
(let ([t (tokenize p)])
(cond
[(eof-object? t)
(error 'read "end of file encountered while reading list")]
(die 'read "end of file encountered while reading list")]
[(eq? t end) (values '() locs k)]
[(eq? t mis)
(error 'read "paren mismatch")]
(die 'read "paren mismatch")]
[(eq? t 'dot)
(error 'read "invalid dot while reading list")]
(die 'read "invalid dot while reading list")]
[(eq? t 'hash-semi)
(let-values ([(ignored locs k) (read-expr p locs k)])
(read-list-init p locs k end mis))]
@ -1061,25 +1061,25 @@
(cond
[(fixnum? a)
(unless (and (fx<= 0 a) (fx<= a 255))
(error 'read
(die 'read
(format "invalid value ~s in a bytevector" a)))
($bytevector-set! v i a)
(bytevector-put v k ($fxsub1 i) ($cdr ls))]
[else (error 'read "invalid value inside a bytevector" a)]))])))
[else (die 'read "invalid value inside a bytevector" a)]))])))
(define read-vector
(lambda (p locs k count ls)
(let ([t (tokenize p)])
(cond
[(eof-object? t)
(error 'read "end of file encountered while reading a vector")]
(die 'read "end of file encountered while reading a vector")]
[(eq? t 'rparen)
(let ([v (make-vector count)])
(let ([k (vector-put v k (fxsub1 count) ls)])
(values v locs k)))]
[(eq? t 'rbrack)
(error 'read "unexpected ] while reading a vector")]
(die 'read "unexpected ] while reading a vector")]
[(eq? t 'dot)
(error 'read "unexpected . while reading a vector")]
(die 'read "unexpected . while reading a vector")]
[(eq? t 'hash-semi)
(let-values ([(ignored locs k) (read-expr p locs k)])
(read-vector p locs k count ls))]
@ -1091,15 +1091,15 @@
(let ([t (tokenize p)])
(cond
[(eof-object? t)
(error 'read "end of file encountered while reading a bytevector")]
(die 'read "end of file encountered while reading a bytevector")]
[(eq? t 'rparen)
(let ([v ($make-bytevector count)])
(let ([k (bytevector-put v k (fxsub1 count) ls)])
(values v locs k)))]
[(eq? t 'rbrack)
(error 'read "unexpected ] while reading a bytevector")]
(die 'read "unexpected ] while reading a bytevector")]
[(eq? t 'dot)
(error 'read "unexpected . while reading a bytevector")]
(die 'read "unexpected . while reading a bytevector")]
[(eq? t 'hash-semi)
(let-values ([(ignored locs k) (read-expr p locs k)])
(read-bytevector p locs k count ls))]
@ -1124,7 +1124,7 @@
[(eq? (car t) 'macro)
(let-values ([(expr locs k) (read-expr p locs k)])
(when (eof-object? expr)
(error 'read
(die 'read
(format "invalid eof after ~a read macro"
(cdr t))))
(let ([x (list expr)])
@ -1142,7 +1142,7 @@
(lambda (x)
(let ([loc (cdr x)])
(when (loc-set? loc)
(error 'read "duplicate mark" n))
(die 'read "duplicate mark" n))
(set-loc-value! loc expr)
(set-loc-set?! loc #t)
(values expr locs k)))]
@ -1160,9 +1160,9 @@
(let ([loc (make-loc #f #f)])
(let ([locs (cons (cons n loc) locs)])
(values loc locs k)))]))]
[else (error 'read "invalid token" t)])]
[else (die 'read "invalid token" t)])]
[else
(error 'read
(die 'read
(format "unexpected ~s found" t))])))
(define read-expr
@ -1177,7 +1177,7 @@
(lambda (x)
(let ([loc (cdr x)])
(unless (loc-set? loc)
(error 'read "referenced mark is not set" (car x)))
(die 'read "referenced mark is not set" (car x)))
(when (loc? (loc-value loc))
(let f ([h loc] [t loc])
(if (loc? h)
@ -1185,7 +1185,7 @@
(if (loc? h1)
(begin
(when (eq? h1 t)
(error 'read "circular marks"))
(die 'read "circular marks"))
(let ([v (f (loc-value h1) (loc-value t))])
(set-loc-value! h1 v)
(set-loc-value! h v)
@ -1225,7 +1225,7 @@
[(p)
(if (input-port? p)
(tokenize p)
(error 'read-token "not an input port" p))]))
(die 'read-token "not an input port" p))]))
(define read
(case-lambda
@ -1233,11 +1233,11 @@
[(p)
(if (input-port? p)
(my-read p)
(error 'read "not an input port" p))]))
(die 'read "not an input port" p))]))
(define (get-datum p)
(unless (input-port? p)
(error 'get-datum "not an input port"))
(die 'get-datum "not an input port"))
(my-read p))
(define comment-handler
@ -1245,7 +1245,7 @@
(lambda (x) (void))
(lambda (x)
(unless (procedure? x)
(error 'comment-handler "not a procedure" x))
(die 'comment-handler "not a procedure" x))
x)))
)

98
scheme/ikarus.records.procedural.ss
View File

@ -59,39 +59,39 @@
(if (rtd? rtd)
(if (not (rtd-opaque? rtd))
rtd
(error 'record-rtd "record is opaque"))
(error 'record-rtd "not a record" x)))
(error 'record-rtd "not a record" x)))
(die 'record-rtd "record is opaque"))
(die 'record-rtd "not a record" x)))
(die 'record-rtd "not a record" x)))
(define (record-type-name x)
(if (rtd? x)
(rtd-name x)
(error 'record-type-name "not an rtd" x)))
(die 'record-type-name "not an rtd" x)))
(define (record-type-parent x)
(if (rtd? x)
(rtd-parent x)
(error 'record-type-parent "not an rtd" x)))
(die 'record-type-parent "not an rtd" x)))
(define (record-type-uid x)
(if (rtd? x)
(rtd-uid x)
(error 'record-type-uid "not an rtd" x)))
(die 'record-type-uid "not an rtd" x)))
(define (record-type-sealed? x)
(if (rtd? x)
(rtd-sealed? x)
(error 'record-type-sealed? "not an rtd" x)))
(die 'record-type-sealed? "not an rtd" x)))
(define (record-type-opaque? x)
(if (rtd? x)
(rtd-opaque? x)
(error 'record-type-opaque? "not an rtd" x)))
(die 'record-type-opaque? "not an rtd" x)))
(define (record-type-generative? x)
(if (rtd? x)
(not (rtd-sealed? x))
(error 'record-type-generative? "not an rtd" x)))
(die 'record-type-generative? "not an rtd" x)))
(define (record-type-field-names x)
(if (rtd? x)
@ -103,7 +103,7 @@
(begin
(vector-set! x i (cdr (vector-ref v i)))
(f x v n (fxadd1 i)))))))
(error 'record-type-field-names "not an rtd" x)))
(die 'record-type-field-names "not an rtd" x)))
(module (make-record-type-descriptor)
@ -114,7 +114,7 @@
#f #f #f parent sealed? opaque? uid fields))
(define (convert-fields sv)
(unless (vector? sv)
(error who "invalid fields argument" sv))
(die who "invalid fields argument" sv))
(let ([n2 (vector-length sv)])
(let ([v (make-vector n2)])
(let f ([i 0])
@ -125,16 +125,16 @@
(if (pair? x)
(let ([name (car x)])
(unless (and (null? (cdr x)) (symbol? name))
(error who "invalid fields argument" sv))
(die who "invalid fields argument" sv))
(vector-set! v i
(cons (case m/u
[(mutable) #t]
[(immutable) #f]
[else
(error who "invalid fields argument" sv)])
(die who "invalid fields argument" sv)])
name)))
(error who "invalid fields argument" sv)))
(error who "invalid fields argument" sv)))
(die who "invalid fields argument" sv)))
(die who "invalid fields argument" sv)))
(f (add1 i))))
v)))
(define generate-rtd
@ -142,7 +142,7 @@
(cond
[(rtd? parent)
(when (rtd-sealed? parent)
(error who "cannot extend sealed parent" parent))
(die who "cannot extend sealed parent" parent))
(make-rtd-aux name parent uid sealed?
(or opaque? (rtd-opaque? parent))
(rtd-size parent)
@ -150,7 +150,7 @@
[(eqv? parent #f)
(make-rtd-aux name parent uid sealed? opaque? 0
(convert-fields fields))]
[else (error who "not a valid parent" parent)])))
[else (die who "not a valid parent" parent)])))
(define (same-fields-as-rtd? fields rtd)
(let* ([fv (rtd-fields rtd)]
[n (vector-length fv)])
@ -183,7 +183,7 @@
(eqv? sealed? (rtd-sealed? rtd))
(eqv? opaque? (rtd-opaque? rtd))
(same-fields-as-rtd? fields rtd))
(error who "invalid arguments"))
(die who "invalid arguments"))
rtd)]
[else
(let ([rtd (generate-rtd name parent uid sealed? opaque? fields)])
@ -192,17 +192,17 @@
(define make-record-type-descriptor
(lambda (name parent uid sealed? opaque? fields)
(unless (symbol? name)
(error who "not a valid record type name" name))
(die who "not a valid record type name" name))
(unless (boolean? sealed?)
(error who "not a valid sealed? argument" sealed?))
(die who "not a valid sealed? argument" sealed?))
(unless (boolean? opaque?)
(error who "not a valid opaque? argument" opaque?))
(die who "not a valid opaque? argument" opaque?))
(cond
[(symbol? uid)
(make-nongenerative-rtd name parent uid sealed? opaque? fields)]
[(eqv? uid #f)
(generate-rtd name parent uid sealed? opaque? fields)]
[else (error who "not a valid uid" uid)]))))
[else (die who "not a valid uid" uid)]))))
(define-struct rcd (rtd prcd proc))
@ -215,9 +215,9 @@
(define (rtd-subtype? rtd parent-rtd)
(unless (rtd? rtd)
(error 'rtd-subtype? "not an rtd" rtd))
(die 'rtd-subtype? "not an rtd" rtd))
(unless (rtd? parent-rtd)
(error 'rtd-substype? "not an rtd" parent-rtd))
(die 'rtd-substype? "not an rtd" parent-rtd))
(or (eq? rtd parent-rtd)
(is-parent-of? parent-rtd rtd)))
@ -225,20 +225,20 @@
(lambda (rtd prcd protocol)
(define who 'make-record-constructor-descriptor)
(unless (rtd? rtd)
(error who "not a record type descriptor" rtd))
(die who "not a record type descriptor" rtd))
(unless (or (not protocol) (procedure? protocol))
(error who "invalid protocol" protocol))
(die who "invalid protocol" protocol))
(let ([prtd (rtd-parent rtd)])
(cond
[(not prcd)
(make-rcd rtd #f protocol)]
[(rcd? prcd)
(unless (is-parent-of? (rcd-rtd prcd) rtd)
(error who "descriptor does not apply"
(die who "descriptor does not apply"
prcd rtd))
(make-rcd rtd prcd protocol)]
[else
(error who "not a valid record constructor descriptor" prcd)]))))
(die who "not a valid record constructor descriptor" prcd)]))))
(define (record-constructor rcd)
(define who 'record-constructor)
@ -250,7 +250,7 @@
(if (pair? ls)
(let-values ([(m p) (f (cdr ls) (- n 1))])
(values (cons (car ls) m) p))
(error 'record-condtructor "insufficient arguments"
(die 'record-condtructor "insufficient arguments"
all-fields)))))
(define (constructor main-rtd size prcd proto)
@ -260,7 +260,7 @@
(lambda flds
(let ([n (rtd-size main-rtd)])
(unless (= (length flds) size)
(apply error
(apply die
'a-record-constructor
(format
"expected ~a args, got ~a instead"
@ -301,7 +301,7 @@
(lambda fmls
(lambda flds
(unless (= (length flds) n)
(apply error
(apply die
'a-record-constructor
(format
"expected ~a args, got ~a instead"
@ -309,7 +309,7 @@
flds))
(apply (p (cons flds f*)) fmls)))))))))
(unless (rcd? rcd)
(error who "not a record constructor descriptor" rcd))
(die who "not a record constructor descriptor" rcd))
(let ([rtd (rcd-rtd rcd)]
[prcd (rcd-prcd rcd)]
[proto (rcd-proc rcd)])
@ -319,14 +319,14 @@
(define (record-accessor rtd k)
(define who 'record-accessor)
(unless (rtd? rtd)
(error who "not an rtd" rtd))
(die who "not an rtd" rtd))
(unless (and (fixnum? k) (fx>= k 0))
(error who "not a valid index" k))
(die who "not a valid index" k))
(let ([sz (rtd-size rtd)]
[p (rtd-parent rtd)])
(let ([i (if p (+ k (rtd-size p)) k)])
(unless (fx< i sz)
(error who "not a valid index" k))
(die who "not a valid index" k))
(let ([a-record-accessor
(lambda (x)
(cond
@ -334,29 +334,29 @@
[($struct? x)
(let ([xrtd ($struct-rtd x)])
(unless (rtd? xrtd)
(error who "invalid type" x rtd))
(die who "invalid type" x rtd))
(let f ([prtd (rtd-parent xrtd)] [rtd rtd] [x x] [i i])
(cond
[(eq? prtd rtd) ($struct-ref x i)]
[(not prtd)
(error who "invalid type" x rtd)]
(die who "invalid type" x rtd)]
[else (f (rtd-parent prtd) rtd x i)])))]
[else (error who "invalid type" x rtd)]))])
[else (die who "invalid type" x rtd)]))])
a-record-accessor))))
(define (record-mutator rtd k)
(define who 'record-mutator)
(unless (rtd? rtd)
(error who "not an rtd" rtd))
(die who "not an rtd" rtd))
(unless (and (fixnum? k) (fx>= k 0))
(error who "not a valid index" k))
(die who "not a valid index" k))
(let ([sz (rtd-size rtd)]
[p (rtd-parent rtd)])
(let ([i (if p (+ k (rtd-size p)) k)])
(unless (fx< i sz)
(error who "not a valid index" k))
(die who "not a valid index" k))
(unless (car (vector-ref (rtd-fields rtd) k))
(error who "field is not mutable" k rtd))
(die who "field is not mutable" k rtd))
(let ([a-record-mutator
(lambda (x v)
(cond
@ -364,20 +364,20 @@
[($struct? x)
(let ([xrtd ($struct-rtd x)])
(unless (rtd? xrtd)
(error who "invalid type" x rtd))
(die who "invalid type" x rtd))
(let f ([prtd (rtd-parent xrtd)] [rtd rtd] [x x] [i i] [v v])
(cond
[(eq? prtd rtd) ($struct-set! x i v)]
[(not prtd)
(error who "invalid type" x rtd)]
(die who "invalid type" x rtd)]
[else (f (rtd-parent prtd) rtd x i v)])))]
[else (error who "invalid type" x rtd)]))])
[else (die who "invalid type" x rtd)]))])
a-record-mutator))))
(define (record-predicate rtd)
(define who 'record-predicate)
(unless (rtd? rtd)
(error who "not an rtd" rtd))
(die who "not an rtd" rtd))
(let ([sz (rtd-size rtd)]
[p (rtd-parent rtd)])
(let ([a-record-predicate
@ -399,14 +399,14 @@
(define (record-field-mutable? rtd k)
(define who 'record-field-mutable?)
(unless (rtd? rtd)
(error who "not an rtd" rtd))
(die who "not an rtd" rtd))
(unless (and (fixnum? k) (fx>= k 0))
(error who "not a valid index" k))
(die who "not a valid index" k))
(let ([sz (rtd-size rtd)]
[p (rtd-parent rtd)])
(let ([i (if p (+ k (rtd-size p)) k)])
(unless (fx< i sz)
(error who "not a valid index" k))
(die who "not a valid index" k))
(car (vector-ref (rtd-fields rtd) k)))))
(set-rtd-printer! (type-descriptor rtd)

10
scheme/ikarus.sort.ss
View File

@ -77,7 +77,7 @@
(define (list-sort <? ls)
(unless (procedure? <?)
(error 'list-sort "not a procedure" <?))
(die 'list-sort "not a procedure" <?))
(sort-tail <? ls (length ls)))
@ -85,9 +85,9 @@
(define (vector-sort <? v)
;;; FIXME: improve
(unless (procedure? <?)
(error 'vector-sort "not a procedure" <?))
(die 'vector-sort "not a procedure" <?))
(unless (vector? v)
(error 'vector-sort "not a vector" v))
(die 'vector-sort "not a vector" v))
(list->vector
(sort-tail <? (vector->list v) (vector-length v))))
@ -95,9 +95,9 @@
(import (ikarus system $vectors))
(import (ikarus system $pairs))
(unless (procedure? <?)
(error 'vector-sort! "not a procedure" <?))
(die 'vector-sort! "not a procedure" <?))
(unless (vector? v)
(error 'vector-sort! "not a vector" v))
(die 'vector-sort! "not a vector" v))
(let f ([i 0] [v v]
[ls (sort-tail <? (vector->list v) (vector-length v))])
(unless (null? ls)

118
scheme/ikarus.strings.ss
View File

@ -36,35 +36,35 @@
(define string-length
(lambda (x)
(unless (string? x)
(error 'string-length "not a string" x))
(die 'string-length "not a string" x))
($string-length x)))
(define (string-ref s i)
(unless (string? s)
(error 'string-ref "not a string" s))
(die 'string-ref "not a string" s))
(unless (fixnum? i)
(error 'string-ref "not a valid index" i))
(die 'string-ref "not a valid index" i))
(unless (and ($fx< i ($string-length s))
($fx<= 0 i))
(error 'string-ref "index is out of range" i s))
(die 'string-ref "index is out of range" i s))
(let ([c ($string-ref s i)])
(unless (char? c)
(error 'string-ref "BUG: got a non-char"))
(die 'string-ref "BUG: got a non-char"))
c))
(define string-set!
(lambda (s i c)
(unless (string? s)
(error 'string-set! "not a string" s))
(die 'string-set! "not a string" s))
(unless (fixnum? i)
(error 'string-set! "not a valid index" i))
(die 'string-set! "not a valid index" i))
(unless (and ($fx< i ($string-length s))
($fx>= i 0))
(error 'string-set! "index is out of range" i s))
(die 'string-set! "index is out of range" i s))
(unless (char? c)
(error 'string-set! "not a character" c))
(die 'string-set! "not a character" c))
($string-set! s i c)))
(define make-string
@ -80,13 +80,13 @@
(case-lambda
[(n)
(unless (and (fixnum? n) (fx>= n 0))
(error 'make-string "not a valid length" n))
(die 'make-string "not a valid length" n))
(fill! ($make-string n) 0 n (integer->char 0))]
[(n c)
(unless (and (fixnum? n) (fx>= n 0))
(error 'make-string "not a valid length" n))
(die 'make-string "not a valid length" n))
(unless (char? c)
(error 'make-string "not a character" c))
(die 'make-string "not a character" c))
(fill! ($make-string n) 0 n c)]))
make-string))
@ -98,7 +98,7 @@
(cond
[(null? ls) n]
[(char? ($car ls)) (length ($cdr ls) ($fx+ n 1))]
[else (error 'string "not a character" ($car ls))]))]
[else (die 'string "not a character" ($car ls))]))]
[loop
(lambda (s ls i n)
(cond
@ -122,18 +122,18 @@
(define substring
(lambda (s n m)
(unless (string? s)
(error 'substring "not a string" s))
(die 'substring "not a string" s))
(let ([len ($string-length s)])
(unless (and (fixnum? n)
($fx>= n 0)
($fx<= n len))
(error 'substring "not a valid start index" n s))
(die 'substring "not a valid start index" n s))
(unless (and (fixnum? m)
($fx>= m 0)
($fx<= m len))
(error 'substring "not a valid end index" m s))
(die 'substring "not a valid end index" m s))
(unless ($fx<= n m)
(error 'substring "indices are in decreasing order" n m))
(die 'substring "indices are in decreasing order" n m))
(let ([len ($fx- m n)])
(if ($fx> len 0)
(fill s ($make-string len) n m 0)
@ -143,7 +143,7 @@
(lambda (s)
(if (string? s)
(substring s 0 (string-length s))
(error 'string-copy "not a string" s))))
(die 'string-copy "not a string" s))))
(module (string=?)
(define bstring=?
@ -163,13 +163,13 @@
(or (null? s*)
(let ([a ($car s*)])
(unless (string? a)
(error 'string=? "not a string" a))
(die 'string=? "not a string" a))
(if ($fx= n ($string-length a))
(and (strings=? s ($cdr s*) n)
(bstring=? s a 0 n))
(check-strings-and-return-false ($cdr s*)))))))
(define (err x)
(error 'string=? "not a string" x))
(die 'string=? "not a string" x))
(define string=?
(case-lambda
[(s s1)
@ -203,10 +203,10 @@
[(string? (car s*))
(f (cdr s*))]
[else
(error who "not a string"
(die who "not a string"
(car s*))]))))
(error who "not a string" s2))])))
(error who "not a string" s1)))
(die who "not a string" s2))])))
(die who "not a string" s1)))
(define ($string<? s1 s2)
(let ([n1 ($string-length s1)]
@ -270,8 +270,8 @@
(if (string? s1)
(if (string? s2)
($string<? s1 s2)
(error 'string<? "not a string" s2))
(error 'string<? "not a string" s2))]
(die 'string<? "not a string" s2))
(die 'string<? "not a string" s2))]
[(s . s*)
(string-cmp 'string<? $string<? s s*)]))
@ -281,8 +281,8 @@
(if (string? s1)
(if (string? s2)
($string<=? s1 s2)
(error 'string<=? "not a string" s2))
(error 'string<=? "not a string" s2))]
(die 'string<=? "not a string" s2))
(die 'string<=? "not a string" s2))]
[(s . s*)
(string-cmp 'string<=? $string<=? s s*)]))
@ -292,8 +292,8 @@
(if (string? s1)
(if (string? s2)
($string>? s1 s2)
(error 'string>? "not a string" s2))
(error 'string>? "not a string" s2))]
(die 'string>? "not a string" s2))
(die 'string>? "not a string" s2))]
[(s . s*)
(string-cmp 'string>? $string>? s s*)]))
@ -303,15 +303,15 @@
(if (string? s1)
(if (string? s2)
($string>=? s1 s2)
(error 'string>=? "not a string" s2))
(error 'string>=? "not a string" s2))]
(die 'string>=? "not a string" s2))
(die 'string>=? "not a string" s2))]
[(s . s*)
(string-cmp 'string>=? $string>=? s s*)]))
(define string->list
(lambda (x)
(unless (string? x)
(error 'string->list "not a string" x))
(die 'string->list "not a string" x))
(let f ([x x] [i ($string-length x)] [ac '()])
(cond
[($fxzero? i) ac]
@ -328,13 +328,13 @@
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'reverse "circular list" ls))
(die 'reverse "circular list" ls))
(if (null? h)
($fx+ n 1)
(error 'reverse "not a proper list" ls))))
(die 'reverse "not a proper list" ls))))
(if (null? h)
n
(error 'reverse "not a proper list" ls))))]
(die 'reverse "not a proper list" ls))))]
[fill
(lambda (s i ls)
(cond
@ -342,7 +342,7 @@
[else
(let ([c ($car ls)])
(unless (char? c)
(error 'list->string "not a character" c))
(die 'list->string "not a character" c))
($string-set! s i c)
(fill s ($fxadd1 i) (cdr ls)))]))])
(lambda (ls)
@ -359,7 +359,7 @@
[else
(let ([a ($car s*)])
(unless (string? a)
(error 'string-append "not a string" a))
(die 'string-append "not a string" a))
(length* ($cdr s*) ($fx+ n ($string-length a))))])))
(define fill-string
(lambda (s a si sj ai)
@ -389,9 +389,9 @@
(case-lambda
[(p v)
(unless (procedure? p)
(error who "not a procedure" p))
(die who "not a procedure" p))
(unless (string? v)
(error who "not a string" v))
(die who "not a string" v))
(let f ([p p] [v v] [i 0] [n (string-length v)])
(cond
[($fx= i n) (void)]
@ -400,14 +400,14 @@
(f p v ($fxadd1 i) n)]))]
[(p v0 v1)
(unless (procedure? p)
(error who "not a procedure" p))
(die who "not a procedure" p))
(unless (string? v0)
(error who "not a string" v0))
(die who "not a string" v0))
(unless (string? v1)
(error who "not a string" v1))
(die who "not a string" v1))
(let ([n (string-length v0)])
(unless ($fx= n ($string-length v1))
(error who "length mismatch" v0 v1))
(die who "length mismatch" v0 v1))
(let f ([p p] [v0 v0] [v1 v1] [i 0] [n n])
(cond
[($fx= i n) (void)]
@ -416,21 +416,21 @@
(f p v0 v1 ($fxadd1 i) n)])))]
[(p v0 v1 . v*)
(unless (procedure? p)
(error who "not a procedure" p))
(die who "not a procedure" p))
(unless (string? v0)
(error who "not a string" v0))
(die who "not a string" v0))
(unless (string? v1)
(error who "not a string" v1))
(die who "not a string" v1))
(let ([n (string-length v0)])
(unless ($fx= n ($string-length v1))
(error who "length mismatch" v0 v1))
(die who "length mismatch" v0 v1))
(let f ([v* v*] [n n])
(unless (null? v*)
(let ([a ($car v*)])
(unless (string? a)
(error who "not a string" a))
(die who "not a string" a))
(unless ($fx= ($string-length a) n)
(error who "length mismatch")))
(die who "length mismatch")))
(f ($cdr v*) n)))
(let f ([p p] [v0 v0] [v1 v1] [v* v*] [i 0] [n n])
(cond
@ -446,9 +446,9 @@
(define (string-fill! v fill)
(unless (string? v)
(error 'string-fill! "not a vector" v))
(die 'string-fill! "not a vector" v))
(unless (char? fill)
(error 'string-fill! "not a character" fill))
(die 'string-fill! "not a character" fill))
(let f ([v v] [i 0] [n ($string-length v)] [fill fill])
(unless ($fx= i n)
($string-set! v i fill)
@ -459,21 +459,21 @@
(lambda (src src-start dst dst-start k)
(cond
[(or (not (fixnum? src-start)) ($fx< src-start 0))
(error 'string-copy! "not a valid starting index" src-start)]
(die 'string-copy! "not a valid starting index" src-start)]
[(or (not (fixnum? dst-start)) ($fx< dst-start 0))
(error 'string-copy! "not a valid starting index" dst-start)]
(die 'string-copy! "not a valid starting index" dst-start)]
[(or (not (fixnum? k)) ($fx< k 0))
(error 'string-copy! "not a valid length" k)]
(die 'string-copy! "not a valid length" k)]
[(not (string? src))
(error 'string-copy! "not a string" src)]
(die 'string-copy! "not a string" src)]
[(not (string? dst))
(error 'string-copy! "not a string" dst)]
(die 'string-copy! "not a string" dst)]
[(let ([n ($fx+ src-start k)])
(or ($fx< n 0) ($fx> n ($string-length src))))
(error 'string-copy! "out of range" src-start k)]
(die 'string-copy! "out of range" src-start k)]
[(let ([n ($fx+ dst-start k)])
(or ($fx< n 0) ($fx> n ($string-length dst))))
(error 'string-copy! "out of range" dst-start k)]
(die 'string-copy! "out of range" dst-start k)]
[(eq? src dst)
(cond
[($fx< dst-start src-start)
@ -499,5 +499,5 @@
(let ([s ($make-bytevector 16)])
(utf8->string
(or (foreign-call "ik_uuid" s)
(error 'uuid "failed!"))))))
(die 'uuid "failed!"))))))
)

68
scheme/ikarus.structs.ss
View File

@ -89,7 +89,7 @@
(define verify-field
(lambda (x)
(unless (symbol? x)
(error 'make-struct-type "not a valid field name" x))))
(die 'make-struct-type "not a valid field name" x))))
(define set-fields
(lambda (r f* i n)
@ -110,9 +110,9 @@
(case-lambda
[(name fields)
(unless (string? name)
(error 'make-struct-type "name must be a string" name))
(die 'make-struct-type "name must be a string" name))
(unless (list? fields)
(error 'make-struct-type "fields must be a list" fields))
(die 'make-struct-type "fields must be a list" fields))
(for-each verify-field fields)
(let ([g (gensym name)])
(let ([rtd (make-rtd name fields #f g)])
@ -120,16 +120,16 @@
rtd))]
[(name fields g)
(unless (string? name)
(error 'make-struct-type "name must be a string" name))
(die 'make-struct-type "name must be a string" name))
(unless (list? fields)
(error 'make-struct-type "fields must be a list" fields))
(die 'make-struct-type "fields must be a list" fields))
(for-each verify-field fields)
(cond
[(symbol-bound? g)
(let ([rtd (symbol-value g)])
(unless (and (string=? name (struct-type-name rtd))
(equal? fields (struct-type-field-names rtd)))
(error 'make-struct-type "definition mismatch"))
(die 'make-struct-type "definition mismatch"))
rtd)]
[else
(let ([rtd (make-rtd name fields #f g)])
@ -139,38 +139,38 @@
(define struct-type-name
(lambda (rtd)
(unless (rtd? rtd)
(error 'struct-type-name "not an rtd" rtd))
(die 'struct-type-name "not an rtd" rtd))
(rtd-name rtd)))
(define struct-type-symbol
(lambda (rtd)
(unless (rtd? rtd)
(error 'struct-type-symbol "not an rtd" rtd))
(die 'struct-type-symbol "not an rtd" rtd))
(rtd-symbol rtd)))
(define struct-type-field-names
(lambda (rtd)
(unless (rtd? rtd)
(error 'struct-type-field-names "not an rtd" rtd))
(die 'struct-type-field-names "not an rtd" rtd))
(rtd-fields rtd)))
(define struct-constructor
(lambda (rtd)
(unless (rtd? rtd)
(error 'struct-constructor "not an rtd"))
(die 'struct-constructor "not an rtd"))
(lambda args
(let ([n (rtd-length rtd)])
(let ([r ($make-struct rtd n)])
(or (set-fields r args 0 n)
(error 'struct-constructor
(die 'struct-constructor
"incorrect number of arguments to the constructor"
rtd)))))))
(define struct-predicate
(lambda (rtd)
(unless (rtd? rtd)
(error 'struct-predicate "not an rtd"))
(die 'struct-predicate "not an rtd"))
(lambda (x)
(and ($struct? x)
(eq? ($struct-rtd x) rtd)))))
@ -180,39 +180,39 @@
(cond
[(fixnum? i)
(unless (and ($fx>= i 0) ($fx< i (rtd-length rtd)))
(error who "out of range for rtd" i rtd))
(die who "out of range for rtd" i rtd))
i]
[(symbol? i)
(letrec ([lookup
(lambda (n ls)
(cond
[(null? ls)
(error who "not a field" rtd)]
(die who "not a field" rtd)]
[(eq? i ($car ls)) n]
[else (lookup ($fx+ n 1) ($cdr ls))]))])
(lookup 0 (rtd-fields rtd)))]
[else (error who "not a valid index" i)])))
[else (die who "not a valid index" i)])))
(define struct-field-accessor
(lambda (rtd i)
(unless (rtd? rtd)
(error 'struct-field-accessor "not an rtd" rtd))
(die 'struct-field-accessor "not an rtd" rtd))
(let ([i (field-index i rtd 'struct-field-accessor)])
(lambda (x)
(unless (and ($struct? x)
(eq? ($struct-rtd x) rtd))
(error 'struct-field-accessor "not of correct type" x rtd))
(die 'struct-field-accessor "not of correct type" x rtd))
($struct-ref x i)))))
(define struct-field-mutator
(lambda (rtd i)
(unless (rtd? rtd)
(error 'struct-field-mutator "not an rtd" rtd))
(die 'struct-field-mutator "not an rtd" rtd))
(let ([i (field-index i rtd 'struct-field-mutator)])
(lambda (x v)
(unless (and ($struct? x)
(eq? ($struct-rtd x) rtd))
(error 'struct-field-mutator "not of correct type" x rtd))
(die 'struct-field-mutator "not of correct type" x rtd))
($struct-set! x i v)))))
(define struct?
@ -221,9 +221,9 @@
($struct? x)
(let ([rtd ($car rest)])
(unless (null? ($cdr rest))
(error 'struct? "too many arguments"))
(die 'struct? "too many arguments"))
(unless (rtd? rtd)
(error 'struct? "not an rtd"))
(die 'struct? "not an rtd"))
(and ($struct? x)
(eq? ($struct-rtd x) rtd))))))
@ -231,49 +231,49 @@
(lambda (x)
(if ($struct? x)
($struct-rtd x)
(error 'struct-rtd "not a struct" x))))
(die 'struct-rtd "not a struct" x))))
(define struct-length
(lambda (x)
(if ($struct? x)
(rtd-length ($struct-rtd x))
(error 'struct-length "not a struct" x))))
(die 'struct-length "not a struct" x))))
(define struct-name
(lambda (x)
(if ($struct? x)
(rtd-name ($struct-rtd x))
(error 'struct-name "not a struct" x))))
(die 'struct-name "not a struct" x))))
(define struct-printer
(lambda (x)
(if ($struct? x)
(rtd-printer ($struct-rtd x))
(error 'struct-printer "not a struct" x))))
(die 'struct-printer "not a struct" x))))
(define struct-ref
(lambda (x i)
(unless ($struct? x) (error 'struct-ref "not a struct" x))
(unless (fixnum? i) (error 'struct-ref "not a valid index" i))
(unless ($struct? x) (die 'struct-ref "not a struct" x))
(unless (fixnum? i) (die 'struct-ref "not a valid index" i))
(let ([n (rtd-length ($struct-rtd x))])
(unless (and ($fx>= i 0) ($fx< i n))
(error 'struct-ref "index is out of range" i x))
(die 'struct-ref "index is out of range" i x))
($struct-ref x i))))
(define struct-set!
(lambda (x i v)
(unless ($struct? x) (error 'struct-set! "not a struct" x))
(unless (fixnum? i) (error 'struct-set! "not a valid index" i))
(unless ($struct? x) (die 'struct-set! "not a struct" x))
(unless (fixnum? i) (die 'struct-set! "not a valid index" i))
(let ([n (rtd-length ($struct-rtd x))])
(unless (and ($fx>= i 0) ($fx< i n))
(error 'struct-set! "index is out of range" i x))
(die 'struct-set! "index is out of range" i x))
($struct-set! x i v))))
(define (set-rtd-printer! x p)
(unless (rtd? x)
(error 'set-rtd-printer! "not an rtd" x))
(die 'set-rtd-printer! "not an rtd" x))
(unless (procedure? p)
(error 'set-rtd-printer! "not a procedure" p))
(die 'set-rtd-printer! "not a procedure" p))
($set-rtd-printer! x p))
(set-rtd-fields! (base-rtd) '(name fields length printer symbol))
@ -281,7 +281,7 @@
($set-rtd-printer! (base-rtd)
(lambda (x p)
(unless (rtd? x)
(error 'struct-type-printer "not an rtd"))
(die 'struct-type-printer "not an rtd"))
(display "#<" p)
(display (rtd-name x) p)
(display " rtd>" p)))

52
scheme/ikarus.symbols.ss
View File

@ -40,7 +40,7 @@
($make-symbol s)
(if (symbol? s)
($make-symbol ($symbol-string s))
(error 'gensym "neither a string nor a symbol" s)))]))
(die 'gensym "neither a string nor a symbol" s)))]))
(define gensym?
(lambda (x)
@ -51,10 +51,10 @@
(define top-level-value
(lambda (x)
(unless (symbol? x)
(error 'top-level-value "not a symbol" x))
(die 'top-level-value "not a symbol" x))
(let ([v ($symbol-value x)])
(when ($unbound-object? v)
(error 'eval "unbound variable"
(die 'eval "unbound variable"
(string->symbol
(symbol->string x))))
v)))
@ -62,39 +62,39 @@
(define top-level-bound?
(lambda (x)
(unless (symbol? x)
(error 'top-level-bound? "not a symbol" x))
(die 'top-level-bound? "not a symbol" x))
(not ($unbound-object? ($symbol-value x)))))
(define set-top-level-value!
(lambda (x v)
(unless (symbol? x)
(error 'set-top-level-value! "not a symbol" x))
(die 'set-top-level-value! "not a symbol" x))
($set-symbol-value! x v)))
(define symbol-value
(lambda (x)
(unless (symbol? x)
(error 'symbol-value "not a symbol" x))
(die 'symbol-value "not a symbol" x))
(let ([v ($symbol-value x)])
(when ($unbound-object? v)
(error 'symbol-value "unbound" x))
(die 'symbol-value "unbound" x))
v)))
(define symbol-bound?
(lambda (x)
(unless (symbol? x)
(error 'symbol-bound? "not a symbol" x))
(die 'symbol-bound? "not a symbol" x))
(not ($unbound-object? ($symbol-value x)))))
(define set-symbol-value!
(lambda (x v)
(unless (symbol? x)
(error 'set-symbol-value! "not a symbol" x))
(die 'set-symbol-value! "not a symbol" x))
($set-symbol-value! x v)
($set-symbol-proc! x
(if (procedure? v) v
(lambda args
(error 'apply "not a procedure"
(die 'apply "not a procedure"
($symbol-value x)))))))
(define reset-symbol-proc!
@ -106,21 +106,21 @@
(lambda args
(let ([v ($symbol-value x)])
(if ($unbound-object? v)
(error 'eval "unbound variable"
(die 'eval "unbound variable"
(string->symbol
(symbol->string x)))
(error 'apply "not a procedure" v)))))))))
(die 'apply "not a procedure" v)))))))))
(define string->symbol
(lambda (x)
(unless (string? x)
(error 'string->symbol "not a string" x))
(die 'string->symbol "not a string" x))
(foreign-call "ikrt_string_to_symbol" x)))
(define symbol->string
(lambda (x)
(unless (symbol? x)
(error 'symbol->string "not a symbol" x))
(die 'symbol->string "not a symbol" x))
(let ([str ($symbol-string x)])
(or str
(let ([ct (gensym-count)])
@ -132,8 +132,8 @@
(define putprop
(lambda (x k v)
(unless (symbol? x) (error 'putprop "not a symbol" x))
(unless (symbol? k) (error 'putprop "not a symbol" k))
(unless (symbol? x) (die 'putprop "not a symbol" x))
(unless (symbol? k) (die 'putprop "not a symbol" k))
(let ([p ($symbol-plist x)])
(cond
[(assq k p) => (lambda (x) (set-cdr! x v))]
@ -142,8 +142,8 @@
(define getprop
(lambda (x k)
(unless (symbol? x) (error 'getprop "not a symbol" x))
(unless (symbol? k) (error 'getprop "not a symbol" k))
(unless (symbol? x) (die 'getprop "not a symbol" x))
(unless (symbol? k) (die 'getprop "not a symbol" k))
(let ([p ($symbol-plist x)])
(cond
[(assq k p) => cdr]
@ -151,8 +151,8 @@
(define remprop
(lambda (x k)
(unless (symbol? x) (error 'remprop "not a symbol" x))
(unless (symbol? k) (error 'remprop "not a symbol" k))
(unless (symbol? x) (die 'remprop "not a symbol" x))
(unless (symbol? k) (die 'remprop "not a symbol" k))
(let ([p ($symbol-plist x)])
(unless (null? p)
(let ([a ($car p)])
@ -171,7 +171,7 @@
(define property-list
(lambda (x)
(unless (symbol? x)
(error 'property-list "not a symbol" x))
(die 'property-list "not a symbol" x))
(letrec ([f
(lambda (ls ac)
(cond
@ -185,12 +185,12 @@
(define gensym->unique-string
(lambda (x)
(unless (symbol? x)
(error 'gensym->unique-string "not a gensym" x))
(die 'gensym->unique-string "not a gensym" x))
(let ([us ($symbol-unique-string x)])
(cond
[(string? us) us]
[(not us)
(error 'gensym->unique-string "not a gensym" x)]
(die 'gensym->unique-string "not a gensym" x)]
[else
(let f ([x x])
(let ([id (uuid)])
@ -204,7 +204,7 @@
"g"
(lambda (x)
(unless (string? x)
(error 'gensym-prefix "not a string" x))
(die 'gensym-prefix "not a string" x))
x)))
(define gensym-count
@ -212,7 +212,7 @@
0
(lambda (x)
(unless (and (fixnum? x) ($fx>= x 0))
(error 'gensym-count "not a valid count" x))
(die 'gensym-count "not a valid count" x))
x)))
(define print-gensym
@ -220,7 +220,7 @@
#t
(lambda (x)
(unless (or (boolean? x) (eq? x 'pretty))
(error 'print-gensym "not in #t|#f|pretty" x))
(die 'print-gensym "not in #t|#f|pretty" x))
x)))
)

6
scheme/ikarus.time-and-date.ss
View File

@ -31,16 +31,16 @@
(if (time? x)
(+ (* (time-msecs x) #e10e5)
(time-secs x))
(error 'time-second "not a time" x)))
(die 'time-second "not a time" x)))
(define (time-nanosecond x)
(if (time? x)
(* (time-usecs x) 1000)
(error 'time-nanosecond "not a time" x)))
(die 'time-nanosecond "not a time" x)))
(define (time-gmt-offset x)
(if (time? x)
(foreign-call "ikrt_gmt_offset" x)
(error 'time-gmt-offset "not a time" x)))
(die 'time-gmt-offset "not a time" x)))
)

2
scheme/ikarus.timer.ss
View File

@ -86,7 +86,7 @@
(time-it #f proc)]
[(message proc)
(unless (procedure? proc)
(error 'time-it "not a procedure" proc))
(die 'time-it "not a procedure" proc))
(let* ([t0 (mk-stats)]
[t1 (mk-stats)]
[bytes-min (bytes-minor)]

6
scheme/ikarus.trace.ss
View File

@ -98,7 +98,7 @@
(let ([a (cdr pr)] [v (symbol-value s)])
(unless (eq? (cdr a) v)
(unless (procedure? v)
(error 'trace
(die 'trace
"the top-level value is not a procedure"
s v))
(let ([p (make-traced-procedure s v)])
@ -107,10 +107,10 @@
(set-symbol-value! s p)))))]
[else
(unless (symbol-bound? s)
(error 'trace "unbound" s))
(die 'trace "unbound" s))
(let ([v (symbol-value s)])
(unless (procedure? v)
(error 'trace "the top-level value is not a procedure" s v))
(die 'trace "the top-level value is not a procedure" s v))
(let ([p (make-traced-procedure s v)])
(set! traced-symbols
(cons (cons s (cons v p)) traced-symbols))

70
scheme/ikarus.unicode-conversion.ss
View File

@ -37,7 +37,7 @@
;;; handling-modes: ignore, replace, raise
;;; ignore: skips over the offending bytes
;;; replace: places a U+FFFD in place of the malformed bytes
;;; raise: raises an error
;;; raise: raises an die
;;; It appears that utf-8 data can start with a #xEF #xBB #xBF BOM!
@ -102,14 +102,14 @@
($fxlogor #b10000000 ($fxlogand b #b111111)))
(f bv str ($fxadd1 i) ($fx+ j 4) n)])))])))
(unless (string? str)
(error 'string->utf8 "not a string" str))
(die 'string->utf8 "not a string" str))
(fill-utf8-bytevector
($make-bytevector (utf8-string-size str))
str)))
(define (utf8->string x)
(unless (bytevector? x)
(error 'utf8->string "not a bytevector" x))
(die 'utf8->string "not a bytevector" x))
(decode-utf8-bytevector x 'replace))
(define decode-utf8-bytevector
@ -142,12 +142,12 @@
[(eq? mode 'replace)
(f x i j ($fxadd1 n) mode)]
[else
(error who "invalid byte sequence at idx of bytevector"
(die who "invalid byte sequence at idx of bytevector"
b0 b1 i bv)]))]
[(eq? mode 'ignore) n]
[(eq? mode 'replace) ($fxadd1 n)]
[else
(error who "invalid byte near end of bytevector" b0)]))]
(die who "invalid byte near end of bytevector" b0)]))]
[($fx= ($fxsra b0 4) #b1110)
(cond
[($fx< ($fx+ i 2) j)
@ -165,10 +165,10 @@
(f x ($fxadd1 i) j n mode)]
[(eq? mode 'replace)
(f x ($fxadd1 i) j ($fxadd1 n) mode)]
[else (error who "invalid sequence" b0 b1 b2)]))]
[else (die who "invalid sequence" b0 b1 b2)]))]
[(eq? mode 'ignore) (f x ($fxadd1 i) j n mode)]
[(eq? mode 'replace) (f x ($fxadd1 i) j ($fxadd1 n) mode)]
[else (error who "incomplete char sequence")])]
[else (die who "incomplete char sequence")])]
[($fx= ($fxsra b0 3) #b11110)
(cond
[($fx< ($fx+ i 3) j)
@ -189,13 +189,13 @@
(f x ($fxadd1 i) j n mode)]
[(eq? mode 'replace)
(f x ($fxadd1 i) j ($fxadd1 n) mode)]
[else (error who "invalid sequence" b0 b1 b2 b3)]))]
[else (die who "invalid sequence" b0 b1 b2 b3)]))]
[(eq? mode 'ignore) (f x ($fxadd1 i) j n mode)]
[(eq? mode 'replace) (f x ($fxadd1 i) j ($fxadd1 n) mode)]
[else (error who "incomplete char sequence")])]
[else (die who "incomplete char sequence")])]
[(eq? mode 'ignore) (f x ($fxadd1 i) j n mode)]
[(eq? mode 'replace) (f x ($fxadd1 i) j ($fxadd1 n) mode)]
[else (error who "invalid byte at index of bytevector" b0 i x)]))])))
[else (die who "invalid byte at index of bytevector" b0 i x)]))])))
(define (fill str bv i mode)
(let f ([str str] [x bv] [i i] [j ($bytevector-length bv)] [n 0] [mode mode])
(cond
@ -227,12 +227,12 @@
[(eq? mode 'replace)
($string-set! str n ($fixnum->char #xFFFD))
(f str x i j ($fxadd1 n) mode)]
[else (error who "BUG")]))]
[else (die who "BUG")]))]
[(eq? mode 'ignore) str]
[(eq? mode 'replace)
($string-set! str n ($fixnum->char #xFFFD))
str]
[else (error who "BUG")]))]
[else (die who "BUG")]))]
[($fx= ($fxsra b0 4) #b1110)
(cond
[($fx< ($fx+ i 2) j)
@ -254,12 +254,12 @@
[(eq? mode 'replace)
($string-set! str n ($fixnum->char #xFFFD))
(f str x ($fxadd1 i) j ($fxadd1 n) mode)]
[else (error who "BUG")]))]
[else (die who "BUG")]))]
[(eq? mode 'ignore) (f str x ($fxadd1 i) j n mode)]
[(eq? mode 'replace)
($string-set! str n ($fixnum->char #xFFFD))
(f str x ($fxadd1 i) j ($fxadd1 n) mode)]
[else (error who "BUG")])]
[else (die who "BUG")])]
[($fx= ($fxsra b0 3) #b11110)
(cond
[($fx< ($fx+ i 3) j)
@ -285,17 +285,17 @@
[(eq? mode 'replace)
($string-set! str n ($fixnum->char #xFFFD))
(f str x ($fxadd1 i) j ($fxadd1 n) mode)]
[else (error who "BUG")]))]
[else (die who "BUG")]))]
[(eq? mode 'ignore) (f str x ($fxadd1 i) j n mode)]
[(eq? mode 'replace)
($string-set! str n ($fixnum->char #xFFFD))
(f str x ($fxadd1 i) j ($fxadd1 n) mode)]
[else (error who "BUG")])]
[else (die who "BUG")])]
[(eq? mode 'ignore) (f str x ($fxadd1 i) j n mode)]
[(eq? mode 'replace)
($string-set! str n ($fixnum->char #xFFFD))
(f str x ($fxadd1 i) j ($fxadd1 n) mode)]
[else (error who "BUG")]))])))
[else (die who "BUG")]))])))
(define (has-bom? bv)
(and (fx> (bytevector-length bv) 3)
(fx= (bytevector-u8-ref bv 0) #xEF)
@ -311,7 +311,7 @@
[(bv) (convert bv 'raise)]
[(bv handling-mode)
(unless (memq handling-mode '(ignore replace raise))
(error 'decode-utf8-bytevector
(die 'decode-utf8-bytevector
"not a valid handling mode"
handling-mode))
(convert bv handling-mode)])))
@ -353,7 +353,7 @@
;;; of W1. Terminate.
;;;
;;; 2) Determine if W1 is between 0xD800 and 0xDBFF. If not, the sequence
;;; is in error and no valid character can be obtained using W1.
;;; is in die and no valid character can be obtained using W1.
;;; Terminate.
;;;
;;; 3) If there is no W2 (that is, the sequence ends with W1), or if W2
@ -407,13 +407,13 @@
(case-lambda
[(str)
(unless (string? str)
(error 'string->utf16 "not a string" str))
(die 'string->utf16 "not a string" str))
($string->utf16 str 'big)]
[(str endianness)
(unless (string? str)
(error 'string->utf16 "not a string" str))
(die 'string->utf16 "not a string" str))
(unless (memv endianness '(big little))
(error 'string->utf16 "invalid endianness" endianness))
(die 'string->utf16 "invalid endianness" endianness))
($string->utf16 str endianness)])))
(module (utf16->string)
@ -429,20 +429,20 @@
(cond
[(or (fx< w1 #xD800) (fx> w1 #xDFFF))
(count-size bv endianness (+ i 2) len (+ n 1))]
[(not (fx<= #xD800 w1 #xDBFF)) ;;; error sequence
[(not (fx<= #xD800 w1 #xDBFF)) ;;; die sequence
(count-size bv endianness (+ i 2) len (+ n 1))]
[(<= (+ i 4) (bytevector-length bv))
(let ([w2 (bytevector-u16-ref bv (+ i 2) endianness)])
(cond
[(not (<= #xDC00 w2 #xDFFF))
;;; do we skip w2 also?
;;; I won't. Just w1 is an error
;;; I won't. Just w1 is an die
(count-size bv endianness (+ i 2) len (+ n 1))]
[else
;;; 4-byte sequence is ok
(count-size bv endianness (+ i 4) len (+ n 1))]))]
[else
;;; error again
;;; die again
(count-size bv endianness (+ i 2) len (+ n 1))]))]))
(define (fill bv endianness str i len n)
(cond
@ -456,7 +456,7 @@
[(or (fx< w1 #xD800) (fx> w1 #xDFFF))
(string-set! str n (integer->char/invalid w1))
(fill bv endianness str (+ i 2) len (+ n 1))]
[(not (fx<= #xD800 w1 #xDBFF)) ;;; error sequence
[(not (fx<= #xD800 w1 #xDBFF)) ;;; die sequence
(string-set! str n #\xFFFD)
(fill bv endianness str (+ i 2) len (+ n 1))]
[(<= (+ i 4) (bytevector-length bv))
@ -464,7 +464,7 @@
(cond
[(not (<= #xDC00 w2 #xDFFF))
;;; do we skip w2 also?
;;; I won't. Just w1 is an error
;;; I won't. Just w1 is an die
(string-set! str n #\xFFFD)
(fill bv endianness str (+ i 2) len (+ n 1))]
[else
@ -475,7 +475,7 @@
(fxlogand w2 #x3FF)))))
(fill bv endianness str (+ i 4) len (+ n 1))]))]
[else
;;; error again
;;; die again
(string-set! str n #\xFFFD)
(fill bv endianness str (+ i 2) len (+ n 1))]))]))
(define (decode bv endianness start)
@ -492,9 +492,9 @@
[(fx= n #xFFFE) 'little]
[else #f]))))
(unless (bytevector? bv)
(error who "not a bytevector" bv))
(die who "not a bytevector" bv))
(unless (memv endianness '(big little))
(error who "invalid endianness" endianness))
(die who "invalid endianness" endianness))
(cond
[em? (decode bv endianness 0)]
[(bom-present bv) =>
@ -528,13 +528,13 @@
(case-lambda
[(str)
(unless (string? str)
(error who "not a string" str))
(die who "not a string" str))
($string->utf32 str 'big)]
[(str endianness)
(unless (string? str)
(error who "not a string" str))
(die who "not a string" str))
(unless (memq endianness '(little big))
(error who "invalid endianness" endianness))
(die who "invalid endianness" endianness))
($string->utf32 str endianness)])))
@ -567,9 +567,9 @@
[(= n #xFFFE0000) 'little]
[else #f]))))
(unless (bytevector? bv)
(error who "not a bytevector" bv))
(die who "not a bytevector" bv))
(unless (memv endianness '(big little))
(error who "invalid endianness" endianness))
(die who "invalid endianness" endianness))
(cond
[em? (decode bv endianness 0)]
[(bom-present bv) =>

68
scheme/ikarus.unicode-data.ss
View File

@ -77,12 +77,12 @@
(if (char? c)
(vector-ref unicode-categories-name-vector
(fxlogand 63 (lookup-char-info c)))
(error 'char-general-category "not a char" c)))
(die 'char-general-category "not a char" c)))
(define (char-has-property? c prop-val who)
(if (char? c)
(not (fxzero? (fxlogand (lookup-char-info c) prop-val)))
(error who "not a char" c)))
(die who "not a char" c)))
(define (unicode-printable-char? c)
(char-has-property? c constituent-property 'unicode-printable-char?))
@ -112,24 +112,24 @@
(if (char? x)
($fixnum->char
(convert-char x char-downcase-adjustment-vector))
(error 'char-downcase "not a character" x)))
(die 'char-downcase "not a character" x)))
(define (char-upcase x)
(if (char? x)
($fixnum->char
(convert-char x char-upcase-adjustment-vector))
(error 'char-downcase "not a character" x)))
(die 'char-downcase "not a character" x)))
(define (char-titlecase x)
(if (char? x)
($fixnum->char
(convert-char x char-titlecase-adjustment-vector))
(error 'char-downcase "not a character" x)))
(die 'char-downcase "not a character" x)))
(define (char-foldcase x)
(if (char? x)
($fixnum->char ($fold x))
(error 'char-downcase "not a character" x)))
(die 'char-downcase "not a character" x)))
(define ($fold x)
(convert-char x char-foldcase-adjustment-vector))
@ -137,7 +137,7 @@
(define (char-ci-loop c0 ls p? who)
(or (null? ls)
(let ([c1 (car ls)])
(unless (char? c1) (error who "not a char" c1))
(unless (char? c1) (die who "not a char" c1))
(let ([c1 ($fold c1)])
(if (p? c0 c1)
(char-ci-loop c1 (cdr ls) p? who)
@ -146,7 +146,7 @@
[(null? ls) #f]
[(char? (car ls))
(f (cdr ls) who)]
[else (error who "not a char" (car ls))])))))))
[else (die who "not a char" (car ls))])))))))
(define char-ci=?
(case-lambda
@ -155,14 +155,14 @@
(or (eq? x y)
(if (char? y)
($fx= ($fold x) ($fold y))
(error 'char-ci=? "not a char" y)))
(error 'char-ci=? "not a char" x))]
(die 'char-ci=? "not a char" y)))
(die 'char-ci=? "not a char" x))]
[(x)
(or (char? x) (error 'char-ci=? "not a char" x))]
(or (char? x) (die 'char-ci=? "not a char" x))]
[(x . x*)
(if (char? x)
(char-ci-loop x x* char=? 'char-ci=?)
(error 'char-ci=? "not a char" x))]))
(die 'char-ci=? "not a char" x))]))
(define char-ci<?
(case-lambda
@ -171,14 +171,14 @@
(or (eq? x y)
(if (char? y)
($fx< ($fold x) ($fold y))
(error 'char-ci<? "not a char" y)))
(error 'char-ci<? "not a char" x))]
(die 'char-ci<? "not a char" y)))
(die 'char-ci<? "not a char" x))]
[(x)
(or (char? x) (error 'char-ci<? "not a char" x))]
(or (char? x) (die 'char-ci<? "not a char" x))]
[(x . x*)
(if (char? x)
(char-ci-loop x x* char<? 'char-ci<?)
(error 'char-ci<? "not a char" x))]))
(die 'char-ci<? "not a char" x))]))
(define char-ci<=?
(case-lambda
@ -187,14 +187,14 @@
(or (eq? x y)
(if (char? y)
($fx<= ($fold x) ($fold y))
(error 'char-ci<=? "not a char" y)))
(error 'char-ci<=? "not a char" x))]
(die 'char-ci<=? "not a char" y)))
(die 'char-ci<=? "not a char" x))]
[(x)
(or (char? x) (error 'char-ci<=? "not a char" x))]
(or (char? x) (die 'char-ci<=? "not a char" x))]
[(x . x*)
(if (char? x)
(char-ci-loop x x* char<=? 'char-ci<=?)
(error 'char-ci<=? "not a char" x))]))
(die 'char-ci<=? "not a char" x))]))
(define char-ci>?
(case-lambda
@ -203,14 +203,14 @@
(or (eq? x y)
(if (char? y)
($fx> ($fold x) ($fold y))
(error 'char-ci>? "not a char" y)))
(error 'char-ci>? "not a char" x))]
(die 'char-ci>? "not a char" y)))
(die 'char-ci>? "not a char" x))]
[(x)
(or (char? x) (error 'char-ci>? "not a char" x))]
(or (char? x) (die 'char-ci>? "not a char" x))]
[(x . x*)
(if (char? x)
(char-ci-loop x x* char>? 'char-ci>?)
(error 'char-ci>? "not a char" x))]))
(die 'char-ci>? "not a char" x))]))
(define char-ci>=?
(case-lambda
@ -219,14 +219,14 @@
(or (eq? x y)
(if (char? y)
($fx>= ($fold x) ($fold y))
(error 'char-ci>=? "not a char" y)))
(error 'char-ci>=? "not a char" x))]
(die 'char-ci>=? "not a char" y)))
(die 'char-ci>=? "not a char" x))]
[(x)
(or (char? x) (error 'char-ci>=? "not a char" x))]
(or (char? x) (die 'char-ci>=? "not a char" x))]
[(x . x*)
(if (char? x)
(char-ci-loop x x* char>=? 'char-ci>=?)
(error 'char-ci>=? "not a char" x))]))
(die 'char-ci>=? "not a char" x))]))
(define ($string-foldcase str)
(define (extend-length str ac)
@ -282,7 +282,7 @@
(define (string-foldcase str)
(if (string? str)
($string-foldcase str)
(error 'string-foldcase "not a string" str)))
(die 'string-foldcase "not a string" str)))
;;; FIXME: case-insensitive comparison procedures are slow.
@ -293,8 +293,8 @@
(if (string? s1)
(if (string? s2)
(cmp ($string-foldcase s1) ($string-foldcase s2))
(error who "not a string" s2))
(error who "not a string" s1))]
(die who "not a string" s2))
(die who "not a string" s1))]
[(s1 . s*)
(if (string? s1)
(let ([s1 ($string-foldcase s1)])
@ -313,10 +313,10 @@
[(string? (car s*))
(f (cdr s*))]
[else
(error who "not a string"
(die who "not a string"
(car s*))]))))
(error who "not a string" s2)))])))
(error who "not a string" s1))])))
(die who "not a string" s2)))])))
(die who "not a string" s1))])))
(define string-ci=? (string-ci-cmp 'string-ci=? string=?))

74
scheme/ikarus.vectors.ss
View File

@ -31,7 +31,7 @@
(define vector-length
(lambda (x)
(unless (vector? x)
(error 'vector-length "not a vector" x))
(die 'vector-length "not a vector" x))
($vector-length x)))
(module (make-vector)
@ -47,7 +47,7 @@
[(n) (make-vector n (void))]
[(n fill)
(unless (and (fixnum? n) ($fx>= n 0))
(error 'make-vector "not a valid length" n))
(die 'make-vector "not a valid length" n))
(fill! ($make-vector n) 0 n fill)])))
@ -74,23 +74,23 @@
(define vector-ref
(lambda (v i)
(unless (vector? v)
(error 'vector-ref "not a vector" v))
(die 'vector-ref "not a vector" v))
(unless (fixnum? i)
(error 'vector-ref "not a valid index" i))
(die 'vector-ref "not a valid index" i))
(unless (and ($fx< i ($vector-length v))
($fx<= 0 i))
(error 'vector-ref "index is out of range" i v))
(die 'vector-ref "index is out of range" i v))
($vector-ref v i)))
(define vector-set!
(lambda (v i c)
(unless (vector? v)
(error 'vector-set! "not a vector" v))
(die 'vector-set! "not a vector" v))
(unless (fixnum? i)
(error 'vector-set! "not a valid index" i))
(die 'vector-set! "not a valid index" i))
(unless (and ($fx< i ($vector-length v))
($fx<= 0 i))
(error 'vector-set! "index is out of range" i v))
(die 'vector-set! "index is out of range" i v))
($vector-set! v i c)))
(define vector->list
@ -106,7 +106,7 @@
(if ($fxzero? n)
'()
(f v ($fxsub1 n) '())))
(error 'vector->list "not a vector" v))))
(die 'vector->list "not a vector" v))))
(define list->vector
(letrec ([race
@ -116,13 +116,13 @@
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'list->vector "circular list" ls))
(die 'list->vector "circular list" ls))
(if (null? h)
($fx+ n 1)
(error 'list->vector "not a proper list" ls))))
(die 'list->vector "not a proper list" ls))))
(if (null? h)
n
(error 'list->vector "not a proper list" ls))))]
(die 'list->vector "not a proper list" ls))))]
[fill
(lambda (v i ls)
(cond
@ -152,9 +152,9 @@
(case-lambda
[(p v)
(unless (procedure? p)
(error who "not a procedure" p))
(die who "not a procedure" p))
(unless (vector? v)
(error who "not a vector" v))
(die who "not a vector" v))
(let f ([p p] [v v] [i 0] [n (vector-length v)] [ac '()])
(cond
[($fx= i n) (ls->vec ac n)]
@ -162,14 +162,14 @@
(f p v ($fxadd1 i) n (cons (p (vector-ref v i)) ac))]))]
[(p v0 v1)
(unless (procedure? p)
(error who "not a procedure" p))
(die who "not a procedure" p))
(unless (vector? v0)
(error who "not a vector" v0))
(die who "not a vector" v0))
(unless (vector? v1)
(error who "not a vector" v1))
(die who "not a vector" v1))
(let ([n (vector-length v0)])
(unless ($fx= n ($vector-length v1))
(error who "length mismatch" v0 v1))
(die who "length mismatch" v0 v1))
(let f ([p p] [v0 v0] [v1 v1] [i 0] [n n] [ac '()])
(cond
[($fx= i n) (ls->vec ac n)]
@ -178,21 +178,21 @@
(cons (p ($vector-ref v0 i) ($vector-ref v1 i)) ac))])))]
[(p v0 v1 . v*)
(unless (procedure? p)
(error who "not a procedure" p))
(die who "not a procedure" p))
(unless (vector? v0)
(error who "not a vector" v0))
(die who "not a vector" v0))
(unless (vector? v1)
(error who "not a vector" v1))
(die who "not a vector" v1))
(let ([n (vector-length v0)])
(unless ($fx= n ($vector-length v1))
(error who "length mismatch" v0 v1))
(die who "length mismatch" v0 v1))
(let f ([v* v*] [n n])
(unless (null? v*)
(let ([a ($car v*)])
(unless (vector? a)
(error who "not a vector" a))
(die who "not a vector" a))
(unless ($fx= ($vector-length a) n)
(error who "length mismatch")))
(die who "length mismatch")))
(f ($cdr v*) n)))
(let f ([p p] [v0 v0] [v1 v1] [v* v*] [i 0] [n n] [ac '()])
(cond
@ -215,9 +215,9 @@
(case-lambda
[(p v)
(unless (procedure? p)
(error who "not a procedure" p))
(die who "not a procedure" p))
(unless (vector? v)
(error who "not a vector" v))
(die who "not a vector" v))
(let f ([p p] [v v] [i 0] [n (vector-length v)])
(cond
[($fx= i n) (void)]
@ -226,14 +226,14 @@
(f p v ($fxadd1 i) n)]))]
[(p v0 v1)
(unless (procedure? p)
(error who "not a procedure" p))
(die who "not a procedure" p))
(unless (vector? v0)
(error who "not a vector" v0))
(die who "not a vector" v0))
(unless (vector? v1)
(error who "not a vector" v1))
(die who "not a vector" v1))
(let ([n (vector-length v0)])
(unless ($fx= n ($vector-length v1))
(error who "length mismatch" v0 v1))
(die who "length mismatch" v0 v1))
(let f ([p p] [v0 v0] [v1 v1] [i 0] [n n])
(cond
[($fx= i n) (void)]
@ -242,21 +242,21 @@
(f p v0 v1 ($fxadd1 i) n)])))]
[(p v0 v1 . v*)
(unless (procedure? p)
(error who "not a procedure" p))
(die who "not a procedure" p))
(unless (vector? v0)
(error who "not a vector" v0))
(die who "not a vector" v0))
(unless (vector? v1)
(error who "not a vector" v1))
(die who "not a vector" v1))
(let ([n (vector-length v0)])
(unless ($fx= n ($vector-length v1))
(error who "length mismatch" v0 v1))
(die who "length mismatch" v0 v1))
(let f ([v* v*] [n n])
(unless (null? v*)
(let ([a ($car v*)])
(unless (vector? a)
(error who "not a vector" a))
(die who "not a vector" a))
(unless ($fx= ($vector-length a) n)
(error who "length mismatch")))
(die who "length mismatch")))
(f ($cdr v*) n)))
(let f ([p p] [v0 v0] [v1 v1] [v* v*] [i 0] [n n])
(cond
@ -272,7 +272,7 @@
(define (vector-fill! v fill)
(unless (vector? v)
(error 'vector-fill! "not a vector" v))
(die 'vector-fill! "not a vector" v))
(let f ([v v] [i 0] [n ($vector-length v)] [fill fill])
(unless ($fx= i n)
($vector-set! v i fill)

36
scheme/ikarus.writer.ss
View File

@ -334,7 +334,7 @@
(write-char #\. p)
(write-char #\. p)
(write-char #\. p)]
[else (error 'write-peculiear "BUG")])))
[else (die 'write-peculiear "BUG")])))
(define write-symbol
(lambda (x p m)
@ -721,7 +721,7 @@
(cond
[(fx= i (string-length fmt))
(unless (null? args)
(error who
(die who
(format
"extra arguments given for format string \x2036;~a\x2033;"
fmt)))]
@ -731,30 +731,30 @@
[(eqv? c #\~)
(let ([i (fxadd1 i)])
(when (fx= i (string-length fmt))
(error who "invalid ~ at end of format string" fmt))
(die who "invalid ~ at end of format string" fmt))
(let ([c (string-ref fmt i)])
(cond
[(memv c '(#\~ #\%)) (f (fxadd1 i) args)]
[(memv c '(#\a #\s))
(when (null? args)
(error who "insufficient arguments"))
(die who "insufficient arguments"))
(f (fxadd1 i) (cdr args))]
[(memv c '(#\b #\o #\x #\d))
(when (null? args)
(error who "insufficient arguments"))
(die who "insufficient arguments"))
(let ([a (car args)])
(cond
[(or (fixnum? a) (bignum? a) (ratnum? a))
(void)]
[(flonum? a)
(unless (eqv? c #\d)
(error who
(die who
(format "flonums cannot be printed with ~~~a" c)))]
[else
(error who "not a number" a)]))
(die who "not a number" a)]))
(f (fxadd1 i) (cdr args))]
[else
(error who "invalid sequence character after ~" c)])))]
(die who "invalid sequence character after ~" c)])))]
[else (f (fxadd1 i) args)]))]))
;;; then format
(let f ([i 0] [args args])
@ -787,9 +787,9 @@
[(flonum? a)
(display-to-port (number->string a) p)]
[else
(error who "BUG: not a number" a)]))
(die who "BUG: not a number" a)]))
(f (fxadd1 i) (cdr args)))]
[else (error who "BUG" c)])))]
[else (die who "BUG" c)])))]
[else
(write-char c p)
(f (fxadd1 i) args)]))))
@ -799,15 +799,15 @@
(define fprintf
(lambda (port fmt . args)
(unless (output-port? port)
(error 'fprintf "not an output port" port))
(die 'fprintf "not an output port" port))
(unless (string? fmt)
(error 'fprintf "not a string" fmt))
(die 'fprintf "not a string" fmt))
(formatter 'fprintf port fmt args)))
(define display-error
(lambda (errname who fmt args)
(unless (string? fmt)
(error 'print-error "not a string" fmt))
(die 'print-error "not a string" fmt))
(let ([p (standard-error-port)])
(if who
(fprintf p "~a in ~a: " errname who)
@ -819,7 +819,7 @@
(define format
(lambda (fmt . args)
(unless (string? fmt)
(error 'format "not a string" fmt))
(die 'format "not a string" fmt))
(let-values ([(p e) (open-string-output-port)])
(formatter 'format p fmt args)
(e))))
@ -827,7 +827,7 @@
(define printf
(lambda (fmt . args)
(unless (string? fmt)
(error 'printf "not a string" fmt))
(die 'printf "not a string" fmt))
(formatter 'printf (current-output-port) fmt args)))
(define write
@ -835,12 +835,12 @@
[(x) (write-to-port x (current-output-port))]
[(x p)
(unless (output-port? p)
(error 'write "not an output port" p))
(die 'write "not an output port" p))
(write-to-port x p)]))
(define (put-datum p x)
(unless (output-port? p)
(error 'put-datum "not an output port" p))
(die 'put-datum "not an output port" p))
(write-to-port x p))
(define display
@ -848,7 +848,7 @@
[(x) (display-to-port x (current-output-port))]
[(x p)
(unless (output-port? p)
(error 'display "not an output port" p))
(die 'display "not an output port" p))
(display-to-port x p)]))
(define print-error

1
scheme/makefile.ss
View File

@ -659,6 +659,7 @@
[equal? i r ba se]
[eqv? i r ba se]
[error i r ba]
[die i]
[even? i r ba se]
[exact i r ba]
[exact-integer-sqrt i r ba]

134
scheme/psyntax.expander.ss
View File

@ -76,7 +76,7 @@
(cond
((symbol? sym) (gensym sym))
((stx? sym) (gen-lexical (id->sym sym)))
(else (error 'gen-lexical "BUG: invalid arg" sym)))))
(else (assertion-violation 'gen-lexical "BUG: invalid arg" sym)))))
;;; gen-global is used to generate global names (e.g. locations
;;; for library exports). We use gen-lexical since it works just
@ -117,7 +117,7 @@
(car label*)
(find sym mark* (cdr sym*) (cdr mark**) (cdr label*)))))
(when (rib-sealed/freq rib)
(error 'extend-rib! "rib is sealed" rib))
(assertion-violation 'extend-rib! "rib is sealed" rib))
(let ((sym (id->sym id))
(mark* (stx-mark* id)))
(let ((sym* (rib-sym* rib)))
@ -127,7 +127,7 @@
=>
(lambda (label^)
(unless (eq? label label^)
;;; signal an error if the identifier was already
;;; signal an assertion-violation if the identifier was already
;;; in the rib.
(stx-error id "cannot redefine")))]
[else
@ -347,7 +347,7 @@
(m* (stx-mark* x)) (s* (stx-subst* x)))
(map (lambda (x) (mkstx x m* s*)) ls)))
((vector? x) (vector->list x))
(else (error 'syntax-vector->list "not a syntax vector" x)))))
(else (assertion-violation 'syntax-vector->list "not a syntax vector" x)))))
(define syntax-pair?
(lambda (x) (syntax-kind? x pair?)))
(define syntax-vector?
@ -364,21 +364,21 @@
(mkstx (syntax-car (stx-expr x)) (stx-mark* x) (stx-subst* x))
(if (pair? x)
(car x)
(error 'syntax-car "not a pair" x)))))
(assertion-violation 'syntax-car "not a pair" x)))))
(define syntax->list
(lambda (x)
(if (syntax-pair? x)
(cons (syntax-car x) (syntax->list (syntax-cdr x)))
(if (syntax-null? x)
'()
(error 'syntax->list "invalid argument" x)))))
(assertion-violation 'syntax->list "invalid argument" x)))))
(define syntax-cdr
(lambda (x)
(if (stx? x)
(mkstx (syntax-cdr (stx-expr x)) (stx-mark* x) (stx-subst* x))
(if (pair? x)
(cdr x)
(error 'syntax-cdr "not a pair" x)))))
(assertion-violation 'syntax-cdr "not a pair" x)))))
(define id?
(lambda (x) (syntax-kind? x symbol?)))
@ -388,7 +388,7 @@
(id->sym (stx-expr x))
(if (symbol? x)
x
(error 'id->sym "not an id" x)))))
(assertion-violation 'id->sym "not an id" x)))))
;;; Two lists of marks are considered the same if they have the
;;; same length and the corresponding marks on each are eq?.
@ -578,9 +578,9 @@
(lambda (x)
(syntax-case x ()
((_ stx)
(syntax (error 'expander "invalid syntax" (stx->datum stx))))
(syntax (assertion-violation 'expander "invalid syntax" (stx->datum stx))))
((_ stx msg arg* ...)
(syntax (error 'expander msg (strip stx '()) arg* ...))))))
(syntax (assertion-violation 'expander msg (strip stx '()) arg* ...))))))
;;; when the rhs of a syntax definition is evaluated, it should be
;;; either a procedure, an identifier-syntax transformer or an
@ -589,7 +589,7 @@
;;; (lacal-macro . procedure)
;;; (local-macro! . procedure)
;;; ($rtd . $rtd)
;;; and signals an error otherwise.
;;; and signals an assertion-violation otherwise.
(define sanitize-binding
(lambda (x src)
(cond
@ -598,14 +598,14 @@
((and (pair? x) (eq? (car x) 'macro!) (procedure? (cdr x)))
(cons* 'local-macro! (cdr x) src))
((and (pair? x) (eq? (car x) '$rtd)) x)
(else (error 'expand "invalid transformer" x)))))
(else (assertion-violation 'expand "invalid transformer" x)))))
;;; r6rs's make-variable-transformer:
(define make-variable-transformer
(lambda (x)
(if (procedure? x)
(cons 'macro! x)
(error 'make-variable-transformer
(assertion-violation 'make-variable-transformer
"not a procedure" x))))
;;; make-eval-transformer takes an expanded expression,
@ -1111,7 +1111,7 @@
(let ((v ,expr))
(if (procedure? v)
(make-traced-procedure ',who v)
(error 'trace-define
(assertion-violation 'trace-define
"not a procedure" v)))))
(stx-error stx "invalid name"))))))
@ -1124,7 +1124,7 @@
(let ((v ,expr))
(if (procedure? v)
(make-traced-procedure ',who v syntax->datum)
(error 'trace-define-syntax
(assertion-violation 'trace-define-syntax
"not a procedure" v)))))
(stx-error stx "invalid name"))))))
@ -1233,7 +1233,7 @@
(syntax-match stx ()
((_ expr)
(bless `(unless ,expr
(error 'assert "assertion failed" ',expr)))))))
(assertion-violation 'assert "assertion failed" ',expr)))))))
(define endianness-macro
(lambda (stx)
@ -1597,7 +1597,7 @@
(lambda (x)
(if ($struct/rtd? x ',rtd)
($struct-ref x ,i)
(error ',getter
(assertion-violation ',getter
"not a struct of required type"
x ',rtd)))))
getters i*)
@ -1606,7 +1606,7 @@
(lambda (x v)
(if ($struct/rtd? x ',rtd)
($struct-set! x ,i v)
(error ',setter
(assertion-violation ',setter
"not a struct of required type"
x ',rtd)))))
setters i*)))))))
@ -1624,7 +1624,7 @@
(cond
[(symbol? x) (symbol->string x)]
[(string? x) x]
[else (error 'define-record-type "BUG")]))
[else (assertion-violation 'define-record-type "BUG")]))
str*)))))
(define (get-record-name spec)
(syntax-match spec ()
@ -2011,7 +2011,7 @@
(match-empty (vector-ref p 3) r))))
((free-id atom) r)
((vector) (match-empty (vector-ref p 1) r))
(else (error 'syntax-dispatch "invalid pattern" p)))))))
(else (assertion-violation 'syntax-dispatch "invalid pattern" p)))))))
(define combine
(lambda (r* r)
(if (null? (car r*))
@ -2051,7 +2051,7 @@
((vector)
(and (vector? e)
(match (vector->list e) (vector-ref p 1) m* s* r)))
(else (error 'syntax-dispatch "invalid pattern" p)))))))
(else (assertion-violation 'syntax-dispatch "invalid pattern" p)))))))
(define match
(lambda (e p m* s* r)
(cond
@ -2334,7 +2334,7 @@
((type-descriptor) type-descriptor-transformer)
((record-type-descriptor) record-type-descriptor-transformer)
((record-constructor-descriptor) record-constructor-descriptor-transformer)
(else (error 'macro-transformer "cannot find transformer" name)))))
(else (assertion-violation 'macro-transformer "cannot find transformer" name)))))
(define file-options-macro
(lambda (x)
@ -2398,8 +2398,8 @@
fields mutable immutable parent protocol
sealed opaque nongenerative parent-rtd)
incorrect-usage-macro)
(else (error 'macro-transformer "invalid macro" x))))
(else (error 'core-macro-transformer "invalid macro" x)))))
(else (assertion-violation 'macro-transformer "invalid macro" x))))
(else (assertion-violation 'core-macro-transformer "invalid macro" x)))))
(define (local-macro-transformer x)
(car x))
@ -2424,7 +2424,7 @@
(let ((transformer
(cond
((procedure? x) x)
(else (error 'chi-global-macro "not a procedure")))))
(else (assertion-violation 'chi-global-macro "not a procedure")))))
(let ((s (transformer (add-mark anti-mark e))))
(add-mark (gen-mark) s))))))
@ -2514,7 +2514,7 @@
(stx-error e
"attempt to reference an unexportable variable"))
(else
;(error 'chi-expr "invalid type " type (strip e '()))
;(assertion-violation 'chi-expr "invalid type " type (strip e '()))
(stx-error e "invalid expression"))))))
(define chi-set!
@ -2600,7 +2600,7 @@
(build-sequence no-source
(list (chi-expr expr r mr)
(build-void)))))
(else (error 'chi-rhs "invalid rhs" rhs)))))
(else (assertion-violation 'chi-rhs "invalid rhs" rhs)))))
(define chi-rhs*
(lambda (rhs* r mr)
@ -2814,7 +2814,7 @@
[(local-macro) 'global-macro]
[(local-macro!) 'global-macro!]
[else
(error 'set-global-macro-binding!
(assertion-violation 'set-global-macro-binding!
"BUG: invalid type" b)])]
[transformer (cadr b)]
[label (id->label id)]
@ -2868,7 +2868,7 @@
(set-global-macro-binding! id loc b)
(chi-top* (cdr e*) init*))))))
((let-syntax letrec-syntax)
(error 'chi-top* "not supported yet at top level" type))
(assertion-violation 'chi-top* "not supported yet at top level" type))
((begin)
(syntax-match e ()
((_ x* ...)
@ -2903,7 +2903,7 @@
(else
(extend-library-subst! lib sym label))))
subst-names subst-labels)))
(else (error 'import "BUG: cannot happen"))))])
(else (assertion-violation 'import "BUG: cannot happen"))))])
(chi-top* (cdr e*) init*)))
(else
(chi-top* (cdr e*)
@ -2930,7 +2930,7 @@
((null? exp*)
(let ((id* (map (lambda (x) (mkstx x top-mark* '())) ext*)))
(unless (valid-bound-ids? id*)
(error 'expander "invalid exports" (find-dups id*))))
(assertion-violation 'expander "invalid exports" (find-dups id*))))
(values int* ext*))
(else
(syntax-match (car exp*) ()
@ -2938,11 +2938,11 @@
(begin
(unless (and (eq? rename 'rename) (for-all symbol? i*)
(for-all symbol? e*))
(error 'expander "invalid export specifier" (car exp*)))
(assertion-violation 'expander "invalid export specifier" (car exp*)))
(f (cdr exp*) (append i* int*) (append e* ext*))))
(ie
(begin
(unless (symbol? ie) (error 'expander "invalid export" ie))
(unless (symbol? ie) (assertion-violation 'expander "invalid export" ie))
(f (cdr exp*) (cons ie int*) (cons ie ext*)))))))))
;;; given a library name, like (foo bar (1 2 3)),
@ -2983,7 +2983,7 @@
;;; and (#<library (foo)> #<library (bar)>)
(define (parse-import-spec* imp*)
(define (dup-error name)
(error 'import "two imports with different bindings" name))
(assertion-violation 'import "two imports with different bindings" name))
(define (merge-substs s subst)
(define (insert-to-subst a subst)
(let ((name (car a)) (label (cdr a)))
@ -3004,7 +3004,7 @@
(define (exclude sym subst)
(cond
((null? subst)
(error 'import "cannot rename unbound identifier" sym))
(assertion-violation 'import "cannot rename unbound identifier" sym))
((eq? sym (caar subst))
(values (cdar subst) (cdr subst)))
(else
@ -3021,7 +3021,7 @@
(map (lambda (x)
(cond
((assq x subst) => cdr)
(else (error 'import "cannot find identifier" x))))
(else (assertion-violation 'import "cannot find identifier" x))))
sym*))
(define (rem* sym* subst)
(let f ((subst subst))
@ -3057,7 +3057,7 @@
(lambda (x) (<= x n))]
[(p? n) (and (eq? p? '>=) (subversion? n))
(lambda (x) (>= x n))]
[_ (error 'import "invalid sub-version spec" x* spec)]))
[_ (assertion-violation 'import "invalid sub-version spec" x* spec)]))
(define (version-pred x*)
(syntax-match x* ()
[() (lambda (x) #t)]
@ -3082,7 +3082,7 @@
[else
(and ((car p*) (car x))
(f (cdr p*) (cdr x*)))]))))]
[_ (error 'import "invalid version spec" x* spec)]))
[_ (assertion-violation 'import "invalid version spec" x* spec)]))
(let f ([x spec])
(syntax-match x ()
[((version-spec* ...))
@ -3130,14 +3130,14 @@
;;; FIXME: versioning stuff
(let-values ([(name pred) (parse-library-name spec*)])
(when (null? name)
(error 'import "empty library name" spec*))
(assertion-violation 'import "empty library name" spec*))
(let ((lib (find-library-by-name name)))
(unless lib
(error 'import
(assertion-violation 'import
"cannot find library with required name"
name))
(unless (pred (library-version lib))
(error 'import
(assertion-violation 'import
"library does not satisfy version specification"
lib
spec*))
@ -3146,7 +3146,7 @@
((x x* ...)
(not (memq x '(rename except only prefix library)))
(get-import `(library (,x . ,x*))))
(spec (error 'import "invalid import spec" spec))))
(spec (assertion-violation 'import "invalid import spec" spec))))
(define (add-imports! imp h)
(let ([subst (get-import imp)])
(for-each
@ -3193,28 +3193,28 @@
(define inv-collector
(make-parameter
(lambda args
(error 'inv-collector "not initialized"))
(assertion-violation 'inv-collector "not initialized"))
(lambda (x)
(unless (procedure? x)
(error 'inv-collector "not a procedure" x))
(assertion-violation 'inv-collector "not a procedure" x))
x)))
(define vis-collector
(make-parameter
(lambda args
(error 'vis-collector "not initialized"))
(assertion-violation 'vis-collector "not initialized"))
(lambda (x)
(unless (procedure? x)
(error 'vis-collector "not a procedure" x))
(assertion-violation 'vis-collector "not a procedure" x))
x)))
(define imp-collector
(make-parameter
(lambda args
(error 'imp-collector "not initialized"))
(assertion-violation 'imp-collector "not initialized"))
(lambda (x)
(unless (procedure? x)
(error 'imp-collector "not a procedure" x))
(assertion-violation 'imp-collector "not a procedure" x))
x)))
(define chi-library-internal
@ -3258,7 +3258,7 @@
(let ([b (cdr p)])
(let ([type (car b)])
(when (eq? type 'mutable)
(error 'export errstr name))))))))
(assertion-violation 'export errstr name))))))))
export-subst)
(let ((invoke-body
(build-library-letrec* no-source
@ -3295,10 +3295,10 @@
(((import imp* ...) b* ...) (eq? import 'import)
(values imp* b*))
(((import . x) . y) (eq? import 'import)
(error 'expander
(assertion-violation 'expander
"invalid syntax of top-level program"))
(_
(error 'expander
(assertion-violation 'expander
"top-level program is missing an (import ---) clause"))))
(define top-level-expander
@ -3314,7 +3314,7 @@
(define-record env (names labels itc)
(lambda (x p)
(unless (env? x)
(error 'record-type-printer "not an environment"))
(assertion-violation 'record-type-printer "not an environment"))
(display "#<environment>" p)))
(define environment?
@ -3335,11 +3335,11 @@
;;; constructed simply using the corresponding libraries.
(define (null-environment n)
(unless (eqv? n 5)
(error 'null-environment "not 5" n))
(assertion-violation 'null-environment "not 5" n))
(environment '(psyntax null-environment-5)))
(define (scheme-report-environment n)
(unless (eqv? n 5)
(error 'scheme-report-environment "not 5" n))
(assertion-violation 'scheme-report-environment "not 5" n))
(environment '(psyntax scheme-report-environment-5)))
;;; The expand procedure is the interface to the internal expression
@ -3349,7 +3349,7 @@
(define expand
(lambda (x env)
(unless (env? env)
(error 'expand "not an environment" env))
(assertion-violation 'expand "not an environment" env))
(let ((rib (make-top-rib (env-names env) (env-labels env))))
(let ((x (mkstx x top-mark* (list rib)))
(itc (env-itc env))
@ -3369,7 +3369,7 @@
(define eval
(lambda (x env)
(unless (env? env)
(error 'eval "not an environment" env))
(assertion-violation 'eval "not an environment" env))
(let-values (((x invoke-req*) (expand x env)))
(for-each invoke-library invoke-req*)
(eval-core (expanded->core x)))))
@ -3450,7 +3450,7 @@
(if (eq? x (car lex*))
(car loc*)
(f x (cdr lex*) (cdr loc*)))]
[else (error 'lookup-make-export "BUG")])))
[else (assertion-violation 'lookup-make-export "BUG")])))
(let f ((r r) (env '()) (global* '()) (macro* '()))
(cond
((null? r) (values env global* macro*))
@ -3482,7 +3482,7 @@
(cons (cons loc (binding-value b)) macro*))))
(($rtd $module) (f (cdr r) (cons x env) global* macro*))
(else
(error 'expander "BUG: do not know how to export"
(assertion-violation 'expander "BUG: do not know how to export"
(binding-type b) (binding-value b))))))))))
(define generate-temporaries
@ -3499,28 +3499,28 @@
top-mark* '()))
ls))
(_
(error 'generate-temporaries "not a list")))))
(assertion-violation 'generate-temporaries "not a list")))))
(define free-identifier=?
(lambda (x y)
(if (id? x)
(if (id? y)
(free-id=? x y)
(error 'free-identifier=? "not an identifier" y))
(error 'free-identifier=? "not an identifier" x))))
(assertion-violation 'free-identifier=? "not an identifier" y))
(assertion-violation 'free-identifier=? "not an identifier" x))))
(define bound-identifier=?
(lambda (x y)
(if (id? x)
(if (id? y)
(bound-id=? x y)
(error 'bound-identifier=? "not an identifier" y))
(error 'bound-identifier=? "not an identifier" x))))
(assertion-violation 'bound-identifier=? "not an identifier" y))
(assertion-violation 'bound-identifier=? "not an identifier" x))))
(define syntax-error
(lambda (x . args)
(unless (for-all string? args)
(error 'syntax-error "invalid argument" args))
(assertion-violation 'syntax-error "invalid argument" args))
(raise
(condition
(make-message-condition
@ -3537,7 +3537,7 @@
(syntax-violation who msg form #f)]
[(who msg form subform)
(unless (string? msg)
(error 'syntax-violation "message is not a string" msg))
(assertion-violation 'syntax-violation "message is not a string" msg))
(let ([who
(cond
[(or (string? who) (symbol? who)) who]
@ -3547,7 +3547,7 @@
[(id . rest) (id? id) (syntax->datum id)]
[_ #f])]
[else
(error 'syntax-violation
(assertion-violation 'syntax-violation
"invalid who argument" who)])])
(raise
(condition
@ -3565,7 +3565,7 @@
(lambda (id datum)
(if (id? id)
(datum->stx id datum)
(error 'datum->syntax "not an identifier" id))))
(assertion-violation 'datum->syntax "not an identifier" id))))
(define syntax->datum
(lambda (x) (stx->datum x)))

38
scheme/psyntax.library-manager.ss
View File

@ -44,14 +44,14 @@
(make-parameter (make-collection)
(lambda (x)
(unless (procedure? x)
(error 'current-library-collection "not a procedure" x))
(assertion-violation 'current-library-collection "not a procedure" x))
x)))
(define-record library
(id name version imp* vis* inv* subst env visit-state invoke-state visible?)
(lambda (x p)
(unless (library? x)
(error 'record-type-printer "not a library"))
(assertion-violation 'record-type-printer "not a library"))
(display
(format "#<library ~s>"
(if (null? (library-version x))
@ -62,7 +62,7 @@
(define (find-dependencies ls)
(cond
((null? ls) '())
(else (error 'find-dependencies "cannot handle deps yet"))))
(else (assertion-violation 'find-dependencies "cannot handle deps yet"))))
(define (find-library-by pred)
(let f ((ls ((current-library-collection))))
@ -77,7 +77,7 @@
(lambda (x)
(if (and (list? x) (for-all string? x))
(map (lambda (x) x) x)
(error 'library-path "not a list of strings" x)))))
(assertion-violation 'library-path "not a list of strings" x)))))
(define (library-name->file-name x)
(let-values (((p extract) (open-string-output-port)))
@ -141,7 +141,7 @@
(lambda (f)
(if (procedure? f)
f
(error 'file-locator "not a procedure" f)))))
(assertion-violation 'file-locator "not a procedure" f)))))
(define library-locator
(make-parameter
@ -152,17 +152,17 @@
(lambda (f)
(if (procedure? f)
f
(error 'library-locator
(assertion-violation 'library-locator
"not a procedure" f)))))
(define current-library-expander
(make-parameter
(lambda (x)
(error 'library-expander "not initialized"))
(assertion-violation 'library-expander "not initialized"))
(lambda (f)
(if (procedure? f)
f
(error 'library-expander
(assertion-violation 'library-expander
"not a procedure" f)))))
(define external-pending-libraries
@ -170,16 +170,16 @@
(define (find-external-library name)
(when (member name (external-pending-libraries))
(error #f "circular attempt to import library was detected" name))
(assertion-violation #f "circular attempt to import library was detected" name))
(parameterize ((external-pending-libraries
(cons name (external-pending-libraries))))
(let ((lib-expr ((library-locator) name)))
(unless lib-expr
(error #f "cannot find library" name))
(assertion-violation #f "cannot find library" name))
((current-library-expander) lib-expr)
(or (find-library-by
(lambda (x) (equal? (library-name x) name)))
(error #f
(assertion-violation #f
"handling external library did not yield the correct library"
name)))))
@ -197,7 +197,7 @@
(let ((id (car spec)))
(or (find-library-by
(lambda (x) (eq? id (library-id x))))
(error #f "cannot find library with required spec" spec))))
(assertion-violation #f "cannot find library with required spec" spec))))
(define label->binding-table (make-eq-hashtable))
@ -225,9 +225,9 @@
(vis-lib* (map find-library-by-spec/die vis*))
(inv-lib* (map find-library-by-spec/die inv*)))
(unless (and (symbol? id) (list? name) (list? ver))
(error 'install-library "invalid spec with id/name/ver" id name ver))
(assertion-violation 'install-library "invalid spec with id/name/ver" id name ver))
(when (library-exists? name)
(error 'install-library "library is already installed" name))
(assertion-violation 'install-library "library is already installed" name))
(let ((lib (make-library id name ver imp-lib* vis-lib* inv-lib*
exp-subst exp-env visit-code invoke-code
visible?)))
@ -251,10 +251,10 @@
(let ((invoke (library-invoke-state lib)))
(when (procedure? invoke)
(set-library-invoke-state! lib
(lambda () (error 'invoke "circularity detected" lib)))
(lambda () (assertion-violation 'invoke "circularity detected" lib)))
(for-each invoke-library (library-inv* lib))
(set-library-invoke-state! lib
(lambda () (error 'invoke "first invoke did not return" lib)))
(lambda () (assertion-violation 'invoke "first invoke did not return" lib)))
(invoke)
(set-library-invoke-state! lib #t))))
@ -263,10 +263,10 @@
(let ((visit (library-visit-state lib)))
(when (procedure? visit)
(set-library-visit-state! lib
(lambda () (error 'visit "circularity detected" lib)))
(lambda () (assertion-violation 'visit "circularity detected" lib)))
(for-each invoke-library (library-vis* lib))
(set-library-visit-state! lib
(lambda () (error 'invoke "first visit did not return" lib)))
(lambda () (assertion-violation 'invoke "first visit did not return" lib)))
(visit)
(set-library-visit-state! lib #t))))
@ -288,7 +288,7 @@
(define library-spec
(lambda (x)
(unless (library? x)
(error 'library-spec "not a library" x))
(assertion-violation 'library-spec "not a library" x))
(list (library-id x) (library-name x) (library-version x))))
)