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

* removed formatted errors from all source codes.

This commit is contained in:
Abdulaziz Ghuloum 2007-10-25 14:32:26 -04:00
parent 4141d699c5
commit b640d98cbc
50 changed files with 1398 additions and 1360 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
scheme/ikarus.apply.ss
View File

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

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

260
scheme/ikarus.bytevectors.ss
View File

@ -56,18 +56,18 @@
[(k)
(if (and (fixnum? k) ($fx>= k 0))
($make-bytevector k)
(error 'make-bytevector "~s is not a valid size" k))]
(error '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 "~s is not a valid fill" fill))]))
(error 'make-bytevector "not a valid fill" fill))]))
(define bytevector-fill!
(lambda (x fill)
(unless (bytevector? x)
(error 'bytevector-fill! "~s is not a bytevector" x))
(error 'bytevector-fill! "not a bytevector" x))
(unless (and (fixnum? fill) ($fx<= -128 fill) ($fx<= fill 255))
(error 'bytevector-fill! "~s is not a valid fill" fill))
(error 'bytevector-fill! "not a valid fill" fill))
($bytevector-fill x 0 ($bytevector-length x) fill)))
@ -75,23 +75,23 @@
(lambda (x)
(if (bytevector? x)
($bytevector-length x)
(error 'bytevector-length "~s is not a bytevector" x))))
(error '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 ~s for ~s" i x))
(error 'bytevector-s8-ref "~s is not a bytevector" x))))
(error 'bytevector-s8-ref "invalid index" i x))
(error '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 ~s for ~s" i x))
(error 'bytevector-u8-ref "~s is not a bytevector" x))))
(error 'bytevector-u8-ref "invalid index" i x))
(error 'bytevector-u8-ref "not a bytevector" x))))
(define bytevector-s8-set!
@ -100,9 +100,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! "~s is not a byte" v))
(error 'bytevector-s8-set! "invalid index ~s for ~s" i x))
(error 'bytevector-s8-set! "~s is not a bytevector" x))))
(error 'bytevector-s8-set! "not a byte" v))
(error 'bytevector-s8-set! "invalid index" i x))
(error 'bytevector-s8-set! "not a bytevector" x))))
(define bytevector-u8-set!
(lambda (x i v)
@ -110,9 +110,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! "~s is not an octet" v))
(error 'bytevector-u8-set! "invalid index ~s for ~s" i x))
(error 'bytevector-u8-set! "~s is not a bytevector" x))))
(error 'bytevector-u8-set! "not an octet" v))
(error 'bytevector-u8-set! "invalid index" i x))
(error 'bytevector-u8-set! "not a bytevector" x))))
(define bytevector-u16-native-ref ;;; HARDCODED
(lambda (x i)
@ -124,8 +124,8 @@
($fxlogor
($fxsll ($bytevector-u8-ref x i) 8)
($bytevector-u8-ref x ($fxadd1 i)))
(error 'bytevector-u16-native-ref "invalid index ~s" i))
(error 'bytevector-u16-native-ref "~s is not a bytevector" x))))
(error 'bytevector-u16-native-ref "invalid index" i))
(error 'bytevector-u16-native-ref "not a bytevector" x))))
(define bytevector-u16-native-set! ;;; HARDCODED
@ -141,9 +141,9 @@
(begin
($bytevector-set! x i ($fxsra n 8))
($bytevector-set! x ($fxadd1 i) n))
(error 'bytevector-u16-native-set! "invalid index ~s" i))
(error 'bytevector-u16-native-set! "invalid value ~s" n))
(error 'bytevector-u16-native-set! "~s is not a bytevector" x))))
(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))))
(define bytevector-s16-native-set! ;;; HARDCODED
(lambda (x i n)
@ -158,9 +158,9 @@
(begin
($bytevector-set! x i ($fxsra n 8))
($bytevector-set! x ($fxadd1 i) n))
(error 'bytevector-s16-native-set! "invalid index ~s" i))
(error 'bytevector-s16-native-set! "invalid value ~s" n))
(error 'bytevector-s16-native-set! "~s is not a bytevector" x))))
(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))))
(define bytevector-s16-native-ref ;;; HARDCODED
(lambda (x i)
@ -172,8 +172,8 @@
($fxlogor
($fxsll ($bytevector-s8-ref x i) 8)
($bytevector-u8-ref x ($fxadd1 i)))
(error 'bytevector-s16-native-ref "invalid index ~s" i))
(error 'bytevector-s16-native-ref "~s is not a bytevector" x))))
(error 'bytevector-s16-native-ref "invalid index" i))
(error 'bytevector-s16-native-ref "not a bytevector" x))))
(define bytevector-u16-ref
(lambda (x i end)
@ -190,9 +190,9 @@
($fxlogor
($fxsll ($bytevector-u8-ref x (fxadd1 i)) 8)
($bytevector-u8-ref x i))]
[else (error 'bytevector-u16-ref "invalid endianness ~s" end)])
(error 'bytevector-u16-ref "invalid index ~s" i))
(error 'bytevector-u16-ref "~s is not a bytevector" x))))
[else (error 'bytevector-u16-ref "invalid endianness" end)])
(error 'bytevector-u16-ref "invalid index" i))
(error 'bytevector-u16-ref "not a bytevector" x))))
(define bytevector-u32-ref
(lambda (x i end)
@ -215,9 +215,9 @@
($fxlogor
($fxsll ($bytevector-u8-ref x ($fx+ i 1)) 8)
($bytevector-u8-ref x i))))]
[else (error 'bytevector-u32-ref "invalid endianness ~s" end)])
(error 'bytevector-u32-ref "invalid index ~s" i))
(error 'bytevector-u32-ref "~s is not a bytevector" x))))
[else (error 'bytevector-u32-ref "invalid endianness" end)])
(error 'bytevector-u32-ref "invalid index" i))
(error 'bytevector-u32-ref "not a bytevector" x))))
(define bytevector-u32-native-ref
(lambda (x i)
@ -232,8 +232,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 ~s" i))
(error 'bytevector-u32-native-ref "~s is not a bytevector" x))))
(error 'bytevector-u32-native-ref "invalid index" i))
(error 'bytevector-u32-native-ref "not a bytevector" x))))
(define bytevector-s32-ref
(lambda (x i end)
@ -256,9 +256,9 @@
($fxlogor
($fxsll ($bytevector-u8-ref x ($fx+ i 1)) 8)
($bytevector-u8-ref x i))))]
[else (error 'bytevector-s32-ref "invalid endianness ~s" end)])
(error 'bytevector-s32-ref "invalid index ~s" i))
(error 'bytevector-s32-ref "~s is not a bytevector" x))))
[else (error 'bytevector-s32-ref "invalid endianness" end)])
(error 'bytevector-s32-ref "invalid index" i))
(error 'bytevector-s32-ref "not a bytevector" x))))
(define bytevector-s32-native-ref
(lambda (x i)
@ -273,8 +273,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 ~s" i))
(error 'bytevector-s32-native-ref "~s is not a bytevector" x))))
(error 'bytevector-s32-native-ref "invalid index" i))
(error 'bytevector-s32-native-ref "not a bytevector" x))))
(define bytevector-u16-set!
(lambda (x i n end)
@ -292,10 +292,10 @@
[(little)
($bytevector-set! x i n)
($bytevector-set! x ($fxadd1 i) (fxsra n 8))]
[else (error 'bytevector-u16-ref "invalid endianness ~s" end)])
(error 'bytevector-u16-set! "invalid index ~s" i))
(error 'bytevector-u16-set! "invalid value ~s" n))
(error 'bytevector-u16-set! "~s is not a bytevector" x))))
[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))))
(define bytevector-u32-set!
@ -324,10 +324,10 @@
(let ([b (logand n #xFFFF)])
($bytevector-set! x ($fx+ i 1) ($fxsra b 8))
($bytevector-set! x i b))]
[else (error 'bytevector-u32-ref "invalid endianness ~s" end)])
(error 'bytevector-u32-set! "invalid index ~s" i))
(error 'bytevector-u32-set! "invalid value ~s" n))
(error 'bytevector-u32-set! "~s is not a bytevector" x))))
[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))))
(define bytevector-u32-native-set!
(lambda (x i n)
@ -348,9 +348,9 @@
(let ([b (logand 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 ~s" i))
(error 'bytevector-u32-native-set! "invalid value ~s" n))
(error 'bytevector-u32-native-set! "~s is not a bytevector" x))))
(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))))
(define bytevector-s32-native-set!
@ -372,9 +372,9 @@
(let ([b (logand 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 ~s" i))
(error 'bytevector-s32-native-set! "invalid value ~s" n))
(error 'bytevector-s32-native-set! "~s is not a bytevector" x))))
(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))))
(define bytevector-s32-set!
(lambda (x i n end)
@ -402,10 +402,10 @@
(let ([b (logand n #xFFFF)])
($bytevector-set! x ($fx+ i 1) ($fxsra b 8))
($bytevector-set! x i b))]
[else (error 'bytevector-s32-ref "invalid endianness ~s" end)])
(error 'bytevector-s32-set! "invalid index ~s" i))
(error 'bytevector-s32-set! "invalid value ~s" n))
(error 'bytevector-s32-set! "~s is not a bytevector" x))))
[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))))
(define bytevector-s16-ref
(lambda (x i end)
@ -422,9 +422,9 @@
($fxlogor
($fxsll ($bytevector-s8-ref x (fxadd1 i)) 8)
($bytevector-u8-ref x i))]
[else (error 'bytevector-s16-ref "invalid endianness ~s" end)])
(error 'bytevector-s16-ref "invalid index ~s" i))
(error 'bytevector-s16-ref "~s is not a bytevector" x))))
[else (error 'bytevector-s16-ref "invalid endianness" end)])
(error 'bytevector-s16-ref "invalid index" i))
(error 'bytevector-s16-ref "not a bytevector" x))))
(define bytevector-s16-set!
@ -443,10 +443,10 @@
[(little)
($bytevector-set! x i n)
($bytevector-set! x ($fxadd1 i) (fxsra n 8))]
[else (error 'bytevector-s16-ref "invalid endianness ~s" end)])
(error 'bytevector-s16-set! "invalid index ~s" i))
(error 'bytevector-s16-set! "invalid value ~s" n))
(error 'bytevector-s16-set! "~s is not a bytevector" x))))
[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))))
@ -456,7 +456,7 @@
(define bytevector->u8-list
(lambda (x)
(unless (bytevector? x)
(error 'bytevector->u8-list "~s is not a bytevector" x))
(error 'bytevector->u8-list "not a bytevector" x))
(let f ([x x] [i ($bytevector-length x)] [ac '()])
(cond
[($fx= i 0) ac]
@ -472,13 +472,13 @@
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'u8-list->bytevector "circular list ~s" ls))
(error 'u8-list->bytevector "circular list" ls))
(if (null? h)
($fx+ n 1)
(error 'u8-list->bytevector "~s is not a proper list" ls))))
(error 'u8-list->bytevector "not a proper list" ls))))
(if (null? h)
n
(error 'u8-list->bytevector "~s is not a proper list" ls))))]
(error 'u8-list->bytevector "not a proper list" ls))))]
[fill
(lambda (s i ls)
(cond
@ -486,7 +486,7 @@
[else
(let ([c ($car ls)])
(unless (and (fixnum? c) ($fx<= 0 c) ($fx<= c 255))
(error 'u8-list->bytevector "~s is not an octet" c))
(error 'u8-list->bytevector "not an octet" c))
($bytevector-set! s i c)
(fill s ($fxadd1 i) (cdr ls)))]))])
(lambda (ls)
@ -498,7 +498,7 @@
(define bytevector-copy
(lambda (src)
(unless (bytevector? src)
(error 'bytevector-copy "~s is not a bytevector" src))
(error 'bytevector-copy "not a bytevector" src))
(let ([n ($bytevector-length src)])
(let f ([src src] [dst ($make-bytevector n)] [i 0] [n n])
(cond
@ -510,9 +510,9 @@
(define bytevector=?
(lambda (x y)
(unless (bytevector? x)
(error 'bytevector=? "~s is not a bytevector" x))
(error 'bytevector=? "not a bytevector" x))
(unless (bytevector? y)
(error 'bytevector=? "~s is not a bytevector" y))
(error '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])
@ -525,21 +525,21 @@
(lambda (src src-start dst dst-start k)
(cond
[(or (not (fixnum? src-start)) ($fx< src-start 0))
(error 'bytevector-copy! "~s is not a valid starting index" src-start)]
(error 'bytevector-copy! "not a valid starting index" src-start)]
[(or (not (fixnum? dst-start)) ($fx< dst-start 0))
(error 'bytevector-copy! "~s is not a valid starting index" dst-start)]
(error 'bytevector-copy! "not a valid starting index" dst-start)]
[(or (not (fixnum? k)) ($fx< k 0))
(error 'bytevector-copy! "~s is not a valid length" k)]
(error 'bytevector-copy! "not a valid length" k)]
[(not (bytevector? src))
(error 'bytevector-copy! "~s is not a bytevector" src)]
(error 'bytevector-copy! "not a bytevector" src)]
[(not (bytevector? dst))
(error 'bytevector-copy! "~s is not a bytevector" dst)]
(error 'bytevector-copy! "not a bytevector" dst)]
[(let ([n ($fx+ src-start k)])
(or ($fx< n 0) ($fx>= n ($bytevector-length src))))
(error 'bytevector-copy! "~s+~s is out of range" src-start k)]
(error '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! "~s+~s is out of range" dst-start k)]
(error 'bytevector-copy! "out of range" dst-start k)]
[(eq? src dst)
(cond
[($fx< dst-start src-start)
@ -647,33 +647,33 @@
(define bytevector-sint-ref
(lambda (x k endianness size)
(define who 'bytevector-sint-ref)
(unless (bytevector? x) (error who "~s is not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (error who "invalid index ~s" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" 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))
(let ([n ($bytevector-length x)])
(unless ($fx< k n) (error who "index ~s is out of range" k))
(unless ($fx< k n) (error who "index is out of range" k))
(let ([end ($fx+ k size)])
(unless (and ($fx>= end 0) ($fx<= end n))
(error who "~s+~s is out of range" k size))
(error 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 ~s" endianness)])))))
[else (error who "invalid endianness" endianness)])))))
(define bytevector-uint-ref
(lambda (x k endianness size)
(define who 'bytevector-uint-ref)
(unless (bytevector? x) (error who "~s is not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (error who "invalid index ~s" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" 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))
(let ([n ($bytevector-length x)])
(unless ($fx< k n) (error who "index ~s is out of range" k))
(unless ($fx< k n) (error who "index is out of range" k))
(let ([end ($fx+ k size)])
(unless (and ($fx>= end 0) ($fx<= end n))
(error who "~s+~s is out of range" k size))
(error 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 ~s" endianness)])))))
[else (error who "invalid endianness" endianness)])))))
(define (bytevector->some-list x k n ls proc who)
(cond
[($fx= n 0) ls]
@ -683,36 +683,36 @@
[($fx>= i 0)
(bytevector->some-list x k i (cons (proc x i n) ls) proc who)]
[else
(error who "invalid size ~s" k)]))]))
(error who "invalid size" k)]))]))
(define bytevector->uint-list
(lambda (x endianness size)
(define who 'bytevector->uint-list)
(unless (bytevector? x) (error who "~s is not a bytevector" x))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" size))
(unless (bytevector? x) (error who "not a bytevector" x))
(unless (and (fixnum? size) ($fx>= size 1)) (error 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 ~s" endianness)])))
[else (error who "invalid endianness" endianness)])))
(define bytevector->sint-list
(lambda (x endianness size)
(define who 'bytevector->sint-list)
(unless (bytevector? x) (error who "~s is not a bytevector" x))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" size))
(unless (bytevector? x) (error who "not a bytevector" x))
(unless (and (fixnum? size) ($fx>= size 1)) (error 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 ~s" endianness)]))))
[else (error 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 ~s does not fit" no))]
(error 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))]))
@ -720,7 +720,7 @@
(cond
[($fx= k1 k2)
(unless ($fx= n -1) ;;; BUG: does not catch all errors
(error who "number ~s does not fit" no))]
(error 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))]))
@ -728,7 +728,7 @@
(cond
[($fx= k1 k2)
(unless ($fxzero? n)
(error who "number ~s does not fit" no))]
(error who "number does not fit" no))]
[else
(let ([k2 ($fxsub1 k2)])
(bufx-set! x k1 ($fxsra n 8) k2 who no)
@ -737,7 +737,7 @@
(cond
[($fx= k1 k2)
(unless ($fx= n -1)
(error who "number ~s does not fit" no))]
(error who "number does not fit" no))]
[else
(let ([k2 ($fxsub1 k2)])
(bsfx-set! x k1 ($fxsra n 8) k2 who no)
@ -765,8 +765,8 @@
[(#x00) ;;; borrow is 0, last byte was positive
(if ($fx< xi xj)
(bv-neg-zero! x xi xj)
(error who "number ~s does not fit" n))]
[else (error 'lbn-neg-copy! "BUG: not handled ~s" c)])]
(error who "number does not fit" n))]
[else (error '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)
@ -782,8 +782,8 @@
[(#x00) ;;; borrow is 0, last byte was positive
(if ($fx< xi xj)
(bv-neg-zero! x xi xj)
(error who "number ~s does not fit" n))]
[else (error 'bbn-neg-copy! "BUG: not handled ~s" c)])]
(error who "number does not fit" n))]
[else (error 'bbn-neg-copy! "BUG: not handled" c)])]
[else
(let ([c ($fx- ($fx+ 255 ($fxsra c 8)) ($bignum-byte-ref n ni))]
[xj ($fxsub1 xj)])
@ -799,7 +799,7 @@
;;; last byte was positive
(bv-zero! x xi xj)]
[else
(error who "number ~s does not fit" n)])]
(error 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)
@ -814,7 +814,7 @@
;;; last byte was positive
(bv-zero! x xi xj)]
[else
(error who "number ~s does not fit" n)])]
(error who "number does not fit" n)])]
[else
(let ([c ($bignum-byte-ref n ni)]
[xj ($fxsub1 xj)])
@ -842,9 +842,9 @@
i))))
(define (make-bytevector-uint-set! who)
(lambda (x k n endianness size)
(unless (bytevector? x) (error who "~s is not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (error who "invalid index ~s" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" 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))
(case endianness
[(little)
(cond
@ -858,9 +858,9 @@
[($fx< sz size)
(lbn-copy! x k n 0 sz)
(bv-zero! x ($fx+ k sz) ($fx+ k size))]
[else (error who "number ~s does not fit" n)]))
(error who "value ~s must be positive" n))]
[else (error who "invalid value argument ~s" n)])]
[else (error who "number does not fit" n)]))
(error who "value must be positive" n))]
[else (error who "invalid value argument" n)])]
[(big)
(cond
[(fixnum? n) (bufx-set! x k n ($fx+ k size) who n)]
@ -873,10 +873,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 ~s does not fit" n)]))
(error who "value ~s must be positive" n))]
[else (error who "invalid value argument ~s" n)])]
[else (error who "invalid endianness ~s" endianness)])))
[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)])))
(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))
@ -884,9 +884,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 "~s is not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (error who "invalid index ~s" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" 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))
(case endianness
[(little)
(cond
@ -897,13 +897,13 @@
(cond
[($fx<= sz size)
(lbn-pos-copy! x k n 0 size sz 255)]
[else (error who "number ~s does not fit" n)]))
[else (error 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 ~s does not fit" n)])))]
[else (error who "invalid value argument ~s" n)])]
[else (error who "number does not fit" n)])))]
[else (error who "invalid value argument" n)])]
[(big)
(cond
[(fixnum? n) (bsfx-set! x k n ($fx+ k size) who n)]
@ -913,14 +913,14 @@
(cond
[($fx<= sz size)
(bbn-pos-copy! x k n 0 size sz 255)]
[else (error who "number ~s does not fit" n)]))
[else (error 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 ~s does not fit" n)])))]
[else (error who "invalid value argument ~s" n)])]
[else (error who "invalid endianness ~s" endianness)])))
[else (error who "number does not fit" n)])))]
[else (error who "invalid value argument" n)])]
[else (error who "invalid endianness" endianness)])))
(define bytevector-sint-set! (make-bytevector-sint-set! 'bytevector-sint-set!)))
(module (uint-list->bytevector sint-list->bytevector)
@ -936,15 +936,15 @@
(bv-set! bv idx a endianness size)
(bv-set! bv ($fx+ idx size) ($car h) endianness size)
bv)
(error who "circular list ~s" ls))
(error who "circular list" ls))
(if (null? h)
(let ([bv (make-bytevector ($fx+ idx size))])
(bv-set! bv idx a endianness size)
bv)
(error who "~s is not a proper list" ls))))
(error who "not a proper list" ls))))
(if (null? h)
(make-bytevector idx)
(error who "~s is not a proper list" ls))))
(error who "not a proper list" ls))))
(lambda (ls endianness size)
(race ls ls ls 0 endianness size)))
(define uint-list->bytevector

2
scheme/ikarus.cafe.ss
View File

@ -97,7 +97,7 @@ description:
[() (do-new-cafe default-cafe-eval)]
[(p)
(unless (procedure? p)
(error 'new-cafe "~s is not a procedure" p))
(error 'new-cafe "not a procedure" p))
(do-new-cafe p)]))
)

20
scheme/ikarus.chars.ss
View File

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

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

@ -16,75 +16,75 @@
(define make-code
(lambda (code-size freevars)
(unless (and (fixnum? code-size) ($fx>= code-size 0))
(error 'make-code "~s is not a valid code size" code-size))
(error 'make-code "not a valid code size" code-size))
(unless (and (fixnum? freevars) ($fx>= freevars 0))
(error 'make-code "~s is not a valid number of free vars" freevars))
(error '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 "~s is not a code" x))
(unless (code? x) (error 'code-reloc-vector "not a code" x))
($code-reloc-vector x)))
(define code-freevars
(lambda (x)
(unless (code? x) (error 'code-closure-size "~s is not a code" x))
(unless (code? x) (error 'code-closure-size "not a code" x))
($code-freevars x)))
(define code-size
(lambda (x)
(unless (code? x) (error 'code-size "~s is not a code" x))
(unless (code? x) (error 'code-size "not a code" x))
($code-size x)))
(define code-set!
(lambda (x i v)
(unless (code? x) (error 'code-set! "~s is not a code" x))
(unless (code? x) (error 'code-set! "not a code" x))
(unless (and (fixnum? i)
($fx>= i 0)
($fx< i ($code-size x)))
(error 'code-set! "~s is not a valid index" i))
(error 'code-set! "not a valid index" i))
(unless (and (fixnum? v)
($fx>= v 0)
($fx< v 256))
(error 'code-set! "~s is not a valid byte" v))
(error 'code-set! "not a valid byte" v))
($code-set! x i v)))
(define code-ref
(lambda (x i)
(unless (code? x) (error 'code-ref "~s is not a code" x))
(unless (code? x) (error 'code-ref "not a code" x))
(unless (and (fixnum? i)
($fx>= i 0)
($fx< i ($code-size x)))
(error 'code-ref "~s is not a valid index" i))
(error '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! "~s is not a code" x))
(error 'set-code-reloc-vector! "not a code" x))
(unless (vector? v)
(error 'set-code-reloc-vector! "~s is not a vector" v))
(error '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! "~s is not a code" x))
(error '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 "~s is not a a code object" x))
(error 'code->thunk "not a a code object" x))
(unless ($fxzero? ($code-freevars x))
(error 'code->thunk "~s has free variables" x))
(error 'code->thunk "has free variables" x))
($code->closure x)))
(define (procedure-annotation x)
(if (procedure? x)
($code-annotation ($closure-code x))
(error 'procedure-annotation "~s is not a procedure" x)))
(error 'procedure-annotation "not a procedure" x)))
)

20
scheme/ikarus.codecs.ss
View File

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

202
scheme/ikarus.compiler.altcogen.ss
View File

@ -29,25 +29,25 @@
;;;
(define (check-gensym x)
(unless (gensym? x)
(error who "invalid gensym ~s" x)))
(error who "invalid gensym" x)))
;;;
(define (check-label x)
(struct-case x
[(code-loc label)
(check-gensym label)]
[else (error who "invalid label ~s" x)]))
[else (error who "invalid label" x)]))
;;;
(define (check-var x)
(struct-case x
[(var) (void)]
[else (error who "invalid var ~s" x)]))
[else (error who "invalid var" x)]))
;;;
(define (check-closure x)
(struct-case x
[(closure label free*)
(check-label label)
(for-each check-var free*)]
[else (error who "invalid closure ~s" x)]))
[else (error who "invalid closure" x)]))
;;;
(define (mkfuncall op arg*)
(import primops)
@ -81,25 +81,25 @@
(make-jmpcall label (Expr rator) (map Expr arg*))]
[(mvcall rator k)
(make-mvcall (Expr rator) (Clambda k))]
[else (error who "invalid expr ~s" x)]))
[else (error who "invalid expr" x)]))
;;;
(define (ClambdaCase x)
(struct-case x
[(clambda-case info body)
(make-clambda-case info (Expr body))]
[else (error who "invalid clambda-case ~s" x)]))
[else (error who "invalid clambda-case" x)]))
;;;
(define (Clambda x)
(struct-case x
[(clambda label case* free* name)
(make-clambda label (map ClambdaCase case*) free* name)]
[else (error who "invalid clambda ~s" x)]))
[else (error who "invalid clambda" x)]))
;;;
(define (Program x)
(struct-case x
[(codes code* body)
(make-codes (map Clambda code*) (Expr body))]
[else (error who "invalid program ~s" x)]))
[else (error who "invalid program" x)]))
;;;
(Program x))
@ -150,7 +150,7 @@
(make-jmpcall label (Expr rator) (map Expr arg*))]
[(mvcall rator k)
(make-mvcall (Expr rator) (Clambda k))]
[else (error who "invalid expr ~s" x)]))
[else (error who "invalid expr" x)]))
Expr)
;;;
(define (ClambdaCase free*)
@ -163,20 +163,20 @@
(make-clambda-case
(make-case-info label (cons cp args) proper)
((Expr cp free*) body)))])]
[else (error who "invalid clambda-case ~s" x)])))
[else (error who "invalid clambda-case" x)])))
;;;
(define (Clambda x)
(struct-case x
[(clambda label case* free* name)
(make-clambda label (map (ClambdaCase free*) case*)
free* name)]
[else (error who "invalid clambda ~s" x)]))
[else (error who "invalid clambda" x)]))
;;;
(define (Program x)
(struct-case x
[(codes code* body)
(make-codes (map Clambda code*) ((Expr #f '()) body))]
[else (error who "invalid program ~s" x)]))
[else (error who "invalid program" x)]))
;;;
(Program x))
@ -268,7 +268,7 @@
[(assq x '([%eax 0] [%edi 1] [%ebx 2] [%edx 3]
[%ecx 4] [%esi 5] [%esp 6] [%ebp 7]))
=> cadr]
[else (error 'register-index "~s is not a register" x)]))
[else (error 'register-index "not a register" x)]))
(define non-8bit-registers '(%edi))
@ -306,7 +306,7 @@
(let ([t (unique-var 'tmp)])
(do-bind (list t) (list x)
(k t)))]
[else (error who "invalid S ~s" x)])]))
[else (error who "invalid S" x)])]))
;;;
(define (do-bind lhs* rhs* body)
(cond
@ -452,7 +452,7 @@
(V d a)
(make-set ecx b)
(make-asm-instr op d ecx))))]))]
[else (error who "invalid value op ~s" op)])]
[else (error who "invalid value op" op)])]
[(funcall rator rands)
(handle-nontail-call rator rands d #f)]
[(jmpcall label rator rands)
@ -468,7 +468,7 @@
[else
(if (symbol? x)
(make-set d x)
(error who "invalid value ~s" (unparse x)))]))
(error who "invalid value" (unparse x)))]))
;;;
(define (assign* lhs* rhs* ac)
(cond
@ -506,7 +506,7 @@
(lambda (s*)
(make-asm-instr op (car s*) (cadr s*))))]
[(nop interrupt incr/zero?) x]
[else (error 'impose-effect "invalid instr ~s" x)])]
[else (error 'impose-effect "invalid instr" x)])]
[(funcall rator rands)
(handle-nontail-call rator rands #f #f)]
[(jmpcall label rator rands)
@ -517,7 +517,7 @@
rands #f op)]
[(shortcut body handler)
(make-shortcut (E body) (E handler))]
[else (error who "invalid effect ~s" x)]))
[else (error who "invalid effect" x)]))
;;; impose pred
(define (P x)
(struct-case x
@ -541,7 +541,7 @@
(make-asm-instr op a b))))]))]
[(shortcut body handler)
(make-shortcut (P body) (P handler))]
[else (error who "invalid pred ~s" x)]))
[else (error who "invalid pred" x)]))
;;;
(define (handle-tail-call target rator rands)
(let* ([args (cons rator rands)]
@ -624,7 +624,7 @@
[(forcall) (VT x)]
[(shortcut body handler)
(make-shortcut (Tail body) (Tail handler))]
[else (error who "invalid tail ~s" x)]))
[else (error who "invalid tail" x)]))
;;;
(define (formals-locations args)
(let f ([regs parameter-registers] [args args])
@ -707,21 +707,21 @@
(define (make-empty-set) (make-set '()))
(define (set-member? x s)
;(unless (fixnum? x) (error 'set-member? "~s is not a fixnum" x))
(unless (set? s) (error 'set-member? "~s is not a set" s))
;(unless (fixnum? x) (error 'set-member? "not a fixnum" x))
(unless (set? s) (error 'set-member? "not a set" s))
(memq x (set-v s)))
(define (empty-set? s)
(unless (set? s) (error 'empty-set? "~s is not a set" s))
(unless (set? s) (error 'empty-set? "not a set" s))
(null? (set-v s)))
(define (set->list s)
(unless (set? s) (error 'set->list "~s is not a set" s))
(unless (set? s) (error 'set->list "not a set" s))
(set-v s))
(define (set-add x s)
;(unless (fixnum? x) (error 'set-add "~s is not a fixnum" x))
(unless (set? s) (error 'set-add "~s is not a set" s))
;(unless (fixnum? x) (error 'set-add "not a fixnum" x))
(unless (set? s) (error 'set-add "not a set" s))
(cond
[(memq x (set-v s)) s]
[else (make-set (cons x (set-v s)))]))
@ -733,8 +733,8 @@
[else (cons (car s) (rem x (cdr s)))]))
(define (set-rem x s)
;(unless (fixnum? x) (error 'set-rem "~s is not a fixnum" x))
(unless (set? s) (error 'set-rem "~s is not a set" s))
;(unless (fixnum? x) (error 'set-rem "not a fixnum" x))
(unless (set? s) (error 'set-rem "not a set" s))
(make-set (rem x (set-v s))))
(define (difference s1 s2)
@ -743,17 +743,17 @@
[else (difference (rem (car s2) s1) (cdr s2))]))
(define (set-difference s1 s2)
(unless (set? s1) (error 'set-difference "~s is not a set" s1))
(unless (set? s2) (error 'set-difference "~s is not a set" s2))
(unless (set? s1) (error 'set-difference "not a set" s1))
(unless (set? s2) (error 'set-difference "not a set" s2))
(make-set (difference (set-v s1) (set-v s2))))
(define (set-union s1 s2)
(unless (set? s1) (error 'set-union "~s is not a set" s1))
(unless (set? s2) (error 'set-union "~s is not a set" s2))
(unless (set? s1) (error 'set-union "not a set" s1))
(unless (set? s2) (error 'set-union "not a set" s2))
(make-set (union (set-v s1) (set-v s2))))
(define (list->set ls)
;(unless (andmap fixnum? ls) (error 'set-rem "~s is not a list of fixnum" ls))
;(unless (andmap fixnum? ls) (error 'set-rem "not a list of fixnum" ls))
(make-set ls))
(define (union s1 s2)
@ -790,7 +790,7 @@
(define (empty-set? s) (eqv? s 0))
(define (set-member? n s)
(unless (fixnum? n) (error 'set-member? "~s is not a fixnum" n))
(unless (fixnum? n) (error 'set-member? "not a fixnum" n))
(let f ([s s] [i (index-of n)] [j (mask-of n)])
(cond
[(pair? s)
@ -801,7 +801,7 @@
[else #f])))
(define (set-add n s)
(unless (fixnum? n) (error 'set-add "~s is not a fixnum" n))
(unless (fixnum? n) (error 'set-add "not a fixnum" n))
(let f ([s s] [i (index-of n)] [j (mask-of n)])
(cond
[(pair? s)
@ -824,7 +824,7 @@
(cons a d)))
(define (set-rem n s)
(unless (fixnum? n) (error 'set-rem "~s is not a fixnum" n))
(unless (fixnum? n) (error 'set-rem "not a fixnum" n))
(let f ([s s] [i (index-of n)] [j (mask-of n)])
(cond
[(pair? s)
@ -888,7 +888,7 @@
(fxlogand s1 (fxlognot s2)))))
(define (list->set ls)
(unless (andmap fixnum? ls) (error 'list->set "~s is not a list of fixnum" ls))
(unless (andmap fixnum? ls) (error 'list->set "not a list of fixnum" ls))
(let f ([ls ls] [s 0])
(cond
[(null? ls) s]
@ -1254,7 +1254,7 @@
[(disp? x)
(let-values ([(vs rs fs ns) (R (disp-s0 x) vs rs fs ns)])
(R (disp-s1 x) vs rs fs ns))]
[else (error who "invalid R ~s" x)]))
[else (error who "invalid R" x)]))
(define (R* ls vs rs fs ns)
(cond
[(null? ls) (values vs rs fs ns)]
@ -1299,7 +1299,7 @@
(let ([rs (rem-reg d rs)])
(mark-reg/vars-conf! d vs)
(values vs rs (add-frm s fs) ns))]
[else (error who "invalid rs ~s" (unparse x))])]
[else (error who "invalid rs" (unparse x))])]
[(fvar? d)
(cond
[(not (mem-frm? d fs))
@ -1317,7 +1317,7 @@
(mark-frm/vars-conf! d vs)
(mark-frm/nfvs-conf! d ns)
(values (add-var s vs) rs fs ns))]
[else (error who "invalid fs ~s" s)])]
[else (error who "invalid fs" s)])]
[(var? d)
(cond
[(not (mem-var? d vs))
@ -1356,7 +1356,7 @@
(mark-var/regs-conf! d rs)
(mark-var/nfvs-conf! d ns)
(values vs rs (add-frm s fs) ns))]
[else (error who "invalid vs ~s" s)])]
[else (error who "invalid vs" s)])]
[(nfv? d)
(cond
[(not (mem-nfv? d ns)) (error who "dead nfv")]
@ -1377,12 +1377,12 @@
(mark-nfv/vars-conf! d vs)
(mark-nfv/frms-conf! d fs)
(values vs rs (add-frm s fs) ns))]
[else (error who "invalid ns ~s" s)])]
[else (error who "invalid d ~s" d)])]
[else (error who "invalid ns" s)])]
[else (error who "invalid d" d)])]
[(int-/overflow int+/overflow int*/overflow)
(let ([v (exception-live-set)])
(unless (vector? v)
(error who "unbound exception for ~s ~s" x v))
(error who "unbound exception" x v))
(let ([vs (union-vars vs (vector-ref v 0))]
[rs (union-regs rs (vector-ref v 1))]
[fs (union-frms fs (vector-ref v 2))]
@ -1416,7 +1416,7 @@
(mark-nfv/vars-conf! d vs)
(mark-nfv/frms-conf! d fs)
(R s vs rs fs (add-nfv d ns)))])]
[else (error who "invalid op d ~s" (unparse x))])))]
[else (error who "invalid op d" (unparse x))])))]
[(logand logor logxor sll sra srl int+ int- int*)
(cond
[(var? d)
@ -1447,7 +1447,7 @@
(mark-nfv/vars-conf! d vs)
(mark-nfv/frms-conf! d fs)
(R s vs rs fs (add-nfv d ns)))])]
[else (error who "invalid op d ~s" (unparse x))])]
[else (error who "invalid op d" (unparse x))])]
[(idiv)
(mark-reg/vars-conf! eax vs)
(mark-reg/vars-conf! edx vs)
@ -1458,7 +1458,7 @@
[(mset bset/c bset/h fl:load fl:store fl:add! fl:sub!
fl:mul! fl:div! fl:from-int)
(R* (list s d) vs rs fs ns)]
[else (error who "invalid effect op ~s" (unparse x))])]
[else (error who "invalid effect op" (unparse x))])]
[(ntcall target value args mask size)
(set! spill-set (union-vars vs spill-set))
(for-each-var vs varvec (lambda (x) (set-var-loc! x #t)))
@ -1478,13 +1478,13 @@
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)))]
[else (error who "invalid effect op ~s" op)])]
[else (error who "invalid effect op" op)])]
[(shortcut body handler)
(let-values ([(vsh rsh fsh nsh) (E handler vs rs fs ns)])
(parameterize ([exception-live-set
(vector vsh rsh fsh nsh)])
(E body vs rs fs ns)))]
[else (error who "invalid effect ~s" (unparse x))]))
[else (error who "invalid effect" (unparse x))]))
(define (P x vst rst fst nst
vsf rsf fsf nsf
vsu rsu fsu nsu)
@ -1527,7 +1527,7 @@
(P body vst rst fst nst
vsf rsf fsf nsf
vsu rsu fsu nsu)))]
[else (error who "invalid pred ~s" (unparse x))]))
[else (error who "invalid pred" (unparse x))]))
(define (T x)
(struct-case x
[(seq e0 e1)
@ -1550,13 +1550,13 @@
(empty-reg-set)
(empty-frm-set)
(empty-nfv-set))]
[else (error who "invalid tail op ~s" x)])]
[else (error who "invalid tail op" x)])]
[(shortcut body handler)
(let-values ([(vsh rsh fsh nsh) (T handler)])
(parameterize ([exception-live-set
(vector vsh rsh fsh nsh)])
(T body)))]
[else (error who "invalid tail ~s" x)]))
[else (error who "invalid tail" x)]))
(define exception-live-set
(make-parameter #f))
(T x)
@ -1622,7 +1622,7 @@
[else (error who "invalid arg")]))
args)
mask idx)]
[else (error who "invalid NF effect ~s" x)]))
[else (error who "invalid NF effect" x)]))
(define (Var x)
(cond
[(var-loc x) =>
@ -1640,7 +1640,7 @@
[(var? x) (Var x)]
[(disp? x)
(make-disp (R (disp-s0 x)) (R (disp-s1 x)))]
[else (error who "invalid R ~s" (unparse x))]))
[else (error who "invalid R" (unparse x))]))
(define (E x)
(struct-case x
[(seq e0 e1)
@ -1664,7 +1664,7 @@
fl:from-int)
(make-asm-instr op (R d) (R s))]
[(nop) (make-primcall 'nop '())]
[else (error who "invalid op ~s" op)])]
[else (error who "invalid op" op)])]
[(nframe vars live body)
(let ([live-frms1
(map (lambda (i) (Var (vector-ref varvec i)))
@ -1762,10 +1762,10 @@
[(primcall op args)
(case op
[(nop interrupt incr/zero?) x]
[else (error who "invalid effect prim ~s" op)])]
[else (error who "invalid effect prim" op)])]
[(shortcut body handler)
(make-shortcut (E body) (E handler))]
[else (error who "invalid effect ~s" (unparse x))]))
[else (error who "invalid effect" (unparse x))]))
(define (P x)
(struct-case x
[(seq e0 e1)
@ -1777,7 +1777,7 @@
[(constant) x]
[(shortcut body handler)
(make-shortcut (P body) (P handler))]
[else (error who "invalid pred ~s" (unparse x))]))
[else (error who "invalid pred" (unparse x))]))
(define (T x)
(struct-case x
[(seq e0 e1)
@ -1788,7 +1788,7 @@
[(primcall op args) x]
[(shortcut body handler)
(make-shortcut (T body) (T handler))]
[else (error who "invalid tail ~s" (unparse x))]))
[else (error who "invalid tail" (unparse x))]))
(T x))
;;;
(define (Main x)
@ -1806,7 +1806,7 @@
[(var-loc (car vars)) (f (cdr vars))]
[else (cons (car vars) (f (cdr vars)))])))
body))))]
[else (error 'assign-frame-sizes "invalid main ~s" x)]))
[else (error 'assign-frame-sizes "invalid main" x)]))
;;;
(define (ClambdaCase x)
(struct-case x
@ -1859,7 +1859,7 @@
(if (memq x all-registers)
(set-add x (make-empty-set))
(make-empty-set))]
[else (error who "invalid R ~s" x)])]))
[else (error who "invalid R" x)])]))
;;; build effect
(define (E x s)
(struct-case x
@ -1910,7 +1910,7 @@
[(mset fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
fl:from-int)
(set-union (R v) (set-union (R d) s))]
[else (error who "invalid effect ~s" x)])]
[else (error who "invalid effect" x)])]
[(seq e0 e1) (E e0 (E e1 s))]
[(conditional e0 e1 e2)
(let ([s1 (E e1 s)] [s2 (E e2 s)])
@ -1922,12 +1922,12 @@
[(nop) s]
[(interrupt incr/zero?)
(or (exception-live-set) (error who "uninitialized exception"))]
[else (error who "invalid effect primcall ~s" op)])]
[else (error who "invalid effect primcall" op)])]
[(shortcut body handler)
(let ([s2 (E handler s)])
(parameterize ([exception-live-set s2])
(E body s)))]
[else (error who "invalid effect ~s" (unparse x))]))
[else (error who "invalid effect" (unparse x))]))
(define (P x st sf su)
(struct-case x
[(constant c) (if c st sf)]
@ -1942,7 +1942,7 @@
(let ([s2 (P handler st sf su)])
(parameterize ([exception-live-set s2])
(P body st sf su)))]
[else (error who "invalid pred ~s" (unparse x))]))
[else (error who "invalid pred" (unparse x))]))
(define (T x)
(struct-case x
[(conditional e0 e1 e2)
@ -1955,7 +1955,7 @@
(let ([s2 (T handler)])
(parameterize ([exception-live-set s2])
(T body)))]
[else (error who "invalid tail ~s" (unparse x))]))
[else (error who "invalid tail" (unparse x))]))
(define exception-live-set (make-parameter #f))
(let ([s (T x)])
;(pretty-print (unparse x))
@ -1986,7 +1986,7 @@
(car r*)))))
(define (find-color x confs env)
(or (find-color/maybe x confs env)
(error 'find-color "cannot find color for ~s" x)))
(error 'find-color "cannot find color for" x)))
(cond
[(and (empty-set? sp*) (empty-set? un*))
(values '() (make-empty-set) '())]
@ -2041,7 +2041,7 @@
(struct-case x
[(var) (Var x)]
[(nfv confs loc)
(or loc (error who "LHS not set ~s" x))]
(or loc (error who "LHS not set" x))]
[else x]))
(define (D x)
(struct-case x
@ -2049,17 +2049,17 @@
[(var) (Var x)]
[(fvar) x]
[else
(if (symbol? x) x (error who "invalid D ~s" x))]))
(if (symbol? x) x (error who "invalid D" x))]))
(define (R x)
(struct-case x
[(constant) x]
[(var) (Var x)]
[(fvar) x]
[(nfv c loc)
(or loc (error who "unset nfv ~s in R" x))]
(or loc (error who "unset nfv in R" x))]
[(disp s0 s1) (make-disp (D s0) (D s1))]
[else
(if (symbol? x) x (error who "invalid R ~s" x))]))
(if (symbol? x) x (error who "invalid R" x))]))
;;; substitute effect
(define (E x)
(struct-case x
@ -2073,7 +2073,7 @@
[(ntcall) x]
[(shortcut body handler)
(make-shortcut (E body) (E handler))]
[else (error who "invalid effect ~s" (unparse x))]))
[else (error who "invalid effect" (unparse x))]))
(define (P x)
(struct-case x
[(constant) x]
@ -2084,7 +2084,7 @@
[(seq e0 e1) (make-seq (E e0) (P e1))]
[(shortcut body handler)
(make-shortcut (P body) (P handler))]
[else (error who "invalid pred ~s" (unparse x))]))
[else (error who "invalid pred" (unparse x))]))
(define (T x)
(struct-case x
[(primcall op rands) x]
@ -2093,7 +2093,7 @@
[(seq e0 e1) (make-seq (E e0) (T e1))]
[(shortcut body handler)
(make-shortcut (T body) (T handler))]
[else (error who "invalid tail ~s" (unparse x))]))
[else (error who "invalid tail" (unparse x))]))
;(print-code x)
(T x))
;;;
@ -2195,12 +2195,12 @@
(error who "invalid arg to idiv"))
(cond
[(disp? b)
(error who "invalid arg to idiv ~s" b)]
(error who "invalid arg to idiv" b)]
[else x])]
[(sll sra srl)
(unless (or (constant? b)
(eq? b ecx))
(error who "invalid shift ~s" b))
(error who "invalid shift" b))
x]
[(mset bset/c bset/h)
(cond
@ -2241,16 +2241,16 @@
(E (make-asm-instr op u b))))]
[else x])]
[(fl:from-int) x]
[else (error who "invalid effect ~s" op)])]
[else (error who "invalid effect" op)])]
[(primcall op rands)
(case op
[(nop interrupt incr/zero?) x]
[else (error who "invalid op in ~s" (unparse x))])]
[else (error who "invalid op in" (unparse x))])]
[(ntcall) x]
[(shortcut body handler)
(let ([body (E body)])
(make-shortcut body (E handler)))]
[else (error who "invalid effect ~s" (unparse x))]))
[else (error who "invalid effect" (unparse x))]))
(define (P x)
(struct-case x
[(constant) x]
@ -2284,7 +2284,7 @@
[(shortcut body handler)
(let ([body (P body)])
(make-shortcut body (P handler)))]
[else (error who "invalid pred ~s" (unparse x))]))
[else (error who "invalid pred" (unparse x))]))
(define (T x)
(struct-case x
[(primcall op rands) x]
@ -2293,7 +2293,7 @@
[(seq e0 e1) (make-seq (E e0) (T e1))]
[(shortcut body handler)
(make-shortcut (T body) (T handler))]
[else (error who "invalid tail ~s" (unparse x))]))
[else (error who "invalid tail" (unparse x))]))
(let ([x (T x)])
(values un* x)))
;;;
@ -2355,19 +2355,19 @@
[else
(if (integer? x)
x
(error who "invalid constant C ~s" x))]))
(error who "invalid constant C" x))]))
(define (BYTE x)
(struct-case x
[(constant x)
(unless (and (integer? x) (fx<= x 255) (fx<= -128 x))
(error who "invalid byte ~s" x))
(error who "invalid byte" x))
x]
[else (error who "invalid byte ~s" x)]))
[else (error who "invalid byte" x)]))
(define (D x)
(struct-case x
[(constant c) (C c)]
[else
(if (symbol? x) x (error who "invalid D ~s" x))]))
(if (symbol? x) x (error who "invalid D" x))]))
(define (R x)
(struct-case x
[(constant c) (C c)]
@ -2376,7 +2376,7 @@
(let ([s0 (D s0)] [s1 (D s1)])
`(disp ,s0 ,s1))]
[else
(if (symbol? x) x (error who "invalid R ~s" x))]))
(if (symbol? x) x (error who "invalid R" x))]))
(define (R/l x)
(struct-case x
[(constant c) (C c)]
@ -2385,27 +2385,27 @@
(let ([s0 (D s0)] [s1 (D s1)])
`(disp ,s0 ,s1))]
[else
(if (symbol? x) (reg/l x) (error who "invalid R/l ~s" x))]))
(if (symbol? x) (reg/l x) (error who "invalid R/l" x))]))
(define (reg/h x)
(cond
[(assq x '([%eax %ah] [%ebx %bh] [%ecx %ch] [%edx %dh]))
=> cadr]
[else (error who "invalid reg/h ~s" x)]))
[else (error who "invalid reg/h" x)]))
(define (reg/l x)
(cond
[(assq x '([%eax %al] [%ebx %bl] [%ecx %cl] [%edx %dl]))
=> cadr]
[else (error who "invalid reg/l ~s" x)]))
[else (error who "invalid reg/l" x)]))
(define (R/cl x)
(struct-case x
[(constant i)
(unless (fixnum? i)
(error who "invalid R/cl ~s" x))
(error who "invalid R/cl" x))
(fxlogand i 31)]
[else
(if (eq? x ecx)
'%cl
(error who "invalid R/cl ~s" x))]))
(error who "invalid R/cl" x))]))
(define (interrupt? x)
(struct-case x
[(primcall op args) (eq? op 'interrupt)]
@ -2532,7 +2532,7 @@
(cons `(mulsd ,(R (make-disp s d)) xmm0) ac)]
[(fl:div!)
(cons `(divsd ,(R (make-disp s d)) xmm0) ac)]
[else (error who "invalid instr ~s" x)])]
[else (error who "invalid instr" x)])]
[(primcall op rands)
(case op
[(nop) ac]
@ -2547,7 +2547,7 @@
`(addl 1 ,(R (make-disp (car rands) (cadr rands))))
`(je ,l)
ac))]
[else (error who "invalid effect ~s" (unparse x))])]
[else (error who "invalid effect" (unparse x))])]
[(shortcut body handler)
(let ([L (unique-interrupt-label)] [L2 (unique-label)])
(let ([hand (cons L (E handler `((jmp ,L2))))])
@ -2560,7 +2560,7 @@
; (let ([ac (cons L (E handler (cons L2 ac)))])
; (parameterize ([exception-label L])
; (E body (cons `(jmp ,L2) ac)))))]
[else (error who "invalid effect ~s" (unparse x))]))
[else (error who "invalid effect" (unparse x))]))
;;;
(define (unique-interrupt-label)
(label (gensym "ERROR")))
@ -2609,7 +2609,7 @@
[fl:> fl:o<=] [fl:>= fl:o<]
))
=> cadr]
[else (error who "invalid notop ~s" x)]))
[else (error who "invalid notop" x)]))
(define (jmpname x)
(cond
[(assq x '([= je] [!= jne] [< jl] [<= jle] [> jg] [>= jge]
@ -2620,13 +2620,13 @@
[fl:o< jb] [fl:o> ja] [fl:o<= jbe] [fl:o>= jae]
))
=> cadr]
[else (error who "invalid jmpname ~s" x)]))
[else (error who "invalid jmpname" x)]))
(define (revjmpname x)
(cond
[(assq x '([= je] [!= jne] [< jg] [<= jge] [> jl] [>= jle]
[u< ja] [u<= jae] [u> jb] [u>= jbe]))
=> cadr]
[else (error who "invalid jmpname ~s" x)]))
[else (error who "invalid jmpname" x)]))
(define (cmp op a0 a1 lab ac)
(cond
[(memq op '(fl:= fl:!= fl:< fl:<= fl:> fl:>=))
@ -2647,7 +2647,7 @@
(cons* `(cmpl ,(R a0) ,(R a1))
`(,(revjmpname op) ,lab)
ac)]
[else (error who "invalid cmpops ~s ~s" a0 a1)]))
[else (error who "invalid cmpops" a0 a1)]))
(cond
[(and lt lf)
(cmp op a0 a1 lt
@ -2665,7 +2665,7 @@
(set-cdr! tc (append hand (cdr tc)))))
(parameterize ([exception-label L])
(P body lt lf ac))))]
[else (error who "invalid pred ~s" x)]))
[else (error who "invalid pred" x)]))
;;;
(define (T x ac)
(struct-case x
@ -2681,7 +2681,7 @@
ac)]
[(direct-jump)
(cons `(jmp (label ,(code-loc-label (car rands)))) ac)]
[else (error who "invalid tail ~s" x)])]
[else (error who "invalid tail" x)])]
[(shortcut body handler)
(let ([L (unique-interrupt-label)])
(let ([hand (cons L (T handler '()))])
@ -2689,7 +2689,7 @@
(set-cdr! tc (append hand (cdr tc)))))
(parameterize ([exception-label L])
(T body ac)))]
[else (error who "invalid tail ~s" x)]))
[else (error who "invalid tail" x)]))
(define exception-label (make-parameter #f))
;;;
(define (handle-vararg fml-count ac)

67
scheme/ikarus.compiler.ss
View File

@ -27,7 +27,7 @@
#'(i . i*))]))
(define (generate-body ctxt cls*)
(syntax-case cls* (else)
[() (with-syntax ([x x]) #'(error #f "unmatched ~s in ~s" v 'x))]
[() (with-syntax ([x x]) #'(error #f "unmatched " v 'x))]
[([else b b* ...]) #'(begin b b* ...)]
[([(rec-name rec-field* ...) b b* ...] . rest) (identifier? #'rec-name)
(with-syntax ([altern (generate-body ctxt #'rest)]
@ -144,7 +144,7 @@
(let ([fv (make-fvar i)])
(set! cache (cons (cons i fv) cache))
fv)])]
[else (error 'mkfvar "~s is not a fixnum" i)]))))
[else (error 'mkfvar "not a fixnum" i)]))))
(define (unique-var x)
(make-var (gensym x) #f #f #f #f #f #f #f #f #f #f))
@ -181,17 +181,17 @@
(eq? 'quote (car x))
(symbol? (cadr x)))
(cadr x)
(error 'quoted-sym "not a quoted symbol ~s" x)))
(error 'quoted-sym "not a quoted symbol" x)))
(define (quoted-string x)
(if (and (list? x)
(fx= (length x) 2)
(eq? 'quote (car x))
(string? (cadr x)))
(cadr x)
(error 'quoted-string "not a quoted string ~s" x)))
(error 'quoted-string "not a quoted string" x)))
(define (Var x)
(or (getprop x *cookie*)
(error 'recordize "unbound ~s" x)))
(error 'recordize "unbound" x)))
(define (lexical x)
(getprop x *cookie*))
(define (get-fmls x args)
@ -292,7 +292,7 @@
(make-funcall
(make-primref 'top-level-value)
(list (make-constant x))))]
[else (error 'recordize "invalid expression ~s" x)]))
[else (error 'recordize "invalid expression" x)]))
(E x #f))
(define (unparse x)
@ -454,8 +454,6 @@
[(conditional) #f]
[(bind lhs* rhs* body) (valid-mv-producer? body)]
[else #f] ;; FIXME BUG
; [else (error 'valid-mv-producer? "unhandles ~s"
; (unparse x))]
))
(struct-case rator
[(clambda g cls*)
@ -514,7 +512,7 @@
(make-forcall rator (map Expr rand*))]
[(assign lhs rhs)
(make-assign lhs (Expr rhs))]
[else (error who "invalid expression ~s" (unparse x))]))
[else (error who "invalid expression" (unparse x))]))
(Expr x))
@ -673,8 +671,8 @@
(make-mvcall p c))]
[(forcall rator rand*)
(make-forcall rator (E* rand* ref comp))]
[else (error who "invalid expression ~s" (unparse x))]))
(E x (lambda (x) (error who "free var ~s found" x))
[else (error who "invalid expression" (unparse x))]))
(E x (lambda (x) (error who "free var found" x))
void))
@ -718,7 +716,7 @@
[(assign lhs rhs)
(set-var-assigned! lhs #t)
(Expr rhs)]
[else (error who "invalid expression ~s" (unparse x))]))
[else (error who "invalid expression" (unparse x))]))
(Expr x)
x)
@ -937,7 +935,8 @@
(make-funcall (make-primref op)
(list a0 (make-constant n1))))))
(make-funcall (make-primref op) rand*))])))
(error 'optimize "~s rands to ~s" (map unparse rand*) op))]
(error 'optimize "invalid operands to primitive"
(map unparse rand*) op))]
[(void)
(or (and (null? rand*)
(case ctxt
@ -1009,7 +1008,7 @@
"incorrect arg ~s to ~s"
v op))))
(giveup))))
(error 'optimize "incorrect args ~s to ~s"
(error 'optimize "incorrect args to primitive"
(map unparse rand*) op))]
[(fxadd1 fxsub1)
(or (and (fx= (length rand*) 1)
@ -1088,7 +1087,7 @@
(make-seq e0 (mk-mvcall e1 c))]
[(bind lhs* rhs* body)
(make-bind lhs* rhs* (mk-mvcall body c))]
[else (error 'mk-mvcall "invalid producer ~s" (unparse p))]))
[else (error 'mk-mvcall "invalid producer" (unparse p))]))
(define (copy-propagate x)
@ -1230,11 +1229,11 @@
(mk-mvcall (Value p) (Value c))]
[(assign lhs rhs)
(unless (var-assigned lhs)
(error who "var ~s is not assigned" lhs))
(error who "var is not assigned" lhs))
(if (var-referenced lhs)
(make-assign lhs (Value rhs))
(Effect rhs))]
[else (error who "invalid effect expression ~s" (unparse x))]))
[else (error who "invalid effect expression" (unparse x))]))
(define (Pred x)
(struct-case x
[(constant) x]
@ -1288,7 +1287,7 @@
(mk-seq (Effect x) (make-constant #t))]
[(mvcall p c)
(mk-mvcall (Value p) (Value c))]
[else (error who "invalid pred expression ~s" (unparse x))]))
[else (error who "invalid pred expression" (unparse x))]))
(define (Value x)
(struct-case x
[(constant) x]
@ -1296,7 +1295,7 @@
(let ([r (var-referenced x)])
(case r
[(#t) x]
[(#f) (error who "Reference to a var ~s that should not be" x)]
[(#f) (error who "Reference to a var that should not be" x)]
[else r]))]
[(primref) x]
[(bind lhs* rhs* body)
@ -1340,7 +1339,7 @@
(mk-seq (Effect x) the-void)]
[(mvcall p c)
(mk-mvcall (Value p) (Value c))]
[else (error who "invalid value expression ~s" (unparse x))]))
[else (error who "invalid value expression" (unparse x))]))
(let ([x (Value x)])
;;; since we messed up the references and assignments here, we
;;; redo them
@ -1405,11 +1404,11 @@
(make-funcall (Expr rator) (map Expr rand*))]
[(assign lhs rhs)
(unless (var-assigned lhs)
(error 'rewrite-assignments "not assigned ~s in ~s" lhs x))
(error 'rewrite-assignments "not assigned" lhs x))
(make-funcall (make-primref '$vector-set!)
(list lhs (make-constant 0) (Expr rhs)))]
[(mvcall p c) (make-mvcall (Expr p) (Expr c))]
[else (error who "invalid expression ~s" (unparse x))]))
[else (error who "invalid expression" (unparse x))]))
(Expr x))
@ -1499,7 +1498,7 @@
[else
(make-funcall rator (map Expr rand*))]))]
[(mvcall p c) (make-mvcall (Expr p) (Expr c))]
[else (error who "invalid expression ~s" (unparse x))]))
[else (error who "invalid expression" (unparse x))]))
(Expr x))
@ -1586,12 +1585,12 @@
[(closure code free^)
(values (make-mvcall p code)
(union p-free c-free))]
[else (error who "invalid mvcall consumer ~s"
[else (error who "invalid mvcall consumer"
(unparse c))]))]
[else (error who "invalid expression ~s" (unparse ex))]))
[else (error who "invalid expression" (unparse ex))]))
(let-values ([(prog free) (Expr prog)])
(unless (null? free)
(error 'convert-closures "free vars ~s encountered in ~a"
(error 'convert-closures "free vars encountered in program"
free (unparse prog)))
prog))
@ -1741,7 +1740,7 @@
(make-clambda-case info (E body))]))
cases)
free name))])]
[else (error who "invalid expression ~s" (unparse x))]))
[else (error who "invalid expression" (unparse x))]))
(let ([x (E x)])
(make-codes all-codes x)))
@ -1944,7 +1943,7 @@
(cond
[(fixnum? off) (list 'disp (int off) val)]
[(register? off) (list 'disp off val)]
[else (error 'mem "invalid disp ~s" off)]))
[else (error 'mem "invalid disp" off)]))
(define-syntax int
(syntax-rules ()
[(_ x) x]))
@ -2027,20 +2026,20 @@
[(engine-counter) (mem 36 pcr)]
[(interrupted) (mem 40 pcr)]
[(base-rtd) (mem 44 pcr)]
[else (error 'pcb-ref "invalid arg ~s" x)])))
[else (error 'pcb-ref "invalid arg" x)])))
(define (primref->symbol op)
(unless (symbol? op) (error 'primref->symbol "not a symbol ~s" op))
(unless (symbol? op) (error 'primref->symbol "not a symbol" op))
(cond
[((current-primitive-locations) op) =>
(lambda (x)
(unless (symbol? x)
(error 'primitive-location
"~s is not a valid location for ~s" x op))
"not a valid location for ~s" x op))
x)]
[else
(error #f "~s is not supported yet" op)]))
(error #f "not supported yet" op)]))
(define (primref-loc op)
(mem (fx- disp-symbol-record-proc record-tag)
@ -2395,7 +2394,7 @@
(if (closure? x)
(if (null? (closure-free* x))
(code-loc-label (closure-code x))
(error 'compile "BUG: non-thunk escaped: ~s" x))
(error 'compile "BUG: non-thunk escaped" x))
#f))
ls*)])
(car code*)))))
@ -2426,7 +2425,7 @@
(begin
(set! plocs p)
(refresh-cached-labels!))
(error 'current-primitive-locations "~s is not a procedure" p))])))
(error 'current-primitive-locations "not a procedure" p))])))
)

22
scheme/ikarus.conditions.ss
View File

@ -132,7 +132,7 @@
[(x)
(if (condition? x)
x
(error 'condition "~s is not a condition type" x))]
(error 'condition "not a condition type" x))]
[x*
(let ([ls
(let f ([x* x*])
@ -142,7 +142,7 @@
(cons (car x*) (f (cdr x*)))]
[(compound-condition? (car x*))
(append (simple-conditions (car x*)) (f (cdr x*)))]
[else (error 'condition "~s is not a condition" (car x*))]))])
[else (error 'condition "not a condition" (car x*))]))])
(cond
[(null? ls) (make-compound-condition '())]
[(null? (cdr ls)) (car ls)]
@ -152,13 +152,13 @@
(cond
[(compound-condition? x) (compound-condition-components x)]
[(&condition? x) (list x)]
[else (error 'simple-conditions "~s is not a condition" x)]))
[else (error 'simple-conditions "not a condition" x)]))
(define (condition-predicate rtd)
(unless (rtd? rtd)
(error 'condition-predicate "~s is not a record type descriptor" rtd))
(error 'condition-predicate "not a record type descriptor" rtd))
(unless (rtd-subtype? rtd (record-type-descriptor &condition))
(error 'condition-predicate "~s is not a descendant of &condition" rtd))
(error 'condition-predicate "not a descendant of &condition" rtd))
(let ([p? (record-predicate rtd)])
(lambda (x)
(or (p? x)
@ -170,11 +170,11 @@
(define (condition-accessor rtd proc)
(unless (rtd? rtd)
(error 'condition-accessor "~s is not a record type descriptor" rtd))
(error 'condition-accessor "not a record type descriptor" rtd))
(unless (procedure? proc)
(error 'condition-accessor "~s is not a procedure" proc))
(error 'condition-accessor "not a procedure" proc))
(unless (rtd-subtype? rtd (record-type-descriptor &condition))
(error 'condition-accessor "~s is not a descendant of &condition" rtd))
(error 'condition-accessor "not a descendant of &condition" rtd))
(let ([p? (record-predicate rtd)])
(lambda (x)
(cond
@ -187,9 +187,9 @@
(proc (car ls))
(f (cdr ls)))]
[else
(error 'condition-accessor "~s is not a condition of type ~s" x rtd)]))]
(error 'condition-accessor "not a condition of correct type" x rtd)]))]
[else
(error 'condition-accessor "~s is not a condition of type ~s" x rtd)]))))
(error 'condition-accessor "not a condition of correct type" x rtd)]))))
(define-syntax define-condition-type
(lambda (x)
@ -358,7 +358,7 @@
[(x port)
(if (output-port? port)
(print-condition x port)
(error 'print-condition "~s is not an output port" port))])))
(error 'print-condition "not an output port" port))])))
)

12
scheme/ikarus.control.ss
View File

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

7
scheme/ikarus.exceptions.ss
View File

@ -20,10 +20,9 @@
(define (with-exception-handler handler proc2)
(unless (procedure? handler)
(error 'with-exception-handler
"handler ~s is not a procedure" handler))
"handler is not a procedure" handler))
(unless (procedure? proc2)
(error 'with-exception-handler
"~s is not a procedure" proc2))
(error 'with-exception-handler "not a procedure" proc2))
(parameterize ([handlers (cons handler (handlers))])
(proc2)))
@ -45,7 +44,7 @@
(define (error who msg . irritants)
(unless (string? msg)
(error 'error "message ~s is not a string" msg))
(error 'error "message is not a string" msg))
(raise
(condition
(make-error)

15
scheme/ikarus.fasl.ss
View File

@ -48,7 +48,8 @@
(define who 'fasl-read)
(define (assert-eq? x y)
(unless (eq? x y)
(error who "Expected ~s, got ~s\n" y x)))
(error who
(format "Expected ~s, got ~s\n" y x))))
(define (char->int x)
(if (char? x)
(char->integer x)
@ -99,7 +100,7 @@
(cond
[(fx< m (vector-length marks))
(when (vector-ref marks m)
(error 'fasl-read "mark ~s set twice" m))
(error 'fasl-read "mark set twice" m))
(vector-set! marks m obj)]
[else
(let ([n (vector-length marks)])
@ -142,7 +143,7 @@
[(#\<)
(let ([cm (read-int p)])
(unless (fx< cm (vector-length marks))
(error who "invalid mark ~s\n" m))
(error who "invalid mark" m))
(let ([code (vector-ref marks cm)])
(let ([proc ($code->closure code)])
(when m (put-mark m proc))
@ -152,7 +153,7 @@
(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 ~s" c)])))
[else (error who "invalid code header" c)])))
(define (read/mark m)
(define (nom)
(when m (error who "unhandled mark")))
@ -244,10 +245,10 @@
[(#\<)
(let ([m (read-int p)])
(unless (fx< m (vector-length marks))
(error who "invalid mark ~s\n" m))
(error who "invalid mark" m))
(vector-ref marks m))]
[else
(error who "Unexpected ~s as a fasl object header" h)])))
(error who "Unexpected char as a fasl object header" h)])))
(read))
(define $fasl-read
(lambda (p)
@ -263,7 +264,7 @@
[(p)
(if (input-port? p)
($fasl-read p)
(error 'fasl-read "~s is not an input port" p))]))
(error 'fasl-read "not an input port" p))]))
)

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

@ -18,14 +18,14 @@
(define write-fixnum
(lambda (x p)
(unless (fixnum? x) (error 'write-fixnum "not a fixnum ~s" x))
(unless (fixnum? x) (error '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 ~s" x))
(unless (fixnum? x) (error '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)
@ -52,7 +52,7 @@
(write-char (if x #\T #\F) p)]
[(eof-object? x) (write-char #\E p)]
[(eq? x (void)) (write-char #\U p)]
[else (error 'fasl-write "~s is not a fasl-writable immediate" x)])))
[else (error 'fasl-write "not a fasl-writable immediate" x)])))
(define (ascii-string? s)
(let f ([s s] [i 0] [n (string-length s)])
@ -202,7 +202,7 @@
(write-byte ($bignum-byte-ref x i) p)
(f (fxadd1 i)))))
m]
[else (error 'fasl-write "~s is not fasl-writable" x)])))
[else (error '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)
@ -214,7 +214,7 @@
[(hashtable-ref h x #f) =>
(lambda (mark)
(unless (fixnum? mark)
(error 'fasl-write "BUG: invalid mark ~s" mark))
(error 'fasl-write "BUG: invalid mark" mark))
(cond
[(fx= mark 0) ; singly referenced
(do-write x p h m)]
@ -227,7 +227,7 @@
(write-char #\< p)
(write-int (fx- 0 mark) p)
m]))]
[else (error 'fasl-write "BUG: not in hash table ~s" x)])))
[else (error 'fasl-write "BUG: not in hash table" x)])))
(define make-graph
(lambda (x h)
(unless (immediate? x)
@ -275,7 +275,7 @@
(let ([code ($closure-code x)])
(unless (fxzero? (code-freevars code))
(error 'fasl-write
"Cannot write a non-thunk procedure; the one given has ~s free vars"
"Cannot write a non-thunk procedure; the one given has free vars"
(code-freevars code)))
(make-graph code h))]
[(bytevector? x) (void)]
@ -284,7 +284,7 @@
[(ratnum? x)
(make-graph (numerator x) h)
(make-graph (denominator x) h)]
[else (error 'fasl-write "~s is not fasl-writable" x)])]))))
[else (error 'fasl-write "not fasl-writable" x)])]))))
(define fasl-write-to-port
(lambda (x port)
(let ([h (make-eq-hashtable)])
@ -302,5 +302,5 @@
[(x) (fasl-write-to-port x (current-output-port))]
[(x port)
(unless (output-port? port)
(error 'fasl-write "~s is not an output port" port))
(error 'fasl-write "not an output port" port))
(fasl-write-to-port x port)])))

132
scheme/ikarus.fixnums.ss
View File

@ -35,39 +35,39 @@
(cond
[(eq? x 0) #t]
[(fixnum? x) #f]
[else (error 'fxzero? "~s is not a fixnum" x)])))
[else (error 'fxzero? "not a fixnum" x)])))
(define fxadd1
(lambda (n)
(if (fixnum? n)
($fxadd1 n)
(error 'fxadd1 "~s is not a fixnum" n))))
(error 'fxadd1 "not a fixnum" n))))
(define fxsub1
(lambda (n)
(if (fixnum? n)
($fxsub1 n)
(error 'fxsub1 "~s is not a fixnum" n))))
(error 'fxsub1 "not a fixnum" n))))
(define fxlognot
(lambda (x)
(unless (fixnum? x)
(error 'fxlognot "~s is not a fixnum" x))
(error 'fxlognot "not a fixnum" x))
($fxlognot x)))
(define fxnot
(lambda (x)
(unless (fixnum? x)
(error 'fxnot "~s is not a fixnum" x))
(error 'fxnot "not a fixnum" x))
($fxlognot x)))
(define error@fx+
(lambda (x y)
(if (fixnum? x)
(if (fixnum? y)
(error 'fx+ "overflow when adding ~s and ~s" x y)
(error 'fx+ "~s is not a fixnum" y))
(error 'fx+ "~s is not a fixnum" x))))
(error 'fx+ "overflow when adding numbers" x y)
(error 'fx+ "not a fixnum" y))
(error 'fx+ "not a fixnum" x))))
(define fx+
(lambda (x y)
@ -76,17 +76,17 @@
(define fx-
(lambda (x y)
(unless (fixnum? x)
(error 'fx- "~s is not a fixnum" x))
(error 'fx- "not a fixnum" x))
(unless (fixnum? y)
(error 'fx- "~s is not a fixnum" y))
(error 'fx- "not a fixnum" y))
($fx- x y)))
(define fx*
(lambda (x y)
(unless (fixnum? x)
(error 'fx* "~s is not a fixnum" x))
(error 'fx* "not a fixnum" x))
(unless (fixnum? y)
(error 'fx* "~s is not a fixnum" y))
(error 'fx* "not a fixnum" y))
($fx* x y)))
@ -95,7 +95,7 @@
(if (pair? ls)
(if (fixnum? ($car ls))
(false-loop who ($cdr ls))
(error who "~s is not a fixnum" ($car ls)))
(error who "not a fixnum" ($car ls)))
#f)))
(define-syntax fxcmp
@ -104,9 +104,9 @@
(case-lambda
[(x y)
(unless (fixnum? x)
(error 'who "~s is not a fixnum" x))
(error 'who "not a fixnum" x))
(unless (fixnum? y)
(error 'who "~s is not a fixnum" y))
(error 'who "not a fixnum" y))
($op x y)]
[(x y . ls)
(if (fixnum? x)
@ -119,13 +119,13 @@
(if ($op x y)
(f y ls)
(false-loop 'who ls))
(error 'who "~s is not a fixnum" y)))
(error 'who "not a fixnum" y)))
#t))
(false-loop 'who ls))
(error 'who "~s is not a fixnum" y))
(error 'who "~s is not a fixnum" x))]
(error 'who "not a fixnum" y))
(error 'who "not a fixnum" x))]
[(x)
(if (fixnum? x) #t (error 'who "~s is not a fixnum" x))])]))
(if (fixnum? x) #t (error 'who "not a fixnum" x))])]))
(define fx= (fxcmp fx= $fx=))
(define fx< (fxcmp fx< $fx<))
@ -142,32 +142,32 @@
(define fxquotient
(lambda (x y)
(unless (fixnum? x)
(error 'fxquotient "~s is not a fixnum" x))
(error 'fxquotient "not a fixnum" x))
(unless (fixnum? y)
(error 'fxquotient "~s is not a fixnum" y))
(error 'fxquotient "not a fixnum" y))
(when ($fxzero? y)
(error 'fxquotient "zero dividend ~s" y))
(error 'fxquotient "zero dividend" y))
($fxquotient x y)))
(define fxremainder
(lambda (x y)
(unless (fixnum? x)
(error 'fxremainder "~s is not a fixnum" x))
(error 'fxremainder "not a fixnum" x))
(unless (fixnum? y)
(error 'fxremainder "~s is not a fixnum" y))
(error 'fxremainder "not a fixnum" y))
(when ($fxzero? y)
(error 'fxremainder "zero dividend ~s" y))
(error 'fxremainder "zero dividend" y))
(let ([q ($fxquotient x y)])
($fx- x ($fx* q y)))))
(define fxmodulo
(lambda (x y)
(unless (fixnum? x)
(error 'fxmodulo "~s is not a fixnum" x))
(error 'fxmodulo "not a fixnum" x))
(unless (fixnum? y)
(error 'fxmodulo "~s is not a fixnum" y))
(error 'fxmodulo "not a fixnum" y))
(when ($fxzero? y)
(error 'fxmodulo "zero dividend ~s" y))
(error 'fxmodulo "zero dividend" y))
($fxmodulo x y)))
(define-syntax fxbitop
@ -178,8 +178,8 @@
(if (fixnum? x)
(if (fixnum? y)
($op x y)
(error 'who "~s is not a fixnum" y))
(error 'who "~s is not a fixnum" x))]
(error 'who "not a fixnum" y))
(error 'who "not a fixnum" x))]
[(x y . ls)
(if (fixnum? x)
(if (fixnum? y)
@ -189,11 +189,11 @@
(let ([b ($car ls)])
(if (fixnum? b)
(f ($op a b) ($cdr ls))
(error 'who "~s is not a fixnum" b)))]
(error 'who "not a fixnum" b)))]
[else a]))
(error 'who "~s is not a fixnum" y))
(error 'who "~s is not a fixnum" x))]
[(x) (if (fixnum? x) x (error 'who "~s is not a fixnum" x))]
(error 'who "not a fixnum" y))
(error 'who "not a fixnum" x))]
[(x) (if (fixnum? x) x (error 'who "not a fixnum" x))]
[() identity])]))
(define fxlogor (fxbitop fxlogor $fxlogor 0))
@ -210,58 +210,58 @@
($fxlogor
($fxlogand x y)
($fxlogand ($fxlognot x) z))
(error 'fxif "~s is not a fixnum" z))
(error 'fxif "~s is not a fixnum" y))
(error 'fxif "~s is not a fixnum" x)))
(error 'fxif "not a fixnum" z))
(error 'fxif "not a fixnum" y))
(error 'fxif "not a fixnum" x)))
(define fxsra
(lambda (x y)
(unless (fixnum? x)
(error 'fxsra "~s is not a fixnum" x))
(error 'fxsra "not a fixnum" x))
(unless (fixnum? y)
(error 'fxsra "~s is not a fixnum" y))
(error 'fxsra "not a fixnum" y))
(unless ($fx>= y 0)
(error 'fxsra "negative shift not allowed, got ~s" y))
(error 'fxsra "negative shift not allowed" y))
($fxsra x y)))
(define fxarithmetic-shift-right
(lambda (x y)
(unless (fixnum? x)
(error 'fxarithmetic-shift-right "~s is not a fixnum" x))
(error 'fxarithmetic-shift-right "not a fixnum" x))
(unless (fixnum? y)
(error 'fxarithmetic-shift-right "~s is not a fixnum" y))
(error 'fxarithmetic-shift-right "not a fixnum" y))
(unless ($fx>= y 0)
(error 'fxarithmetic-shift-right "negative shift not allowed, got ~s" y))
(error 'fxarithmetic-shift-right "negative shift not allowed" y))
($fxsra x y)))
(define fxsll
(lambda (x y)
(unless (fixnum? x)
(error 'fxsll "~s is not a fixnum" x))
(error 'fxsll "not a fixnum" x))
(unless (fixnum? y)
(error 'fxsll "~s is not a fixnum" y))
(error 'fxsll "not a fixnum" y))
(unless ($fx>= y 0)
(error 'fxsll "negative shift not allowed, got ~s" y))
(error 'fxsll "negative shift not allowed" y))
($fxsll x y)))
(define fxarithmetic-shift-left
(lambda (x y)
(unless (fixnum? x)
(error 'fxarithmetic-shift-left "~s is not a fixnum" x))
(error 'fxarithmetic-shift-left "not a fixnum" x))
(unless (fixnum? y)
(error 'fxarithmetic-shift-left "~s is not a fixnum" y))
(error 'fxarithmetic-shift-left "not a fixnum" y))
(unless ($fx>= y 0)
(error 'fxarithmetic-shift-left "negative shift not allowed, got ~s" y))
(error 'fxarithmetic-shift-left "negative shift not allowed" y))
($fxsll x y)))
(define fxarithmetic-shift
(lambda (x y)
(unless (fixnum? x)
(error 'fxarithmetic-shift "~s is not a fixnum" x))
(error 'fxarithmetic-shift "not a fixnum" x))
(unless (fixnum? y)
(error 'fxarithmetic-shift "~s is not a fixnum" y))
(error 'fxarithmetic-shift "not a fixnum" y))
(if ($fx>= y 0)
($fxsll x y)
(if ($fx< x -100) ;;; arbitrary number < (fixnum-width)
@ -271,22 +271,22 @@
(define (fxpositive? x)
(if (fixnum? x)
($fx> x 0)
(error 'fxpositive? "~s is not a fixnum" x)))
(error 'fxpositive? "not a fixnum" x)))
(define (fxnegative? x)
(if (fixnum? x)
($fx< x 0)
(error 'fxnegative? "~s is not a fixnum" x)))
(error 'fxnegative? "not a fixnum" x)))
(define (fxeven? x)
(if (fixnum? x)
($fxzero? ($fxlogand x 1))
(error 'fxeven? "~s is not a fixnum" x)))
(error 'fxeven? "not a fixnum" x)))
(define (fxodd? x)
(if (fixnum? x)
(not ($fxzero? ($fxlogand x 1)))
(error 'fxodd? "~s is not a fixnum" x)))
(error 'fxodd? "not a fixnum" x)))
(define fxmin
(case-lambda
@ -294,8 +294,8 @@
(if (fixnum? x)
(if (fixnum? y)
(if ($fx< x y) x y)
(error 'fxmin "~s is not a fixnum" y))
(error 'fxmin "~s is not a fixnum" x))]
(error 'fxmin "not a fixnum" y))
(error 'fxmin "not a fixnum" x))]
[(x y z . ls)
(fxmin (fxmin x y)
(if (fixnum? z)
@ -307,9 +307,9 @@
(if ($fx< a z)
(f a ($cdr ls))
(f z ($cdr ls)))
(error 'fxmin "~s is not a fixnum" a)))))
(error 'fxmin "~s is not a fixnum" z)))]
[(x) (if (fixnum? x) x (error 'fxmin "~s is not a fixnum" x))]))
(error 'fxmin "not a fixnum" a)))))
(error 'fxmin "not a fixnum" z)))]
[(x) (if (fixnum? x) x (error 'fxmin "not a fixnum" x))]))
(define fxmax
(case-lambda
@ -317,8 +317,8 @@
(if (fixnum? x)
(if (fixnum? y)
(if ($fx> x y) x y)
(error 'fxmax "~s is not a fixnum" y))
(error 'fxmax "~s is not a fixnum" x))]
(error 'fxmax "not a fixnum" y))
(error 'fxmax "not a fixnum" x))]
[(x y z . ls)
(fxmax (fxmax x y)
(if (fixnum? z)
@ -330,9 +330,9 @@
(if ($fx> a z)
(f a ($cdr ls))
(f z ($cdr ls)))
(error 'fxmax "~s is not a fixnum" a)))))
(error 'fxmax "~s is not a fixnum" z)))]
[(x) (if (fixnum? x) x (error 'fxmax "~s is not a fixnum" x))]))
(error 'fxmax "not a fixnum" a)))))
(error 'fxmax "not a fixnum" z)))]
[(x) (if (fixnum? x) x (error 'fxmax "not a fixnum" x))]))
(define (fx*/carry fx1 fx2 fx3)
(let ([s0 ($fx+ ($fx* fx1 fx2) fx3)])
@ -369,7 +369,7 @@
(values str ($fxadd1 j))))))])))
(define fixnum->string
(lambda (x)
(unless (fixnum? x) (error 'fixnum->string "~s is not a fixnum" x))
(unless (fixnum? x) (error 'fixnum->string "not a fixnum" x))
(cond
[($fxzero? x) "0"]
[($fx> x 0)

28
scheme/ikarus.handlers.ss
View File

@ -10,7 +10,7 @@
[(v) (set! x v)])]
[(x guard)
(unless (procedure? guard)
(error 'make-parameter "~s is not a procedure" guard))
(error 'make-parameter "not a procedure" guard))
(set! x (guard x))
(case-lambda
[() x]
@ -35,20 +35,20 @@
(lambda (x)
(if (procedure? x)
x
(error 'interrupt-handler "~s is not a procedure" x)))))
(error 'interrupt-handler "not a procedure" x)))))
(define $apply-nonprocedure-error-handler
(lambda (x)
(error 'apply "~s is not a procedure" x)))
(error 'apply "not a procedure" x)))
(define $incorrect-args-error-handler
(lambda (p n)
(error 'apply "incorrect number of argument (~s) to ~s" n p)))
(error 'apply "incorrect number of argument" n p)))
(define $multiple-values-error
(lambda args
(error 'apply
"incorrect number of values ~s returned to single value context"
"incorrect number of values returned to single value context"
args)))
(define $debug
@ -64,42 +64,42 @@
(cond
[(symbol? x)
(if (symbol-bound? x)
(error 'top-level-value-error "BUG in ~s" x)
(error 'top-level-value-error "BUG: should not happen" x)
(error #f "unbound" (string->symbol (symbol->string x))))]
[else
(error 'top-level-value "~s is not a symbol" x)])))
(error 'top-level-value "not a symbol" x)])))
(define car-error
(lambda (x)
(error 'car "~s is not a pair" x)))
(error 'car "not a pair" x)))
(define cdr-error
(lambda (x)
(error 'cdr "~s is not a pair" x)))
(error 'cdr "not a pair" x)))
(define fxadd1-error
(lambda (x)
(if (fixnum? x)
(error 'fxadd1 "overflow")
(error 'fxadd1 "~s is not a fixnum" x))))
(error 'fxadd1 "not a fixnum" x))))
(define fxsub1-error
(lambda (x)
(if (fixnum? x)
(error 'fxsub1 "underflow")
(error 'fxsub1 "~s is not a fixnum" x))))
(error 'fxsub1 "not a fixnum" x))))
(define cadr-error
(lambda (x)
(error 'cadr "invalid list structure in ~s" x)))
(error 'cadr "invalid list structure" x)))
(define fx+-type-error
(lambda (x)
(error 'fx+ "~s is not a fixnum" x)))
(error 'fx+ "not a fixnum" x)))
(define fx+-types-error
(lambda (x y)
(error 'fx+ "~s is not a fixnum"
(error 'fx+ "not a fixnum"
(if (fixnum? x) y x))))
(define fx+-overflow-error

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

@ -259,28 +259,28 @@
(>= k 0))
(make-eq-hashtable)
(error 'make-eq-hashtable
"invalid initial capacity ~s" k))]))
"invalid initial capacity" k))]))
(define hashtable-ref
(lambda (h x v)
(if (hasht? h)
(get-hash h x v)
(error 'hashtable-ref "~s is not a hash table" h))))
(error 'hashtable-ref "not a hash table" h))))
(define hashtable-contains?
(lambda (h x)
(if (hasht? h)
(in-hash? h x)
(error 'hashtable-contains? "~s is not a hash table" h))))
(error '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! "~s is immutable" h))
(error 'hashtable-set! "~s is not a hash table" h))))
(error 'hashtable-set! "hashtable is immutable" h))
(error 'hashtable-set! "not a hash table" h))))
(define hashtable-update!
@ -289,16 +289,16 @@
(if (hasht-mutable? h)
(if (procedure? proc)
(update-hash! h x proc default)
(error 'hashtable-update! "~s is not a procedure" proc))
(error 'hashtable-update! "~s is immutable" h))
(error 'hashtable-update! "~s is not a hash table" h))))
(error 'hashtable-update! "not a procedure" proc))
(error 'hashtable-update! "hashtable is immutable" h))
(error 'hashtable-update! "not a hash table" h))))
(define hashtable-size
(lambda (h)
(if (hasht? h)
(hasht-count h)
(error 'hashtable-size "~s is not a hash table" h))))
(error 'hashtable-size "not a hash table" h))))
(define hashtable-delete!
(lambda (h x)
@ -307,23 +307,23 @@
(if (hasht? h)
(if (hasht-mutable? h)
(del-hash h x)
(error 'hashtable-delete! "~s is immutable" h))
(error 'hashtable-delete! "~s is not a hash table" h))))
(error 'hashtable-delete! "hashtable is immutable" h))
(error 'hashtable-delete! "not a hash table" h))))
(define (hashtable-keys h)
(if (hasht? h)
(get-keys h)
(error 'hashtable-keys "~s is not a hash table" h)))
(error 'hashtable-keys "not a hash table" h)))
(define (hashtable-mutable? h)
(if (hasht? h)
(hasht-mutable? h)
(error 'hashtable-mutable? "~s is not a hash table" h)))
(error 'hashtable-mutable? "not a hash table" h)))
(define (hashtable-clear! h)
(if (hasht? h)
(if (hasht-mutable? h)
(clear-hash! h)
(error 'hashtable-clear! "~s is immutable" h))
(error 'hashtable-clear! "~s is not a hash table" h)))
(error 'hashtable-clear! "hashtable is immutable" h))
(error 'hashtable-clear! "not a hash table" h)))
)

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

@ -58,7 +58,7 @@
(lambda (x)
(cond
[(assq x register-mapping) => caddr]
[else (error 'register-index "not a register ~s" x)])))
[else (error 'register-index "not a register" x)])))
(define reg32?
(lambda (x)
@ -194,7 +194,7 @@
(cons (cons 'label-addr (label-name n)) ac)]
[(foreign? n)
(cons (cons 'foreign-label (label-name n)) ac)]
[else (error 'IMM32 "invalid ~s" n)])))
[else (error 'IMM32 "invalid" n)])))
(define IMM8
@ -202,7 +202,7 @@
(cond
[(int? n)
(cons* (byte n) ac)]
[else (error 'IMM8 "invalid ~s" n)])))
[else (error 'IMM8 "invalid" n)])))
(define imm?
@ -229,7 +229,7 @@
(let ([d (cdr x)])
(unless (and (null? (cdr d))
(symbol? (car d)))
(error 'assemble "invalid label ~s" x)))
(error 'assemble "invalid label" x)))
#t]
[else #f])))
@ -241,7 +241,7 @@
(unless (and (null? (cdr d))
(or (symbol? (car d))
(string? (car d))))
(error 'assemble "invalid label-address ~s" x)))
(error 'assemble "invalid label-address" x)))
#t]
[else #f])))
@ -265,7 +265,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=~s" i)])))
[else (error 'CODErri "invalid i" i)])))
(define CODErr
(lambda (c d s ac)
@ -297,8 +297,9 @@
(cons (reloc-word+ v d) ac))]
[(and (int? i2) (obj? i1)) (IMM32*2 i2 i1 ac)]
[(and (int? i1) (int? i2))
;FIXME
(IMM32 i1 (IMM32 i2 ac))]
[else (error 'assemble "IMM32*2 ~s ~s" i1 i2)])))
[else (error 'assemble "invalid IMM32*2" i1 i2)])))
(define CODErd
(lambda (c r1 disp ac)
@ -315,7 +316,7 @@
(CODE c
(ModRM 0 r1 '/5
(IMM32*2 a1 a2 ac)))]
[else (error 'CODErd "unhandled ~s" disp)])))))
[else (error 'CODErd "unhandled" disp)])))))
(define CODEdi
(lambda (c /? disp n ac)
@ -323,14 +324,14 @@
(lambda (a1 a2)
(cond
[(and (reg? a1) (reg? a2))
(error 'CODEdi "unsupported1 ~s" disp)]
(error '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 ~s" disp)]
[else (error 'CODEdi "unhandled ~s" disp)])))))
(error 'CODEdi "unsupported2" disp)]
[else (error 'CODEdi "unhandled" disp)])))))
(define (SIB s i b ac)
(cons (byte
@ -360,8 +361,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 ~s ~s" a0 a1)])))]
[else (error 'CODE/digit "unhandled ~s" dst)])))
[else (error 'CODE/digit "unhandled" a0 a1)])))]
[else (error 'CODE/digit "unhandled" dst)])))
(define CODEid
(lambda (c /? n disp ac)
@ -369,7 +370,7 @@
(lambda (a1 a2)
(cond
[(and (reg? a1) (reg? a2))
(error 'CODEid "unsupported1 ~s" disp)]
(error 'CODEid "unsupported1" disp)]
[(and (imm? a1) (reg? a2))
(error 'CODEid "unsupported2")
(CODErri c /? a2 a1 (IMM32 n ac))]
@ -378,7 +379,7 @@
(CODErri c /? a1 a2 (IMM32 n ac))]
[(and (imm? a1) (imm? a2))
(error 'CODEid "unsupported4")]
[else (error 'CODEid "unhandled ~s" disp)])))))
[else (error 'CODEid "unhandled" disp)])))))
(define CODEdi8
(lambda (c /? disp n ac)
@ -410,20 +411,20 @@
[(fx= n 2)
(if (fx= (length args) 2)
(proc a ac (car args) (cadr args))
(error 'convert-instruction "incorrect args in ~s" a))]
(error 'convert-instruction "incorrect args" a))]
[(fx= n 1)
(if (fx= (length args) 1)
(proc a ac (car args))
(error 'convert-instruction "incorrect args in ~s" a))]
(error 'convert-instruction "incorrect args" a))]
[(fx= n 0)
(if (fx= (length args) 0)
(proc a ac)
(error 'convert-instruction "incorrect args in ~s" a))]
(error 'convert-instruction "incorrect args" a))]
[else
(if (fx= (length args) n)
(apply proc a ac args)
(error 'convert-instruction "incorrect args in ~s" a))])))]
[else (error 'convert-instruction "unknown instruction in ~s" a)]))
(error 'convert-instruction "incorrect args" a))])))]
[else (error 'convert-instruction "unknown instruction" a)]))
@ -433,17 +434,17 @@
(cond
[(reg? arg2) (CODEri ircode arg2 arg1 ac)]
[(mem? arg2) (CODEdi imcode '/0 arg2 arg1 ac)]
[else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)])]
[else (error '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 ~s ~s" arg1 arg2)])]
[else (error 'instr/2 "invalid args" arg1 arg2)])]
[(mem? arg1)
(cond
[(reg? arg2) (CODErd mrcode arg2 arg1 ac)]
[else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)])]
[else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)]))
[else (error 'instr/2 "invalid args" arg1 arg2)])]
[else (error 'instr/2 "invalid args" arg1 arg2)]))
(module ()
(define who 'assembler)
@ -452,7 +453,7 @@
(cond
[(reg8? dst)
(CODE #x0F (CODE c (ModRM 3 '/0 dst ac)))]
[else (error who "invalid condition-set to ~s" dst)]))
[else (error who "invalid condition-set" dst)]))
(define (conditional-jump c dst ac)
(cond
@ -460,7 +461,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 ~s" dst)]))
[else (error who "invalid conditional jump target" dst)]))
(add-instructions instr ac
[(ret) (CODE #xC3 ac)]
@ -473,46 +474,46 @@
((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 ~s" instr)])]
[else (error 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 ~s" instr)])]
[else (error 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 ~s" instr)])]
[else (error 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 ~s" instr)])]
[else (error 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 ~s" instr)])]
[else (error 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 ~s" instr)])]
[else (error 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 ~s" instr)])]
[else (error 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 ~s" instr)])]
[else (error who "invalid" instr)])]
[(addl src dst)
(cond
[(and (imm8? src) (reg? dst))
@ -529,7 +530,7 @@
((CODE/digit #x81 '/0) dst (IMM32 src ac))]
[(and (reg? src) (mem? dst))
((CODE/digit #x01 src) dst ac)]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(subl src dst)
(cond
[(and (imm8? src) (reg? dst))
@ -546,7 +547,7 @@
((CODE/digit #x81 '/5) dst (IMM32 src ac))]
[(and (reg? src) (mem? dst))
((CODE/digit #x29 src) dst ac)]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(sall src dst)
(cond
[(and (equal? 1 src) (reg? dst))
@ -559,7 +560,7 @@
(CODE #xD3 (ModRM 3 '/4 dst ac))]
[(and (eq? src '%cl) (mem? dst))
((CODE/digit #xD3 '/4) dst ac)]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(shrl src dst)
(cond
[(and (equal? 1 src) (reg? dst))
@ -572,7 +573,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 ~s" instr)])]
[else (error who "invalid" instr)])]
[(sarl src dst)
(cond
[(and (equal? 1 src) (reg? dst))
@ -585,7 +586,7 @@
(CODE #xD3 (ModRM 3 '/7 dst ac))]
[(and (eq? src '%cl) (mem? dst))
((CODE/digit #xD3 '/7) dst ac)]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(andl src dst)
(cond
[(and (imm? src) (mem? dst))
@ -602,7 +603,7 @@
((CODE/digit #x21 src) dst ac)]
[(and (mem? src) (reg? dst))
(CODErd #x23 dst src ac)]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(orl src dst)
(cond
[(and (imm? src) (mem? dst))
@ -619,7 +620,7 @@
(CODE #x09 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x0B dst src ac)]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(xorl src dst)
(cond
[(and (imm8? src) (reg? dst))
@ -630,12 +631,12 @@
(CODE #x31 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x33 dst src ac)]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(leal src dst)
(cond
[(and (mem? src) (reg? dst))
(CODErd #x8D dst src ac)]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(cmpl src dst)
(cond
[(and (imm8? src) (reg? dst))
@ -654,7 +655,7 @@
[(and (imm? src) (mem? dst))
;;; maybe error
(CODErd #x81 '/7 dst (IMM32 src ac))]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(imull src dst)
(cond
[(and (imm8? src) (reg? dst))
@ -665,7 +666,7 @@
(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 ~s" instr)])]
[else (error who "invalid" instr)])]
[(idivl dst)
(cond
[(reg? dst)
@ -673,7 +674,7 @@
[(mem? dst)
;;; maybe error
(CODErd #xF7 '/7 dst ac)]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(pushl dst)
(cond
[(imm8? dst)
@ -685,7 +686,7 @@
[(mem? dst)
;;; maybe error
(CODErd #xFF '/6 dst ac)]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(popl dst)
(cond
[(reg? dst)
@ -693,7 +694,7 @@
[(mem? dst)
;;; maybe error
(CODErd #x8F '/0 dst ac)]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(notl dst)
(cond
[(reg? dst)
@ -701,12 +702,12 @@
[(mem? dst)
;;; maybe error
(CODErd #xF7 '/7 dst ac)]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(negl dst)
(cond
[(reg? dst)
(CODE #xF7 (ModRM 3 '/3 dst ac))]
[else (error who "invalid ~s" instr)])]
[else (error who "invalid" instr)])]
[(jmp dst)
(cond
[(label? dst)
@ -716,7 +717,7 @@
[(mem? dst)
;;; maybe error
(CODErd #xFF '/4 dst ac)]
[else (error who "invalid jmp target ~s" dst)])]
[else (error who "invalid jmp target" dst)])]
[(call dst)
(cond
[(imm? dst)
@ -728,7 +729,7 @@
(CODErd #xFF '/2 dst ac)]
[(reg? dst)
(CODE #xFF (ModRM 3 '/2 dst ac))]
[else (error who "invalid jmp target ~s" dst)])]
[else (error 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)]
@ -769,15 +770,15 @@
[(jp dst) (conditional-jump #x8A dst ac)]
[(jnp dst) (conditional-jump #x8B dst ac)]
[(byte x)
(unless (byte? x) (error who "~s is not a byte" x))
(unless (byte? x) (error 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 ~s is not a symbol" L))
(unless (symbol? L) (error who "label is not a symbol" L))
(cons (cons 'label L) ac)]
[(label-address L)
(unless (symbol? L) (error who "label-address ~s is not a symbol" L))
(unless (symbol? L) (error who "label-address is not a symbol" L))
(cons (cons 'label-addr L) ac)]
[(current-frame-offset)
(cons '(current-frame-offset) ac)]
@ -797,7 +798,7 @@
relative local-relative current-frame-offset)
(fx+ ac 4)]
[(label) ac]
[else (error 'compute-code-size "unknown instr ~s" x)])))
[else (error 'compute-code-size "unknown instr" x)])))
0
ls)))
@ -805,13 +806,13 @@
(define set-label-loc!
(lambda (x loc)
(when (getprop x '*label-loc*)
(error 'compile "label ~s is already defined" x))
(error '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 ~s" x))))
(error 'compile "undefined label" x))))
(define unset-label-loc!
@ -827,7 +828,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 ~s" x)])))
[else (error 'set-code-word! "unhandled" x)])))
(define (optimize-local-jumps ls)
(define locals '())
@ -881,7 +882,7 @@
(set-label-loc! (cdr a) (list x idx))
(f (cdr ls) idx reloc)]
[else
(error 'whack-instructions "unknown instr ~s" a)])))])))
(error 'whack-instructions "unknown instr" a)])))])))
(f ls 0 '())))
(define wordsize 4)
@ -896,7 +897,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 ~s" x)])))
[else (error 'compute-reloc-size "unknown instr" x)])))
0
ls)))
@ -923,7 +924,6 @@
(lambda (thunk?-label code vec)
(define reloc-idx 0)
(lambda (r)
;(printf "r=~s\n" r)
(let ([idx (car r)] [type (cadr r)]
[v
(let ([v (cddr r)])
@ -936,7 +936,7 @@
(let ([code (car p)] [idx (cadr p)])
(unless (fx= idx 0)
(error 'whack-reloc
"cannot create a thunk pointing at ~s"
"cannot create a thunk pointing"
idx))
(let ([thunk (code->thunk code)])
(set-cdr! (cdr p) (list thunk))
@ -954,7 +954,7 @@
(let ([name
(if (string? v)
(foreign-string->bytevector v)
(error 'whack-reloc "not a string ~s" v))])
(error '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)))]
@ -986,14 +986,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=~s disp=~s\n"
obj disp))
(error '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 ~s" type)]))
[else (error 'whack-reloc "invalid reloc type" type)]))
)))
@ -1034,9 +1033,6 @@
(lambda (foo reloc*)
(for-each (whack-reloc thunk?-label (car foo) (cdr foo)) reloc*))
(map cons code* relv*) reloc**)
;(for-each (lambda (x)
; (printf "RV=~s\n" x))
; relv*)
(for-each set-code-reloc-vector! code* relv*)
(for-each (lambda (code name)
(when name

54
scheme/ikarus.io-ports.ss
View File

@ -51,8 +51,8 @@
(if (procedure? handler)
(if (bytevector? buffer)
($make-input-port handler buffer)
(error 'make-input-port "~s is not a bytevector" buffer))
(error 'make-input-port "~s is not a procedure" handler))))
(error 'make-input-port "not a bytevector" buffer))
(error 'make-input-port "not a procedure" handler))))
;;;
(define $make-output-port
(lambda (handler buffer)
@ -63,50 +63,50 @@
(if (procedure? handler)
(if (bytevector? buffer)
($make-output-port handler buffer)
(error 'make-output-port "~s is not a bytevector" buffer))
(error 'make-output-port "~s is not a procedure" handler))))
(error 'make-output-port "not a bytevector" buffer))
(error 'make-output-port "not a procedure" handler))))
;;;
(define port-handler
(lambda (x)
(if (port? x)
($port-handler x)
(error 'port-handler "~s is not a port" x))))
(error 'port-handler "not a port" x))))
;;;
(define port-input-buffer
(lambda (x)
(if (input-port? x)
($port-buffer x)
(error 'port-input-buffer "~s is not an input-port" x))))
(error 'port-input-buffer "not an input-port" x))))
;;;
(define port-input-index
(lambda (x)
(if (input-port? x)
($port-index x)
(error 'port-input-index "~s is not an input-port" x))))
(error 'port-input-index "not an input-port" x))))
;;;
(define port-input-size
(lambda (x)
(if (input-port? x)
($port-size x)
(error 'port-input-size "~s is not an input-port" x))))
(error 'port-input-size "not an input-port" x))))
;;;
(define port-output-buffer
(lambda (x)
(if (output-port? x)
($port-buffer x)
(error 'port-output-buffer "~s is not an output-port" x))))
(error 'port-output-buffer "not an output-port" x))))
;;;
(define port-output-index
(lambda (x)
(if (output-port? x)
($port-index x)
(error 'port-output-index "~s is not an output-port" x))))
(error 'port-output-index "not an output-port" x))))
;;;
(define port-output-size
(lambda (x)
(if (output-port? x)
($port-size x)
(error 'port-output-size "~s is not an output-port" x))))
(error 'port-output-size "not an output-port" x))))
;;;
(define set-port-input-index!
(lambda (p i)
@ -115,10 +115,10 @@
(if ($fx>= i 0)
(if ($fx<= i ($port-size p))
($set-port-index! p i)
(error 'set-port-input-index! "index ~s is too big" i))
(error 'set-port-input-index! "index ~s is negative" i))
(error 'set-port-input-index! "~s is not a valid index" i))
(error 'set-port-input-index! "~s is not an input-port" p))))
(error 'set-port-input-index! "index is too big" i))
(error 'set-port-input-index! "index is negative" i))
(error 'set-port-input-index! "not a valid index" i))
(error 'set-port-input-index! "not an input-port" p))))
;;;
(define set-port-input-size!
(lambda (p i)
@ -129,10 +129,10 @@
(begin
($set-port-index! p 0)
($set-port-size! p i))
(error 'set-port-input-size! "size ~s is too big" i))
(error 'set-port-input-size! "size ~s is negative" i))
(error 'set-port-input-size! "~s is not a valid size" i))
(error 'set-port-input-size! "~s is not an input-port" p))))
(error 'set-port-input-size! "size is too big" i))
(error 'set-port-input-size! "size is negative" i))
(error 'set-port-input-size! "not a valid size" i))
(error 'set-port-input-size! "not an input-port" p))))
;;;
(define set-port-output-index!
(lambda (p i)
@ -141,10 +141,10 @@
(if ($fx>= i 0)
(if ($fx<= i ($port-size p))
($set-port-index! p i)
(error 'set-port-output-index! "index ~s is too big" i))
(error 'set-port-output-index! "index ~s is negative" i))
(error 'set-port-output-index! "~s is not a valid index" i))
(error 'set-port-output-index! "~s is not an output-port" p))))
(error 'set-port-output-index! "index is too big" i))
(error 'set-port-output-index! "index is negative" i))
(error 'set-port-output-index! "not a valid index" i))
(error 'set-port-output-index! "not an output-port" p))))
;;;
(define set-port-output-size!
(lambda (p i)
@ -155,10 +155,10 @@
(begin
($set-port-index! p 0)
($set-port-size! p i))
(error 'set-port-output-size! "size ~s is too big" i))
(error 'set-port-output-size! "size ~s is negative" i))
(error 'set-port-output-size! "~s is not a valid size" i))
(error 'set-port-output-size! "~s is not an output-port" p)))))
(error 'set-port-output-size! "size is too big" i))
(error 'set-port-output-size! "size is negative" i))
(error 'set-port-output-size! "not a valid size" i))
(error 'set-port-output-size! "not an output-port" p)))))

38
scheme/ikarus.io-primitives.ss
View File

@ -19,26 +19,26 @@
[(c)
(if (char? c)
($write-char c (current-output-port))
(error 'write-char "~s is not a character" c))]
(error 'write-char "not a character" c))]
[(c p)
(if (char? c)
(if (output-port? p)
($write-char c p)
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]))
(error 'write-char "not an output-port" p))
(error 'write-char "not a character" c))]))
(define write-byte
(case-lambda
[(b)
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
($write-byte b (current-output-port))
(error 'write-byte "~s is not a byte" b))]
(error 'write-byte "not a byte" b))]
[(b p)
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
(if (output-port? p)
($write-byte b p)
(error 'write-byte "~s is not an output-port" p))
(error 'write-byte "~s is not a byte" b))]))
(error 'write-byte "not an output-port" p))
(error 'write-byte "not a byte" b))]))
;;;
(define newline
(case-lambda
@ -50,25 +50,25 @@
(begin
($write-char #\newline p)
($flush-output-port p))
(error 'newline "~s is not an output port" p))]))
(error 'newline "not an output port" p))]))
;;;
(define port-name
(lambda (p)
(if (port? p)
(($port-handler p) 'port-name p)
(error 'port-name "~s is not a port" p))))
(error 'port-name "not a port" p))))
(define input-port-name
(lambda (p)
(if (port? p)
(($port-handler p) 'port-name p)
(error 'input-port-name "~s is not a port" p))))
(error 'input-port-name "not a port" p))))
(define output-port-name
(lambda (p)
(if (port? p)
(($port-handler p) 'port-name p)
(error 'output-port-name "~s is not a port" p))))
(error 'output-port-name "not a port" p))))
(define read-char
(case-lambda
@ -76,19 +76,19 @@
[(p)
(if (input-port? p)
($read-char p)
(error 'read-char "~s is not an input-port" p))]))
(error 'read-char "not an input-port" p))]))
;;;
(define unread-char
(case-lambda
[(c) (if (char? c)
($unread-char c (current-input-port))
(error 'unread-char "~s is not a character" c))]
(error 'unread-char "not a character" c))]
[(c p)
(if (input-port? p)
(if (char? c)
($unread-char c p)
(error 'unread-char "~s is not a character" c))
(error 'unread-char "~s is not an input-port" p))]))
(error 'unread-char "not a character" c))
(error 'unread-char "not an input-port" p))]))
;;;
(define peek-char
(case-lambda
@ -96,7 +96,7 @@
[(p)
(if (input-port? p)
($peek-char p)
(error 'peek-char "~s is not an input-port" p))]))
(error 'peek-char "not an input-port" p))]))
;;;
(define reset-input-port!
(case-lambda
@ -104,7 +104,7 @@
[(p)
(if (input-port? p)
($reset-input-port! p)
(error 'reset-input-port! "~s is not an input-port" p))]))
(error 'reset-input-port! "not an input-port" p))]))
;;;
(define close-input-port
(case-lambda
@ -112,7 +112,7 @@
[(p)
(if (input-port? p)
($close-input-port p)
(error 'close-input-port! "~s is not an input-port" p))]))
(error 'close-input-port! "not an input-port" p))]))
;;;
(define close-output-port
(case-lambda
@ -120,7 +120,7 @@
[(p)
(if (output-port? p)
($close-output-port p)
(error 'close-output-port "~s is not an output-port" p))]))
(error 'close-output-port "not an output-port" p))]))
;;;
(define flush-output-port
(case-lambda
@ -128,5 +128,5 @@
[(p)
(if (output-port? p)
($flush-output-port p)
(error 'flush-output-port "~s is not an output-port" p))])))
(error 'flush-output-port "not an output-port" p))])))

47
scheme/ikarus.io.input-files.ss
View File

@ -26,12 +26,12 @@
[(__ y () body)
(if (null? y)
body
(error 'message-case "unmatched ~s" (cons tmsg targs)))]
(error 'message-case "unmatched" (cons tmsg targs)))]
[(__ y (a a* (... ...)) body)
(if (pair? y)
(let ([a (car y)] [d (cdr y)])
(match-and-bind d (a* (... ...)) body))
(error 'message-case "unmatched ~s" (cons tmsg targs)))]))
(error 'message-case "unmatched" (cons tmsg targs)))]))
(case tmsg
[(msg-name)
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
@ -64,14 +64,14 @@
($port-buffer p)
($fxadd1 idx))])
(unless ($fx= ($fxlogand b1 #b11000000) #b10000000)
(error 'read-char "invalid utf8 sequence ~a ~a" b0 b1))
(error 'read-char "invalid utf8 sequence" b0 b1))
($set-port-index! p ($fx+ idx 2))
($fixnum->char
($fx+ ($fxsll ($fxlogand b0 #b11111) 6)
($fxlogand b1 #b111111))))]
[else
(error 'read-multibyte
"bytesequence ~a is not supported yet" b0)]))))
"BUG: bytesequence is not supported yet" b0)]))))
(define peek-multibyte-char
(lambda (p)
@ -87,7 +87,7 @@
(message-case msg args
[(read-char p)
(unless (input-port? p)
(error 'read-char "~s is not an input port" p))
(error 'read-char "not an input port" p))
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
@ -107,12 +107,12 @@
[($fx= bytes 0)
(eof-object)]
[else
(error 'read-char "Cannot read from ~a"
(error 'read-char "Cannot read from file"
port-name)]))
(error 'read-char "port ~s is closed" p))))]
(error 'read-char "port is closed" p))))]
[(peek-char p)
(unless (input-port? p)
(error 'peek-char "~s is not an input port" p))
(error 'peek-char "not an input port" p))
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
@ -126,20 +126,20 @@
(cond
[(not bytes)
(error 'peek-char
"Cannot read from ~s" port-name)]
"Cannot read from file" port-name)]
[($fx= bytes 0)
(eof-object)]
[else
($set-port-size! p bytes)
($peek-char p)]))
(error 'peek-char "port ~s is closed" p))))]
(error 'peek-char "port is closed" p))))]
[(unread-char c p)
(unless (input-port? p)
(error 'unread-char "~s is not an input port" p))
(error 'unread-char "not an input port" p))
(let ([idx ($fxsub1 ($port-index p))]
[b (if (char? c)
($char->fixnum c)
(error 'unread-char "~s is not a char" c))])
(error 'unread-char "not a char" c))])
(if (and ($fx>= idx 0)
($fx< idx ($port-size p)))
(cond
@ -147,20 +147,20 @@
($set-port-index! p idx)]
[else (unread-multibyte-char c p)])
(if open?
(error 'unread-char "port ~s is closed" p)
(error 'unread-char "port is closed" p)
(error 'unread-char "too many unread-chars"))))]
[(port-name p) port-name]
[(close-port p)
(unless (input-port? p)
(error 'close-input-port "~s is not an input port" p))
(error 'close-input-port "not an input port" p))
(when open?
($set-port-size! p 0)
(set! open? #f)
(unless (foreign-call "ikrt_close_file" fd)
(error 'close-input-port "cannot close ~s" port-name)))]
(error 'close-input-port "cannot close port" port-name)))]
[else
(error 'input-file-handler
"message not handled ~s" (cons msg args))])))))
"message not handled" (cons msg args))])))))
(define $open-input-file
(lambda (filename)
@ -174,20 +174,21 @@
(set-port-input-size! port 0)
(guardian port)
port)
(error 'open-input-file "cannot open ~s: ~a" filename fd/error)))))
(error 'open-input-file "cannot open file"
filename fd/error)))))
(define open-input-file
(lambda (filename)
(if (string? filename)
($open-input-file filename)
(error 'open-input-file "~s is not a string" filename))))
(error 'open-input-file "not a string" filename))))
(define with-input-from-file
(lambda (name proc)
(unless (string? name)
(error 'with-input-from-file "~s is not a string" name))
(error 'with-input-from-file "not a string" name))
(unless (procedure? proc)
(error 'with-input-from-file "~s is not a procedure" proc))
(error 'with-input-from-file "not a procedure" proc))
(let ([p ($open-input-file name)])
(call-with-values
(lambda ()
@ -202,9 +203,9 @@
(define call-with-input-file
(lambda (name proc)
(unless (string? name)
(error 'call-with-input-file "~s is not a string" name))
(error 'call-with-input-file "not a string" name))
(unless (procedure? proc)
(error 'call-with-input-file "~s is not a procedure" proc))
(error 'call-with-input-file "not a procedure" proc))
(let ([p ($open-input-file name)])
(call-with-values (lambda () (proc p))
(case-lambda
@ -225,7 +226,7 @@
[(p)
(if (input-port? p)
(set! *current-input-port* p)
(error 'current-input-port "~s is not an input-port" p))]))
(error 'current-input-port "not an input-port" p))]))
(set! *standard-input-port*
(let ([p (make-input-port

18
scheme/ikarus.io.input-strings.ss
View File

@ -21,12 +21,12 @@
[(__ y () body)
(if (null? y)
body
(error 'message-case "unmatched ~s" (cons tmsg targs)))]
(error 'message-case "unmatched" (cons tmsg targs)))]
[(__ y (a a* (... ...)) body)
(if (pair? y)
(let ([a (car y)] [d (cdr y)])
(match-and-bind d (a* (... ...)) body))
(error 'message-case "unmatched ~s" (cons tmsg targs)))]))
(error 'message-case "unmatched" (cons tmsg targs)))]))
(case tmsg
[(msg-name)
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
@ -44,20 +44,20 @@
c)
(if open?
(eof-object)
(error 'read-char "port ~s is closed" p)))]
(error 'read-char "port is closed" p)))]
[(peek-char p)
(if ($fx< idx n)
($string-ref str idx)
(if open?
(eof-object)
(error 'peek-char "port ~s is closed" p)))]
(error 'peek-char "port is closed" p)))]
[(unread-char c p)
(let ([i ($fxsub1 idx)])
(if (and ($fx>= i 0)
($fx< i n))
(set! idx i)
(if open?
(error 'unread-char "port ~s is closed" p)
(error 'unread-char "port is closed" p)
(error 'unread-char "too many unread-chars"))))]
[(port-name p) '*string-port*]
[(close-port p)
@ -65,12 +65,12 @@
(set! open? #f))]
[else
(error 'input-string-handler
"message not handled ~s" (cons msg args))])))))
"message not handled" (cons msg args))])))))
(define open-input-string
(lambda (str)
(unless (string? str)
(error 'open-input-string "~s is not a string" str))
(error 'open-input-string "not a string" str))
(let ([port (make-input-port
(make-input-string-handler str)
'#vu8())])
@ -80,9 +80,9 @@
(define with-input-from-string
(lambda (str proc)
(unless (string? str)
(error 'with-input-from-string "~s is not a string" str))
(error 'with-input-from-string "not a string" str))
(unless (procedure? proc)
(error 'with-input-from-string "~s is not a procedure" proc))
(error 'with-input-from-string "not a procedure" proc))
(let ([p (open-input-string str)])
(parameterize ([current-input-port p])
(proc)))))

55
scheme/ikarus.io.output-files.ss
View File

@ -30,12 +30,12 @@
[(__ y () body)
(if (null? y)
body
(error 'message-case "unmatched ~s" (cons tmsg targs)))]
(error 'message-case "unmatched" (cons tmsg targs)))]
[(__ y (a a* (... ...)) body)
(if (pair? y)
(let ([a (car y)] [d (cdr y)])
(match-and-bind d (a* (... ...)) body))
(error 'message-case "unmatched ~s" (cons tmsg targs)))]))
(error 'message-case "unmatched" (cons tmsg targs)))]))
(case tmsg
[(msg-name)
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
@ -51,22 +51,12 @@
(close-output-port p)
(close-ports))])))
(define do-write-buffer-old
(lambda (fd port-name p caller)
(let ([bytes (foreign-call "ikrt_write_file"
fd
(port-output-buffer p)
(port-output-index p))])
(if (fixnum? bytes)
(set-port-output-index! p 0)
(error caller "cannot write to file ~s: ~a" port-name bytes)))))
(define do-write-buffer
(lambda (fd port-name buff idx caller)
(let ([bytes (foreign-call "ikrt_write_file" fd buff idx)])
(if (fixnum? bytes)
bytes
(error caller "cannot write to file ~s: ~a" port-name bytes)))))
(error caller "cannot write to file" port-name bytes)))))
(define make-output-file-handler
(lambda (fd port-name)
@ -87,18 +77,19 @@
($port-buffer p) idx 'write-char)])
($set-port-index! p 0)
($write-byte b p))
(error 'write-byte "port ~s is closed" p))))
(error 'write-byte "~s is not an output-port" p))
(error 'write-byte "~s is not a byte" b))]
(error 'write-byte "port is closed" p))))
(error 'write-byte "not an output-port" p))
(error 'write-byte "not a byte" b))]
[(write-char c p)
(if (char? c)
(if (output-port? p)
(let ([b ($char->fixnum c)])
(if ($fx<= b 255)
($write-byte b p)
(error 'write-char "multibyte write of ~s not implemented" c)))
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]
(error 'write-char
"BUG: multibyte write of not implemented" c)))
(error 'write-char "not an output-port" p))
(error 'write-char "not a character" c))]
[(flush-output-port p)
(if (output-port? p)
(if open?
@ -107,18 +98,18 @@
($port-index p)
'flush-output-port)])
($set-port-index! p 0))
(error 'flush-output-port "port ~s is closed" p))
(error 'flush-output-port "~s is not an output-port" p))]
(error 'flush-output-port "port is closed" p))
(error 'flush-output-port "not an output-port" p))]
[(close-port p)
(when open?
(flush-output-port p)
($set-port-size! p 0)
(set! open? #f)
(unless (foreign-call "ikrt_close_file" fd)
(error 'close-output-port "cannot close ~s" port-name)))]
(error 'close-output-port "cannot close" port-name)))]
[(port-name p) port-name]
[else (error 'output-file-handler
"unhandled message ~s" (cons msg args))])))
"unhandled message" (cons msg args))])))
output-file-handler))
(define (option-id x)
(case x
@ -126,7 +117,7 @@
[(replace) 1]
[(truncate) 2]
[(append) 3]
[else (error 'open-output-file "~s is not a valid mode" x)]))
[else (error 'open-output-file "not a valid mode" x)]))
(define $open-output-file
(lambda (filename options)
@ -142,7 +133,7 @@
($make-bytevector 4096))])
(guardian port)
port)
(error 'open-output-file "cannot open ~s: ~a" filename fd/error)))))
(error 'open-output-file "cannot open file" filename fd/error)))))
(define *standard-output-port* #f)
@ -165,25 +156,25 @@
[(p)
(if (output-port? p)
(set! *current-output-port* p)
(error 'current-output-port "~s is not an output port" p))]))
(error 'current-output-port "not an output port" p))]))
(define open-output-file
(case-lambda
[(filename)
(if (string? filename)
($open-output-file filename 'error)
(error 'open-output-file "~s is not a string" filename))]
(error 'open-output-file "not a string" filename))]
[(filename options)
(if (string? filename)
($open-output-file filename options)
(error 'open-output-file "~s is not a string" filename))]))
(error 'open-output-file "not a string" filename))]))
(define with-output-to-file
(lambda (name proc . args)
(unless (string? name)
(error 'with-output-to-file "~s is not a string" name))
(error 'with-output-to-file "not a string" name))
(unless (procedure? proc)
(error 'with-output-to-file "~s is not a procedure" proc))
(error 'with-output-to-file "not a procedure" proc))
(let ([p (apply open-output-file name args)]
[shot #f])
(call-with-values
@ -199,9 +190,9 @@
(define call-with-output-file
(lambda (name proc . args)
(unless (string? name)
(error 'call-with-output-file "~s is not a string" name))
(error 'call-with-output-file "not a string" name))
(unless (procedure? proc)
(error 'call-with-output-file "~s is not a procedure" proc))
(error 'call-with-output-file "not a procedure" proc))
(let ([p (apply open-output-file name args)])
(call-with-values (lambda () (proc p))
(case-lambda

25
scheme/ikarus.io.output-strings.ss
View File

@ -24,12 +24,12 @@
[(__ y () body)
(if (null? y)
body
(error 'message-case "unmatched ~s" (cons tmsg targs)))]
(error 'message-case "unmatched" (cons tmsg targs)))]
[(__ y (a a* (... ...)) body)
(if (pair? y)
(let ([a (car y)] [d (cdr y)])
(match-and-bind d (a* (... ...)) body))
(error 'message-case "unmatched ~s" (cons tmsg targs)))]))
(error 'message-case "unmatched" (cons tmsg targs)))]))
(case tmsg
[(msg-name)
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
@ -120,18 +120,19 @@
(set! buffer-list (cons (bv-copy buff) buffer-list))
($bytevector-set! buff 0 b)
($set-port-index! p 1))
(error 'write-byte "port ~s is closed" p))))
(error 'write-byte "~s is not an output-port" p))
(error 'write-byte "~s is not a byte" b))]
(error 'write-byte "port is closed" p))))
(error 'write-byte "not an output-port" p))
(error 'write-byte "not a byte" b))]
[(write-char c p)
(if (char? c)
(if (output-port? p)
(let ([b ($char->fixnum c)])
(if ($fx<= b 127)
($write-byte b p)
(error 'write-char "multibyte write of ~s is not implemented" c)))
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]
(error 'write-char
"BUG: multibyte write of is not implemented" c)))
(error 'write-char "not an output-port" p))
(error 'write-char "not a character" c))]
[(flush-output-port p)
(void)]
[(close-port p)
@ -143,8 +144,8 @@
($port-buffer p)
($port-index p)
buffer-list))]
[else (error 'output-handler
"unhandled message ~s" (cons msg args))])))
[else
(error 'output-handler "unhandled message" (cons msg args))])))
output-handler))
(define open-output-string
@ -157,12 +158,12 @@
(lambda (p)
(if (output-port? p)
(($port-handler p) 'get-output-string p)
(error 'get-output-string "~s is not an output port" p))))
(error 'get-output-string "not an output port" p))))
(define with-output-to-string
(lambda (f)
(unless (procedure? f)
(error 'with-output-to-string "~s is not a procedure" f))
(error 'with-output-to-string "not a procedure" f))
(let ([p (open-output-string)])
(parameterize ([current-output-port p]) (f))
(get-output-string p))))

216
scheme/ikarus.lists.ss
View File

@ -55,11 +55,11 @@
[(n)
(if (and (fixnum? n) ($fx>= n 0))
(f n (void) '())
(error 'make-list "~s is not a valid length" n))]
(error 'make-list "not a valid length" n))]
[(n fill)
(if (and (fixnum? n) ($fx>= n 0))
(f n fill '())
(error 'make-list "~s is not a valid length" n))])))
(error 'make-list "not a valid length" n))])))
(define length
@ -70,13 +70,13 @@
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'length "circular list ~s" ls))
(error 'length "circular list" ls))
(if (null? h)
($fx+ n 1)
(error 'length "~s is not a proper list" ls))))
(error 'length "not a proper list" ls))))
(if (null? h)
n
(error 'length "~s is not a proper list" ls))))])
(error 'length "not a proper list" ls))))])
(lambda (ls)
(race ls ls ls 0))))
@ -88,14 +88,14 @@
[($fxzero? i)
(if (pair? ls)
($car ls)
(error 'list-ref "index ~s is out of range for ~s" index list))]
(error 'list-ref "index is out of range" index list))]
[(pair? ls)
(f ($cdr ls) ($fxsub1 i))]
[(null? ls)
(error 'list-rec "index ~s is out of range for ~s" index list)]
[else (error 'list-ref "~s is not a list" list)])))
(error 'list-rec "index is out of range" index list)]
[else (error 'list-ref "not a list" list)])))
(unless (and (fixnum? index) ($fx>= index 0))
(error 'list-ref "~s is not a valid index" index))
(error 'list-ref "not a valid index" index))
(f list index)))
@ -108,10 +108,10 @@
[(pair? ls)
(f ($cdr ls) ($fxsub1 i))]
[(null? ls)
(error 'list-tail "index ~s is out of range for ~s" index list)]
[else (error 'list-tail "~s is not a list" list)])))
(error 'list-tail "index is out of range" index list)]
[else (error 'list-tail "not a list" list)])))
(unless (and (fixnum? index) ($fx>= index 0))
(error 'list-tail "~s is not a valid index" index))
(error 'list-tail "not a valid index" index))
(f list index)))
(module (append)
@ -123,13 +123,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 ~s" ls))
(error 'append "circular list" ls))
(if (null? h)
(cons a1 ac)
(error 'append "~s is not a proper list" ls))))
(error 'append "not a proper list" ls))))
(if (null? h)
ac
(error 'append "~s is not a proper list" ls)))))
(error 'append "not a proper list" ls)))))
(define revcons
(lambda (ls ac)
(cond
@ -158,13 +158,13 @@
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls (cons ($car h) ac))
(error 'reverse "~s is a circular list" ls))
(error 'reverse "circular list" ls))
(if (null? h)
ac
(error 'reverse "~s is not a proper list" ls))))
(error 'reverse "not a proper list" ls))))
(if (null? h)
ac
(error 'reverse "~s is not a proper list" ls))))])
(error 'reverse "not a proper list" ls))))])
(lambda (x)
(race x x x '()))))
@ -176,14 +176,14 @@
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls h)
(error 'last-pair "~s is a circular list" ls))
(error 'last-pair "circular list" ls))
last))
last))])
(lambda (x)
(if (pair? x)
(let ([d (cdr x)])
(race d d x x))
(error 'last-pair "~s is not a pair" x)))))
(error 'last-pair "not a pair" x)))))
(define memq
(letrec ([race
@ -197,13 +197,13 @@
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'memq "circular list ~s" ls)))
(error 'memq "circular list" ls)))
(if (null? h)
'#f
(error 'memq "~s is not a proper list" ls)))))
(error 'memq "not a proper list" ls)))))
(if (null? h)
'#f
(error 'memq "~s is not a proper list" ls))))])
(error 'memq "not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
@ -219,13 +219,13 @@
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'memv "circular list ~s" ls)))
(error 'memv "circular list" ls)))
(if (null? h)
'#f
(error 'memv "~s is not a proper list" ls)))))
(error 'memv "not a proper list" ls)))))
(if (null? h)
'#f
(error 'memv "~s is not a proper list" ls))))])
(error 'memv "not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
@ -241,13 +241,13 @@
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'member "circular list ~s" ls)))
(error 'member "circular list" ls)))
(if (null? h)
'#f
(error 'member "~s is not a proper list" ls)))))
(error 'member "not a proper list" ls)))))
(if (null? h)
'#f
(error 'member "~s is not a proper list" ls))))])
(error 'member "not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
@ -264,16 +264,16 @@
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls p)
(error 'memp "circular list ~s" ls)))
(error 'memp "circular list" ls)))
(if (null? h)
'#f
(error 'memp "~s is not a proper list" ls)))))
(error 'memp "not a proper list" ls)))))
(if (null? h)
'#f
(error 'memp "~s is not a proper list" ls))))])
(error 'memp "not a proper list" ls))))])
(lambda (p ls)
(unless (procedure? p)
(error 'memp "~s is not a procedure" p))
(error 'memp "not a procedure" p))
(race ls ls ls p))))
(define find
@ -290,16 +290,16 @@
a
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls p)
(error 'find "circular list ~s" ls))))
(error 'find "circular list" ls))))
(if (null? h)
'#f
(error 'find "~s is not a proper list" ls))))))
(error 'find "not a proper list" ls))))))
(if (null? h)
'#f
(error 'find "~s is not a proper list" ls))))])
(error 'find "not a proper list" ls))))])
(lambda (p ls)
(unless (procedure? p)
(error 'find "~s is not a procedure" p))
(error 'find "not a procedure" p))
(race ls ls ls p))))
(define assq
@ -317,16 +317,16 @@
(if (eq? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assq "malformed alist ~s"
(error 'assq "malformed alist"
ls)))
(error 'assq "circular list ~s" ls))
(error 'assq "circular list" ls))
(if (null? h)
#f
(error 'assq "~s is not a proper list" ls))))
(error 'assq "malformed alist ~s" ls)))
(error 'assq "not a proper list" ls))))
(error 'assq "malformed alist" ls)))
(if (null? h)
#f
(error 'assq "~s is not a proper list" ls))))])
(error 'assq "not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
@ -346,19 +346,19 @@
(if (p ($car a))
a
(race p ($cdr h) ($cdr t) ls))
(error 'assp "malformed alist ~s"
(error 'assp "malformed alist"
ls)))
(error 'assp "circular list ~s" ls))
(error 'assp "circular list" ls))
(if (null? h)
#f
(error 'assp "~s is not a proper list" ls))))
(error 'assp "malformed alist ~s" ls)))
(error 'assp "not a proper list" ls))))
(error 'assp "malformed alist" ls)))
(if (null? h)
#f
(error 'assp "~s is not a proper list" ls))))])
(error 'assp "not a proper list" ls))))])
(lambda (p ls)
(unless (procedure? p)
(error 'assp "~s is not a procedure" p))
(error 'assp "not a procedure" p))
(race p ls ls ls))))
(define assv
@ -376,16 +376,16 @@
(if (eqv? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assv "malformed alist ~s"
(error 'assv "malformed alist"
ls)))
(error 'assv "circular list ~s" ls))
(error 'assv "circular list" ls))
(if (null? h)
#f
(error 'assv "~s is not a proper list" ls))))
(error 'assv "malformed alist ~s" ls)))
(error 'assv "not a proper list" ls))))
(error 'assv "malformed alist" ls)))
(if (null? h)
#f
(error 'assv "~s is not a proper list" ls))))])
(error 'assv "not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
@ -404,16 +404,16 @@
(if (equal? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assoc "malformed alist ~s"
(error 'assoc "malformed alist"
ls)))
(error 'assoc "circular list ~s" ls))
(error 'assoc "circular list" ls))
(if (null? h)
#f
(error 'assoc "~s is not a proper list" ls))))
(error 'assoc "malformed alist ~s" ls)))
(error 'assoc "not a proper list" ls))))
(error 'assoc "malformed alist" ls)))
(if (null? h)
#f
(error 'assoc "~s is not a proper list" ls))))])
(error 'assoc "not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
@ -433,23 +433,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 ~s" ls))
(error 'name "circular list" ls))
(if (null? h)
'()
(error 'name "~s is not a proper list" ls))))
(error '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 ~s" ls))
(error 'name "circular list" ls))
(if (null? h)
(list a0)
(error 'name "~s is not a proper list" ls)))))
(error 'name "not a proper list" ls)))))
(if (null? h)
'()
(error 'name "~s is not a proper list" ls))))])
(error 'name "not a proper list" ls))))])
(lambda (x ls)
(check x ls)
(race ls ls ls x))))]))
@ -459,11 +459,11 @@
(define-remover remp (lambda (elt p) (p elt))
(lambda (x ls)
(unless (procedure? x)
(error 'remp "~s is not a procedure" x))))
(error 'remp "not a procedure" x))))
(define-remover filter (lambda (elt p) (not (p elt)))
(lambda (x ls)
(unless (procedure? x)
(error 'filter "~s is not a procedure" x)))))
(error 'filter "not a procedure" x)))))
(module (map)
@ -558,7 +558,7 @@
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(cond
[(pair? ls)
(let ([d ($cdr ls)])
@ -567,7 +567,7 @@
[else (error who "improper list")])]
[(f ls ls2)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(cond
[(pair? ls)
(if (pair? ls2)
@ -581,7 +581,7 @@
[else (error who "not a list")])]
[(f ls . ls*)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(cond
[(pair? ls)
(let ([n (len ls ls 0)])
@ -648,7 +648,7 @@
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(cond
[(pair? ls)
(let ([d ($cdr ls)])
@ -657,7 +657,7 @@
[else (error who "improper list")])]
[(f ls ls2)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(cond
[(pair? ls)
(if (pair? ls2)
@ -672,23 +672,23 @@
[else (error who "not a list")])]
[(f ls . ls*)
(unless (procedure? f)
(error 'for-each "~s is not a procedure" f))
(error 'for-each "not a procedure" f))
(unless (list? ls)
(error 'for-each "~s is not a list" ls))
(error 'for-each "not a list" ls))
(let ([n (length ls)])
(for-each
(lambda (x)
(unless (and (list? x) (= (length x) n))
(error 'for-each "~s is not a list" x)))
(error '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 by ~s" f))]
(error 'for-each "list modified" f))]
[else
(unless (and (pair? ls) (andmap pair? ls*))
(error 'for-each "list modified by ~s" f))
(error 'for-each "list modified" f))
(apply f (car ls) (map car ls*))
(loop (fx- n 1) (cdr ls) (map cdr ls*))])))])))
@ -748,7 +748,7 @@
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(cond
[(pair? ls)
(let ([d ($cdr ls)])
@ -757,7 +757,7 @@
[else (error who "improper list")])]
[(f ls ls2)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(cond
[(pair? ls)
(if (pair? ls2)
@ -772,7 +772,7 @@
[else (error who "not a list")])]
[(f ls . ls*)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(error who "vararg not yet supported")])))
@ -811,7 +811,7 @@
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(cond
[(pair? ls)
(let ([d ($cdr ls)])
@ -829,7 +829,7 @@
(let ([a0 ($car h)] [h ($cdr h)])
(if (pair? h)
(if (eq? h t)
(error 'partition "circular list ~s" ls)
(error 'partition "circular list" ls)
(let ([a1 ($car h)])
(let-values ([(a* b*) (race ($cdr h) ($cdr t) ls p)])
(if (p a0)
@ -843,13 +843,13 @@
(if (p a0)
(values (list a0) '())
(values '() (list a0)))
(error 'parititon "~s is not a proper list" ls))))
(error 'parititon "not a proper list" ls))))
(if (null? h)
(values '() '())
(error 'parition "~s is not a proper list" ls))))])
(error 'parition "not a proper list" ls))))])
(lambda (p ls)
(unless (procedure? p)
(error 'partition "~s is not a procedure" p))
(error 'partition "not a procedure" p))
(race ls ls ls p))))
@ -866,7 +866,7 @@
(error who "length mismatch")
(if (list? (car ls*))
(err* (cdr ls*))
(error who "~s is not a proper list" (car ls*)))))
(error who "not a proper list" (car ls*)))))
(define (cars+cdrs ls ls*)
(cond
[(null? ls) (values '() '())]
@ -877,22 +877,22 @@
(values (cons (car a) cars) (cons (cdr a) cdrs)))
(if (list? (car ls*))
(error who "length mismatch")
(error who "~s is not a proper list" (car ls*)))))]))
(error 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 "~s is circular" ls)
(error 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 "~s is not a proper list" ls))))))
(combine (f b) (error who "not a proper list" ls))))))
(if (null? h)
(f a)
(combine (f a) (error who "~s is not a proper list" ls)))))
(combine (f a) (error 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*)])
@ -900,7 +900,7 @@
(combine (apply f a a*)
(if (pair? h)
(if (eq? h t)
(error who "~s is circular" ls)
(error who "circular" ls)
(let-values ([(c* h*) (cars+cdrs h* ls*)])
(let ([c (car h)] [h (cdr h)])
(combine (apply f b b*)
@ -915,15 +915,15 @@
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(if (pair? ls)
(loop1 f (car ls) (cdr ls) (cdr ls) ls)
(if (null? ls)
(combine)
(error who "~s is not a list" ls)))]
(error who "not a list" ls)))]
[(f ls . ls*)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error 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*))
@ -943,7 +943,7 @@
(error who "length mismatch")
(if (list? (car ls*))
(err* (cdr ls*))
(error who "~s is not a proper list" (car ls*)))))
(error who "not a proper list" (car ls*)))))
(define (cars+cdrs ls ls*)
(cond
[(null? ls) (values '() '())]
@ -954,28 +954,28 @@
(values (cons (car a) cars) (cons (cdr a) cdrs)))
(if (list? (car ls*))
(error who "length mismatch")
(error who "~s is not a proper list" (car ls*)))))]))
(error 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 "~s is circular" ls)
(error 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 "~s is not a proper list" ls))))
(error who "not a proper list" ls))))
(if (null? h)
nil
(error who "~s is not a proper list" ls))))
(error 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 "~s is circular" ls)
(error who "circular" ls)
(let-values ([(b* h*) (cars+cdrs h* ls*)])
(let ([b (car h)] [h (cdr h)] [t (cdr t)])
(loopn f
@ -991,11 +991,11 @@
(case-lambda
[(f nil ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(loop1 f nil ls ls ls)]
[(f nil ls . ls*)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(loopn f nil ls ls* ls ls ls*)])))
(module (fold-right)
@ -1007,7 +1007,7 @@
(error who "length mismatch")
(if (list? (car ls*))
(err* (cdr ls*))
(error who "~s is not a proper list" (car ls*)))))
(error who "not a proper list" (car ls*)))))
(define (cars+cdrs ls ls*)
(cond
[(null? ls) (values '() '())]
@ -1018,28 +1018,28 @@
(values (cons (car a) cars) (cons (cdr a) cdrs)))
(if (list? (car ls*))
(error who "length mismatch")
(error who "~s is not a proper list" (car ls*)))))]))
(error 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 "~s is circular" ls)
(error 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 "~s is not a proper list" ls))))
(error who "not a proper list" ls))))
(if (null? h)
nil
(error who "~s is not a proper list" ls))))
(error 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 "~s is circular" ls)
(error who "circular" ls)
(let-values ([(b* h*) (cars+cdrs h* ls*)])
(let ([b (car h)] [h (cdr h)] [t (cdr t)])
(apply f a
@ -1058,11 +1058,11 @@
(case-lambda
[(f nil ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(loop1 f nil ls ls ls)]
[(f nil ls . ls*)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(error who "not a procedure" f))
(loopn f nil ls ls* ls ls ls*)]
)))

4
scheme/ikarus.load.ss
View File

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

374
scheme/ikarus.numerics.ss
View File

File diff suppressed because it is too large Load Diff

6
scheme/ikarus.pairs.ss
View File

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

54
scheme/ikarus.posix.ss
View File

@ -24,13 +24,13 @@
(define waitpid
(lambda (pid)
(unless (fixnum? pid)
(error 'waitpid "~s is not a fixnum" pid))
(error 'waitpid "not a fixnum" pid))
(foreign-call "ikrt_waitpid" pid)))
(define system
(lambda (x)
(unless (string? x)
(error 'system "~s is not a string" x))
(error 'system "not a string" x))
(let ([rv (foreign-call "ik_system"
(string->utf8 x))])
(if (fx= rv -1)
@ -40,7 +40,7 @@
(define file-exists?
(lambda (x)
(unless (string? x)
(error 'file-exists? "filename ~s is not a string" x))
(error 'file-exists? "filename is not a string" x))
(let ([v (foreign-call "ikrt_file_exists"
(string->utf8 x))])
(cond
@ -48,19 +48,19 @@
[else
(error 'file-exists?
(case v
[(1) "the path ~s contains a non-directory"]
[(2) "the path ~s is too long"]
[(3) "the path ~s is not accessible"]
[(4) "the path ~s contains too many symbolic links"]
[(5) "internal access error while accessing ~s"]
[(6) "IO error encountered while accessing ~s"]
[else "Unknown error in ~s"])
[(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"])
x)]))))
(define delete-file
(lambda (x)
(unless (string? x)
(error 'delete-file "filename ~s is not a string" x))
(error 'delete-file "filename is not a string" x))
(let ([v (foreign-call "ikrt_delete_file"
(string->utf8 x))])
(case v
@ -68,17 +68,17 @@
[else
(error 'delete-file
(case v
[(1) "the path ~s contains a non-directory"]
[(2) "the path ~s is too long"]
[(3) "the file ~s does not exist"]
[(4) "the path ~s is not accessible"]
[(5) "the path ~s contains too many symbolic links"]
[(6) "you do not have permissions to delete ~s"]
[(7) "device ~s is busy"]
[(8) "IO error encountered while deleting ~s"]
[(9) "~s is in a read-only file system"]
[(10) "internal access error while deleting ~s"]
[else "Unknown error while deleting ~s"])
[(1) "the path contains a non-directory"]
[(2) "the path is too long"]
[(3) "the file does not exist"]
[(4) "the path is not accessible"]
[(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"]
[(9) "is in a read-only file system"]
[(10) "internal access error while deleting"]
[else "Unknown error while deleting"])
x)]))))
(define env
@ -88,16 +88,16 @@
[(key)
(if (string? key)
(foreign-call "ikrt_getenv" key)
(error 'env "the key: ~s is not a string" key))]
(error '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 to set ~s to ~s" key val))
(error 'env "the value: ~s is not a string" val))
(error 'env "the key: ~s is not a string" key))]))
(define busted (lambda args (error 'env "busted!")))
(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!")))
busted))

18
scheme/ikarus.predicates.ss
View File

@ -109,7 +109,7 @@
[(sys:ratnum? x) #t]
[(sys:flonum? x) #f]
[else
(error 'exact? "~s is not a number" x)])))
(error 'exact? "not a number" x)])))
(define inexact?
@ -120,7 +120,7 @@
[(sys:bignum? x) #f]
[(sys:ratnum? x) #f]
[else
(error 'inexact? "~s is not a number" x)])))
(error 'inexact? "not a number" x)])))
(define finite?
(lambda (x)
@ -130,7 +130,7 @@
[(sys:bignum? x) #t]
[(sys:ratnum? x) #t]
[else
(error 'finite? "~s is not a number" x)])))
(error 'finite? "not a number" x)])))
(define infinite?
(lambda (x)
@ -140,7 +140,7 @@
[(sys:bignum? x) #f]
[(sys:ratnum? x) #f]
[else
(error 'infinite? "~s is not a number" x)])))
(error 'infinite? "not a number" x)])))
(define nan?
(lambda (x)
@ -150,7 +150,7 @@
[(sys:bignum? x) #f]
[(sys:ratnum? x) #f]
[else
(error 'nan? "~s is not a number" x)])))
(error 'nan? "not a number" x)])))
@ -191,8 +191,8 @@
#t
(if (sys:boolean? y)
#f
(error 'boolean=? "~s is not a boolean" y)))
(error 'boolean=? "~s is not a boolean" x))))
(error 'boolean=? "not a boolean" y)))
(error 'boolean=? "not a boolean" x))))
(define symbol=?
@ -202,8 +202,8 @@
#t
(if (sys:symbol? y)
#f
(error 'symbol=? "~s is not a symbol" y)))
(error 'symbol=? "~s is not a symbol" x))))
(error 'symbol=? "not a symbol" y)))
(error 'symbol=? "not a symbol" x))))
(module (equal?)
(define vector-loop

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

@ -26,7 +26,7 @@
[(mbox? x) (mbox-length x)]
[(vbox? x) (vbox-length x)]
[(fbox? x) (fbox-length x)]
[else (error 'boxify "invalid box ~s" x)]))
[else (error 'boxify "invalid box" x)]))
(define (boxify x)
(define (conc . a*)
(let ([n
@ -437,7 +437,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 ~s" x)]))
[else (error 'pretty-print-output "invalid" x)]))
(f x p 0)
(newline p))
;;;
@ -586,7 +586,7 @@
[(x p)
(if (output-port? p)
(pretty x p)
(error 'pretty-print "~s is not an output port" p))]))
(error 'pretty-print "not an output port" p))]))
(set-fmt! 'quote '(read-macro . "'"))
(set-fmt! 'unquote '(read-macro . ","))
(set-fmt! 'unquote-splicing '(read-macro . ",@"))
@ -648,7 +648,7 @@
[(x p)
(if (output-port? p)
(pretty x p)
(error 'pretty-print "~s is not an output port" p))])))
(error 'pretty-print "not an output port" p))])))
(test '(384 7384 83947 893478 9137489 3894789 134789314 79817238
97314897 318947138974 981374 89137489 1374897 13498713
@ -679,5 +679,5 @@
(with-input-from-file fname read))])
(if (equal? x y)
(f (fxadd1 i))
(error 'test-file "mismatch\n\n~s\n\n~s" x y)))))))))
(error 'test-file "mismatch" x y)))))))))

4
scheme/ikarus.promises.ss
View File

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

124
scheme/ikarus.reader.ss
View File

@ -59,7 +59,7 @@
ls]
[else
(unread-char c p)
(error 'tokenize "invalid identifier syntax: ~a"
(error 'tokenize "invalid identifier syntax"
(list->string (reverse (cons c ls))))]))))
(define tokenize-string
(lambda (ls p)
@ -95,12 +95,12 @@
(cons (integer->char n) ls) p)]
[else
(error 'tokenize
"invalid char ~a in escape sequence"
"invalid char in escape sequence"
c)]))))]
[else
(error 'tokenize
"invalid char ~a in escape sequence" c)]))]
[else (error 'tokenize "invalid string escape \\~a" c)]))]
"invalid char in escape sequence" c)]))]
[else (error 'tokenize "invalid string escape" c)]))]
[else
(tokenize-string (cons c ls) p)]))))
(define skip-comment
@ -128,10 +128,12 @@
[(eof-object? c) '(datum . ...)]
[(delimiter? c) '(datum . ...)]
[else
(error 'tokenize "invalid syntax ...~a" c)]))]
(error 'tokenize "invalid syntax"
(string-append "..." (string c)))]))]
[else
(unread-char c p)
(error 'tokenize "invalid syntax ..~a" c)]))]
(error 'tokenize "invalid syntax"
(string-append ".." (string c)))]))]
[else
(cons 'datum
(tokenize-decimal-no-digits p '(#\.) #f))]))))
@ -143,17 +145,19 @@
(cond
[(eof-object? c) d]
[(delimiter? c) d]
[else (error 'tokenize "invalid character after #\\~a" str)]))]
[else (error '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 #\\~a" str)]
(error '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
"invalid char ~a while scanning #\\~a" c str)]))])))
"invalid char while scanning string"
c str)]))])))
(define tokenize-char-seq
(lambda (p str d)
(let ([c (peek-char p)])
@ -163,7 +167,7 @@
[($char= (string-ref str 1) c)
(read-char p)
(tokenize-char* 2 str p d)]
[else (error 'tokenize "invalid syntax near #\\~a~a"
[else (error 'tokenize "invalid syntax"
(string-ref str 0) c)]))))
(define tokenize-char
(lambda (p)
@ -201,14 +205,16 @@
[else
(error 'tokenize "invalid character sequence")]))))]
[else
(error 'tokenize "invalid character sequence #\\x~a" n)]))]
(error 'tokenize "invalid character sequence"
(string-append "#\\" (string n)))]))]
[else
(let ([n (peek-char p)])
(cond
[(eof-object? n) (cons 'datum c)]
[(delimiter? n) (cons 'datum c)]
[else
(error 'tokenize "invalid syntax #\\~a~a" c n)]))]))))
(error 'tokenize "invalid syntax"
(string-append "#\\" (string c n)))]))]))))
(define (hex x)
(cond
[(and ($char<= #\0 x) ($char<= x #\9))
@ -265,7 +271,7 @@
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof insize ~a" caller)]
(error 'tokenize "invalid eof inside" caller)]
[(char-whitespace? c)
(skip-whitespace p caller)]
[else c])))
@ -278,13 +284,15 @@
(cond
[(eof-object? c) '(datum . #t)]
[(delimiter? c) '(datum . #t)]
[else (error 'tokenize "invalid syntax near #~a" c)]))]
[else (error '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 "invalid syntax near #~a" c)]))]
[else (error 'tokenize
(format "invalid syntax near #~a" c))]))]
[($char= #\\ c) (tokenize-char p)]
[($char= #\( c) 'vparen]
[($char= #\' c) '(macro . syntax)]
@ -303,17 +311,20 @@
(when (eof-object? e)
(error 'tokenize "invalid eof near #!"))
(unless ($char= #\e e)
(error 'tokenize "invalid syntax near #!~a" e))
(error 'tokenize
(format "invalid syntax near #!~a" e)))
(let ([o (read-char p)])
(when (eof-object? o)
(error 'tokenize "invalid eof near #!e"))
(unless ($char= #\o o)
(error 'tokenize "invalid syntax near #!e~a" o))
(error 'tokenize
(format "invalid syntax near #!e~a" o)))
(let ([f (read-char p)])
(when (eof-object? f)
(error 'tokenize "invalid syntax near #!eo"))
(unless ($char= #\f f)
(error 'tokenize "invalid syntax near #!eo~a" f))
(error 'tokenize
(format "invalid syntax near #!eo~a" f)))
(cons 'datum (eof-object)))))]
[(digit? c)
(tokenize-hashnum p (char->num c))]
@ -329,7 +340,7 @@
(reverse (tokenize-bar p '())))]
[else
(error 'tokenize
"invalid char ~a inside gensym" c)])])
"invalid char inside gensym" c)])])
(cons 'datum (gensym id0)))]
[($char= #\{ c)
(let* ([c (skip-whitespace p "gensym")]
@ -343,7 +354,7 @@
(reverse (tokenize-bar p '())))]
[else
(error 'tokenize
"invalid char ~a inside gensym" c)])]
"invalid char inside gensym" c)])]
[c (skip-whitespace p "gensym")])
(cond
[($char= #\} c)
@ -361,7 +372,7 @@
(reverse (tokenize-bar p '())))]
[else
(error 'tokenize
"invalid char ~a inside gensym" c)])])
"invalid char inside gensym" c)])])
(let ([c (skip-whitespace p "gensym")])
(cond
[($char= #\} c)
@ -370,7 +381,7 @@
id0 id1))]
[else
(error 'tokenize
"invalid char ~a inside gensym" c)])))]))]
"invalid char inside gensym" c)])))]))]
[($char= #\v c)
(let ([c (read-char p)])
(cond
@ -383,13 +394,16 @@
[($char= c #\() 'vu8]
[(eof-object? c)
(error 'tokenize "invalid eof object after #vu8")]
[else (error 'tokenize "invalid sequence #vu8~a" c)]))]
[else (error 'tokenize
(format "invalid sequence #vu8~a" c))]))]
[(eof-object? c)
(error 'tokenize "invalid eof object after #vu")]
[else (error 'tokenize "invalid sequence #vu~a" c)]))]
[else (error 'tokenize
(format "invalid sequence #vu~a" c))]))]
[(eof-object? c)
(error 'tokenize "invalid eof object after #v")]
[else (error 'tokenize "invalid sequence #v~a" c)]))]
[else (error 'tokenize
(format "invalid sequence #v~a" c))]))]
[(memq c '(#\e #\E))
(cons 'datum (tokenize-exactness-mark p (list c #\#) 'e))]
[(memq c '(#\i #\I))
@ -407,7 +421,8 @@
'(cons 'datum ($fasl-read p))]
[else
(unread-char c p)
(error 'tokenize "invalid syntax #~a" c)])))
(error 'tokenize
(format "invalid syntax #~a" c))])))
(define (tokenize-exactness-mark p ls exact?)
(let ([c (read-char p)])
(cond
@ -630,7 +645,7 @@
[(#\0) 0]
[(#\1) 1]
[else #f])]
[else (error 'radix-digit "invalid radix ~s" radix)]))
[else (error 'radix-digit "invalid radix" radix)]))
(define (read-char* p ls str who)
(let f ([i 0] [ls ls])
(let ([c (read-char p)])
@ -641,18 +656,21 @@
[(delimiter? c) (unread-char c p)]
[else
(unread-char c p)
(error 'tokenize "invalid ~a: ~s" who
(list->string (reverse (cons c ls))))])]
(error 'tokenize
(format "invalid ~a: ~s" who
(list->string (reverse (cons c ls)))))])]
[else
(cond
[(eof-object? c)
(error 'tokenize "invalid eof inside ~a" who)]
(error 'tokenize
(format "invalid eof inside ~a" who))]
[(char=? c (string-ref str i))
(f (add1 i) (cons c ls))]
[else
(unread-char c p)
(error 'tokenize "invalid ~a: ~s" who
(list->string (reverse (cons c ls))))])]))))
(error 'tokenize
(format "invalid ~a: ~s" who
(list->string (reverse (cons c ls)))))])]))))
(define (tokenize-integer/nan/inf-no-digits p ls)
(let ([c (read-char p)])
(cond
@ -682,7 +700,7 @@
(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 ~a"
(error 'read "invalid numeric sequence"
(list->string (reverse ls))))
(define (tokenize-hashnum p n)
(let ([c (read-char p)])
@ -695,7 +713,7 @@
(tokenize-hashnum p (fx+ (fx* n 10) (char->num c)))]
[else
(unread-char c p)
(error 'tokenize "invalid char ~a while inside a #n mark/ref" c)])))
(error 'tokenize "invalid char while inside a #n mark/ref" c)])))
(define tokenize-bar
(lambda (p ac)
(let ([c (read-char p)])
@ -726,8 +744,9 @@
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof after ~a"
(list->string (reverse ac)))]
(error 'tokenize
(format "invalid eof after ~a"
(list->string (reverse ac))))]
[($char= #\; c)
(cons 'datum
(string->symbol
@ -738,14 +757,16 @@
(lambda (v0)
(f (+ (* v 16) v0) (cons c ac)))]
[else
(error 'tokenize "invalid sequence ~a"
(error 'tokenize "invalid sequence"
(list->string (cons c (reverse ac))))]))))]
[else
(unread-char c p)
(error 'tokenize "invalid sequence \\x~a" c)]))]
(error 'tokenize
(format "invalid sequence \\x~a" c))]))]
[else
(unread-char c p)
(error 'tokenize "invalid sequence \\~a" c)])))
(error 'tokenize
(format "invalid sequence \\~a" c))])))
(define tokenize/c
(lambda (c p)
(cond
@ -809,7 +830,7 @@
(tokenize-backslash p)]
[else
(unread-char c p)
(error 'tokenize "invalid syntax ~a" c)])))
(error 'tokenize "invalid syntax" c)])))
(define tokenize
(lambda (p)
@ -851,7 +872,8 @@
[(eq? t 'dot)
(error 'read "cannot have two dots in a list")]
[else
(error 'read "expecting ~a, got ~a" end t)])))]
(error 'read
(format "expecting ~a, got ~a" end t))])))]
[(eq? t 'hash-semi)
(let-values ([(ignored locs k) (read-expr p locs k)])
(read-list-rest p locs k end mis))]
@ -918,10 +940,11 @@
(cond
[(fixnum? a)
(unless (and (fx<= 0 a) (fx<= a 255))
(error 'read "invalid value ~s in a bytevector" a))
(error '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 ~s is a bytevector" a)]))])))
[else (error 'read "invalid value inside a bytevector" a)]))])))
(define read-vector
(lambda (p locs k count ls)
(let ([t (tokenize p)])
@ -994,7 +1017,7 @@
(lambda (x)
(let ([loc (cdr x)])
(when (loc-set? loc)
(error 'read "duplicate mark ~s" n))
(error 'read "duplicate mark" n))
(set-loc-value! loc expr)
(set-loc-set?! loc #t)
(values expr locs k)))]
@ -1012,9 +1035,10 @@
(let ([loc (make-loc #f #f)])
(let ([locs (cons (cons n loc) locs)])
(values loc locs k)))]))]
[else (error 'read "invalid token! ~s" t)])]
[else (error 'read "invalid token" t)])]
[else
(error 'read "unexpected ~s found" t)])))
(error 'read
(format "unexpected ~s found" t))])))
(define read-expr
(lambda (p locs k)
@ -1028,7 +1052,7 @@
(lambda (x)
(let ([loc (cdr x)])
(unless (loc-set? loc)
(error 'read "referenced mark ~s not set" (car x)))
(error 'read "referenced mark is not set" (car x)))
(when (loc? (loc-value loc))
(let f ([h loc] [t loc])
(if (loc? h)
@ -1076,7 +1100,7 @@
[(p)
(if (input-port? p)
(tokenize p)
(error 'read-token "~s is not an input port" p))]))
(error 'read-token "not an input port" p))]))
(define read
(case-lambda
@ -1084,14 +1108,14 @@
[(p)
(if (input-port? p)
(my-read p)
(error 'read "~s is not an input port" p))]))
(error 'read "not an input port" p))]))
(define comment-handler
(make-parameter
(lambda (x) (void))
(lambda (x)
(unless (procedure? x)
(error 'comment-handler "~s is not a procedure" x))
(error 'comment-handler "not a procedure" x))
x)))
)

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

@ -40,7 +40,7 @@
(define (record-rtd x)
(define (err x)
(error 'record-rtd "~s is not a record" x))
(error 'record-rtd "not a record" x))
(if ($struct? x)
(let ([rtd ($struct-rtd x)])
(if (rtd? rtd)
@ -53,32 +53,32 @@
(define (record-type-name x)
(if (rtd? x)
(rtd-name x)
(error 'record-type-name "~s is not an rtd" x)))
(error 'record-type-name "not an rtd" x)))
(define (record-type-parent x)
(if (rtd? x)
(rtd-parent x)
(error 'record-type-parent "~s is not an rtd" x)))
(error 'record-type-parent "not an rtd" x)))
(define (record-type-uid x)
(if (rtd? x)
(rtd-uid x)
(error 'record-type-uid "~s is not an rtd" x)))
(error 'record-type-uid "not an rtd" x)))
(define (record-type-sealed? x)
(if (rtd? x)
(rtd-sealed? x)
(error 'record-type-sealed? "~s is not an rtd" x)))
(error 'record-type-sealed? "not an rtd" x)))
(define (record-type-opaque? x)
(if (rtd? x)
(rtd-opaque? x)
(error 'record-type-opaque? "~s is not an rtd" x)))
(error 'record-type-opaque? "not an rtd" x)))
(define (record-type-generative? x)
(if (rtd? x)
(not (rtd-sealed? x))
(error 'record-type-generative? "~s is not an rtd" x)))
(error 'record-type-generative? "not an rtd" x)))
(define (record-type-field-names x)
(if (rtd? x)
@ -90,7 +90,7 @@
(begin
(vector-set! x i (cdr (vector-ref v i)))
(f x v n (fxadd1 i)))))))
(error 'record-type-field-names "~s is not an rtd" x)))
(error 'record-type-field-names "not an rtd" x)))
(module (make-record-type-descriptor)
@ -101,7 +101,7 @@
#f #f #f parent sealed? opaque? uid fields))
(define (convert-fields sv)
(unless (vector? sv)
(error who "invalid fields argument ~s" sv))
(error who "invalid fields argument" sv))
(let ([n2 (vector-length sv)])
(let ([v (make-vector n2)])
(let f ([i 0])
@ -112,16 +112,16 @@
(if (pair? x)
(let ([name (car x)])
(unless (and (null? (cdr x)) (symbol? name))
(error who "invalid fields argument ~s" sv))
(error who "invalid fields argument" sv))
(vector-set! v i
(cons (case m/u
[(mutable) #t]
[(immutable) #f]
[else
(error who "invalid fields argument ~s" sv)])
(error who "invalid fields argument" sv)])
name)))
(error who "invalid fields argument ~s" sv)))
(error who "invalid fields argument ~s" sv)))
(error who "invalid fields argument" sv)))
(error who "invalid fields argument" sv)))
(f (add1 i))))
v)))
(define generate-rtd
@ -129,7 +129,7 @@
(cond
[(rtd? parent)
(when (rtd-sealed? parent)
(error who "cannot extend sealed parent ~s" parent))
(error who "cannot extend sealed parent" parent))
(make-rtd-aux name parent uid sealed?
(or opaque? (rtd-opaque? parent))
(rtd-size parent)
@ -137,7 +137,7 @@
[(eqv? parent #f)
(make-rtd-aux name parent uid sealed? opaque? 0
(convert-fields fields))]
[else (error who "~s is not a valid parent" parent)])))
[else (error who "not a valid parent" parent)])))
(define (same-fields-as-rtd? fields rtd)
(let* ([fv (rtd-fields rtd)]
[n (vector-length fv)])
@ -178,17 +178,17 @@
(define make-record-type-descriptor
(lambda (name parent uid sealed? opaque? fields)
(unless (symbol? name)
(error who "~s is not a valid record type name" name))
(error who "not a valid record type name" name))
(unless (boolean? sealed?)
(error who "~s is not a valid sealed? argument" sealed?))
(error who "not a valid sealed? argument" sealed?))
(unless (boolean? opaque?)
(error who "~s is not a valid opaque? argument" opaque?))
(error 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 "~s is not a valid uid" uid)]))))
[else (error who "not a valid uid" uid)]))))
(define-struct rcd (rtd prcd proc))
@ -201,9 +201,9 @@
(define (rtd-subtype? rtd parent-rtd)
(unless (rtd? rtd)
(error 'rtd-subtype? "~s is not an rtd" rtd))
(error 'rtd-subtype? "not an rtd" rtd))
(unless (rtd? parent-rtd)
(error 'rtd-substype? "~s is not an rtd" parent-rtd))
(error 'rtd-substype? "not an rtd" parent-rtd))
(or (eq? rtd parent-rtd)
(is-parent-of? parent-rtd rtd)))
@ -211,20 +211,20 @@
(lambda (rtd prcd protocol)
(define who 'make-record-constructor-descriptor)
(unless (rtd? rtd)
(error who "~s is not a record type descriptor" rtd))
(error who "not a record type descriptor" rtd))
(unless (or (not protocol) (procedure? protocol))
(error who "invalid protocol ~s" protocol))
(error 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 ~s does not apply to ~s"
(error who "descriptor does not apply"
prcd rtd))
(make-rcd rtd prcd protocol)]
[else
(error who "~s is not a valid record constructor descriptor" prcd)]))))
(error who "not a valid record constructor descriptor" prcd)]))))
(define (record-constructor rcd)
(define who 'record-constructor)
@ -235,7 +235,7 @@
(let ([n (rtd-size main-rtd)])
(unless (= (length flds) size)
(error 'record-constructor
"expecting ~s args, got ~s" n flds))
"expecting args, got" n flds))
(let ([r ($make-struct main-rtd n)])
(let f ([i 0] [r r] [flds flds] [f* f*])
(cond
@ -258,15 +258,15 @@
(lambda flds
(unless (= (length flds) n)
(error 'record-constructor
"expecting ~s args, got ~s" n flds))
"expecting args, got" n flds))
(apply (p (cons flds f*)) fmls))))
(lambda flds
(unless (= (length flds) n)
(error 'record-constructor
"expecting ~s args, got ~s" n flds))
"expecting args, got" n flds))
((p (cons flds f*))))))))))
(unless (rcd? rcd)
(error who "~s is not a record constructor descriptor" rcd))
(error who "not a record constructor descriptor" rcd))
(let ([rtd (rcd-rtd rcd)]
[prcd (rcd-prcd rcd)]
[proto (rcd-proc rcd)])
@ -276,61 +276,61 @@
(define (record-accessor rtd k)
(define who 'record-accessor)
(unless (rtd? rtd)
(error who "~s is not an rtd" rtd))
(error who "not an rtd" rtd))
(unless (and (fixnum? k) (fx>= k 0))
(error who "~s is not a valid index" k))
(error 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 "~s is not a valid index" k))
(error who "not a valid index" k))
(lambda (x)
(cond
[($struct/rtd? x rtd) ($struct-ref x i)]
[($struct? x)
(let ([xrtd ($struct-rtd x)])
(unless (rtd? xrtd)
(error who "~s is not of type ~s" x rtd))
(error 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 "~s is not of type ~s" x rtd)]
(error who "invalid type" x rtd)]
[else (f (rtd-parent prtd) rtd x i)])))]
[else (error who "~s is not of type ~s" x rtd)])))))
[else (error who "invalid type" x rtd)])))))
(define (record-mutator rtd k)
(define who 'record-mutator)
(unless (rtd? rtd)
(error who "~s is not an rtd" rtd))
(error who "not an rtd" rtd))
(unless (and (fixnum? k) (fx>= k 0))
(error who "~s is not a valid index" k))
(error 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 "~s is not a valid index" k))
(error who "not a valid index" k))
(unless (car (vector-ref (rtd-fields rtd) k))
(error who "field ~s of ~s is not mutable" k rtd))
(error who "field is not mutable" k rtd))
(lambda (x v)
(cond
[($struct/rtd? x rtd) ($struct-set! x i v)]
[($struct? x)
(let ([xrtd ($struct-rtd x)])
(unless (rtd? xrtd)
(error who "~s is not of type ~s" x rtd))
(error 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 "~s is not of type ~s" x rtd)]
(error who "invalid type" x rtd)]
[else (f (rtd-parent prtd) rtd x i v)])))]
[else (error who "~s is not of type ~s" x rtd)])))))
[else (error who "invalid type" x rtd)])))))
(define (record-predicate rtd)
(define who 'record-predicate)
(unless (rtd? rtd)
(error who "~s is not an rtd" rtd))
(error who "not an rtd" rtd))
(let ([sz (rtd-size rtd)]
[p (rtd-parent rtd)])
(lambda (x)
@ -350,14 +350,14 @@
(define (record-field-mutable? rtd k)
(define who 'record-field-mutable?)
(unless (rtd? rtd)
(error who "~s is not an rtd" rtd))
(error who "not an rtd" rtd))
(unless (and (fixnum? k) (fx>= k 0))
(error who "~s is not a valid index" k))
(error 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 "~s is not a valid index" k))
(error 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

@ -61,23 +61,23 @@
(define (list-sort <? ls)
(unless (procedure? <?)
(error 'list-sort "~s is not a procedure" <?))
(error 'list-sort "not a procedure" <?))
(sort-tail <? ls (length ls)))
(define (vector-sort <? v)
;;; FIXME: improve
(unless (procedure? <?)
(error 'vector-sort "~s is not a procedure" <?))
(error 'vector-sort "not a procedure" <?))
(unless (vector? v)
(error 'vector-sort "~s is not a vector" v))
(error 'vector-sort "not a vector" v))
(list->vector
(sort-tail <? (vector->list v) (vector-length v))))
(define (vector-sort! <? v)
(unless (procedure? <?)
(error 'vector-sort! "~s is not a procedure" <?))
(error 'vector-sort! "not a procedure" <?))
(unless (vector? v)
(error 'vector-sort! "~s is not a vector" v))
(error 'vector-sort! "not a vector" v))
(let f ([i 0] [v v]
[ls (sort-tail <? (vector->list v) (vector-length v))])
(unless (null? ls)

96
scheme/ikarus.strings.ss
View File

@ -20,18 +20,18 @@
(define string-length
(lambda (x)
(unless (string? x)
(error 'string-length "~s is not a string" x))
(error 'string-length "not a string" x))
($string-length x)))
(define (string-ref s i)
(unless (string? s)
(error 'string-ref "~s is not a string" s))
(error 'string-ref "not a string" s))
(unless (fixnum? i)
(error 'string-ref "~s is not a valid index" i))
(error 'string-ref "not a valid index" i))
(unless (and ($fx< i ($string-length s))
($fx<= 0 i))
(error 'string-ref "index ~s is out of range for ~s" i s))
(error '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"))
@ -41,14 +41,14 @@
(define string-set!
(lambda (s i c)
(unless (string? s)
(error 'string-set! "~s is not a string" s))
(error 'string-set! "not a string" s))
(unless (fixnum? i)
(error 'string-set! "~s is not a valid index" i))
(error 'string-set! "not a valid index" i))
(unless (and ($fx< i ($string-length s))
($fx>= i 0))
(error 'string-set! "index ~s is out of range for ~s" i s))
(error 'string-set! "index is out of range" i s))
(unless (char? c)
(error 'string-set! "~s is not a character" c))
(error 'string-set! "not a character" c))
($string-set! s i c)))
(define make-string
@ -64,13 +64,13 @@
(case-lambda
[(n)
(unless (and (fixnum? n) (fx>= n 0))
(error 'make-string "~s is not a valid length" n))
(error '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 "~s is not a valid length" n))
(error 'make-string "not a valid length" n))
(unless (char? c)
(error 'make-string "~s is not a character" c))
(error 'make-string "not a character" c))
(fill! ($make-string n) 0 n c)]))
make-string))
@ -82,7 +82,7 @@
(cond
[(null? ls) n]
[(char? ($car ls)) (length ($cdr ls) ($fx+ n 1))]
[else (error 'string "~s is not a character" ($car ls))]))]
[else (error 'string "not a character" ($car ls))]))]
[loop
(lambda (s ls i n)
(cond
@ -106,16 +106,16 @@
(define substring
(lambda (s n m)
(unless (string? s)
(error 'substring "~s is not a string" s))
(error 'substring "not a string" s))
(let ([len ($string-length s)])
(unless (and (fixnum? n)
($fx>= n 0)
($fx< n len))
(error 'substring "~s is not a valid start index for ~s" n s))
(error 'substring "not a valid start index" n s))
(unless (and (fixnum? m)
($fx>= m 0)
($fx<= m len))
(error 'substring "~s is not a valid end index for ~s" m s))
(error 'substring "not a valid end index" m s))
(let ([len ($fx- m n)])
(if ($fx<= len 0)
""
@ -125,7 +125,7 @@
(lambda (s)
(if (string? s)
(substring s 0 (string-length s))
(error 'string-copy "~s is not a string" s))))
(error 'string-copy "not a string" s))))
(module (string=?)
(define bstring=?
@ -145,13 +145,13 @@
(or (null? s*)
(let ([a ($car s*)])
(unless (string? a)
(error 'string=? "~s is not a string" a))
(error '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=? "~s is not a string" x))
(error 'string=? "not a string" x))
(define string=?
(case-lambda
[(s s1)
@ -185,10 +185,10 @@
[(string? (car s*))
(f (cdr s*))]
[else
(error who "~s is not a string"
(error who "not a string"
(car s*))]))))
(error who "~s is not a string" s2))])))
(error who "~s is not a string" s1)))
(error who "not a string" s2))])))
(error who "not a string" s1)))
(define ($string<? s1 s2)
(let ([n1 ($string-length s1)]
@ -252,8 +252,8 @@
(if (string? s1)
(if (string? s2)
($string<? s1 s2)
(error 'string<? "~s is not a string" s2))
(error 'string<? "~s is not a string" s2))]
(error 'string<? "not a string" s2))
(error 'string<? "not a string" s2))]
[(s . s*)
(string-cmp 'string<? $string<? s s*)]))
@ -263,8 +263,8 @@
(if (string? s1)
(if (string? s2)
($string<=? s1 s2)
(error 'string<=? "~s is not a string" s2))
(error 'string<=? "~s is not a string" s2))]
(error 'string<=? "not a string" s2))
(error 'string<=? "not a string" s2))]
[(s . s*)
(string-cmp 'string<=? $string<=? s s*)]))
@ -274,8 +274,8 @@
(if (string? s1)
(if (string? s2)
($string>? s1 s2)
(error 'string>? "~s is not a string" s2))
(error 'string>? "~s is not a string" s2))]
(error 'string>? "not a string" s2))
(error 'string>? "not a string" s2))]
[(s . s*)
(string-cmp 'string>? $string>? s s*)]))
@ -285,15 +285,15 @@
(if (string? s1)
(if (string? s2)
($string>=? s1 s2)
(error 'string>=? "~s is not a string" s2))
(error 'string>=? "~s is not a string" s2))]
(error 'string>=? "not a string" s2))
(error 'string>=? "not a string" s2))]
[(s . s*)
(string-cmp 'string>=? $string>=? s s*)]))
(define string->list
(lambda (x)
(unless (string? x)
(error 'string->list "~s is not a string" x))
(error 'string->list "not a string" x))
(let f ([x x] [i ($string-length x)] [ac '()])
(cond
[($fxzero? i) ac]
@ -310,13 +310,13 @@
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'reverse "circular list ~s" ls))
(error 'reverse "circular list" ls))
(if (null? h)
($fx+ n 1)
(error 'reverse "~s is not a proper list" ls))))
(error 'reverse "not a proper list" ls))))
(if (null? h)
n
(error 'reverse "~s is not a proper list" ls))))]
(error 'reverse "not a proper list" ls))))]
[fill
(lambda (s i ls)
(cond
@ -324,7 +324,7 @@
[else
(let ([c ($car ls)])
(unless (char? c)
(error 'list->string "~s is not a character" c))
(error 'list->string "not a character" c))
($string-set! s i c)
(fill s ($fxadd1 i) (cdr ls)))]))])
(lambda (ls)
@ -341,7 +341,7 @@
[else
(let ([a ($car s*)])
(unless (string? a)
(error 'string-append "~s is not a string" a))
(error 'string-append "not a string" a))
(length* ($cdr s*) ($fx+ n ($string-length a))))])))
(define fill-string
(lambda (s a si sj ai)
@ -371,9 +371,9 @@
(case-lambda
[(p v)
(unless (procedure? p)
(error who "~s is not a procedure" p))
(error who "not a procedure" p))
(unless (string? v)
(error who "~s is not a string" v))
(error who "not a string" v))
(let f ([p p] [v v] [i 0] [n (string-length v)])
(cond
[($fx= i n) (void)]
@ -382,14 +382,14 @@
(f p v ($fxadd1 i) n)]))]
[(p v0 v1)
(unless (procedure? p)
(error who "~s is not a procedure" p))
(error who "not a procedure" p))
(unless (string? v0)
(error who "~s is not a string" v0))
(error who "not a string" v0))
(unless (string? v1)
(error who "~s is not a string" v1))
(error who "not a string" v1))
(let ([n (string-length v0)])
(unless ($fx= n ($string-length v1))
(error who "length mismatch between ~s and ~s" v0 v1))
(error who "length mismatch" v0 v1))
(let f ([p p] [v0 v0] [v1 v1] [i 0] [n n])
(cond
[($fx= i n) (void)]
@ -398,19 +398,19 @@
(f p v0 v1 ($fxadd1 i) n)])))]
[(p v0 v1 . v*)
(unless (procedure? p)
(error who "~s is not a procedure" p))
(error who "not a procedure" p))
(unless (string? v0)
(error who "~s is not a string" v0))
(error who "not a string" v0))
(unless (string? v1)
(error who "~s is not a string" v1))
(error who "not a string" v1))
(let ([n (string-length v0)])
(unless ($fx= n ($string-length v1))
(error who "length mismatch between ~s and ~s" v0 v1))
(error who "length mismatch" v0 v1))
(let f ([v* v*] [n n])
(unless (null? v*)
(let ([a ($car v*)])
(unless (string? a)
(error who "~s is not a string" a))
(error who "not a string" a))
(unless ($fx= ($string-length a) n)
(error who "length mismatch")))
(f ($cdr v*) n)))
@ -428,9 +428,9 @@
(define (string-fill! v fill)
(unless (string? v)
(error 'string-fill! "~s is not a vector" v))
(error 'string-fill! "not a vector" v))
(unless (char? fill)
(error 'string-fill! "~s is not a character" fill))
(error '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)

62
scheme/ikarus.structs.ss
View File

@ -74,7 +74,7 @@
(define verify-field
(lambda (x)
(unless (symbol? x)
(error 'make-struct-type "~s is not a valid field name" x))))
(error 'make-struct-type "not a valid field name" x))))
(define set-fields
(lambda (r f* i n)
@ -95,9 +95,9 @@
(case-lambda
[(name fields)
(unless (string? name)
(error 'make-struct-type "name must be a string, got ~s" name))
(error 'make-struct-type "name must be a string" name))
(unless (list? fields)
(error 'make-struct-type "fields must be a list, got ~s" fields))
(error '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)])
@ -105,9 +105,9 @@
rtd))]
[(name fields g)
(unless (string? name)
(error 'make-struct-type "name must be a string, got ~s" name))
(error 'make-struct-type "name must be a string" name))
(unless (list? fields)
(error 'make-struct-type "fields must be a list, got ~s" fields))
(error 'make-struct-type "fields must be a list" fields))
(for-each verify-field fields)
(cond
[(symbol-bound? g)
@ -124,38 +124,38 @@
(define struct-type-name
(lambda (rtd)
(unless (rtd? rtd)
(error 'struct-type-name "~s is not an rtd" rtd))
(error 'struct-type-name "not an rtd" rtd))
(rtd-name rtd)))
(define struct-type-symbol
(lambda (rtd)
(unless (rtd? rtd)
(error 'struct-type-symbol "~s is not an rtd" rtd))
(error '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 "~s is not an rtd" rtd))
(error 'struct-type-field-names "not an rtd" rtd))
(rtd-fields rtd)))
(define struct-constructor
(lambda (rtd)
(unless (rtd? rtd)
(error 'struct-constructor "~s is not an rtd"))
(error '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
"incorrect number of arguments to the constructor of ~s"
"incorrect number of arguments to the constructor"
rtd)))))))
(define struct-predicate
(lambda (rtd)
(unless (rtd? rtd)
(error 'struct-predicate "~s is not an rtd"))
(error 'struct-predicate "not an rtd"))
(lambda (x)
(and ($struct? x)
(eq? ($struct-rtd x) rtd)))))
@ -165,39 +165,39 @@
(cond
[(fixnum? i)
(unless (and ($fx>= i 0) ($fx< i (rtd-length rtd)))
(error who "~s is out of range for rtd ~s" rtd))
(error who "out of range for rtd" i rtd))
i]
[(symbol? i)
(letrec ([lookup
(lambda (n ls)
(cond
[(null? ls)
(error who "~s is not a field in ~s" rtd)]
(error 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 "~s is not a valid index" i)])))
[else (error who "not a valid index" i)])))
(define struct-field-accessor
(lambda (rtd i)
(unless (rtd? rtd)
(error 'struct-field-accessor "~s is not an rtd" rtd))
(error '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 "~s is not of type ~s" x rtd))
(error '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 "~s is not an rtd" rtd))
(error '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 "~s is not of type ~s" x rtd))
(error 'struct-field-mutator "not of correct type" x rtd))
($struct-set! x i v)))))
(define struct?
@ -208,7 +208,7 @@
(unless (null? ($cdr rest))
(error 'struct? "too many arguments"))
(unless (rtd? rtd)
(error 'struct? "~s is not an rtd"))
(error 'struct? "not an rtd"))
(and ($struct? x)
(eq? ($struct-rtd x) rtd))))))
@ -216,49 +216,49 @@
(lambda (x)
(if ($struct? x)
($struct-rtd x)
(error 'struct-rtd "~s is not a struct" x))))
(error 'struct-rtd "not a struct" x))))
(define struct-length
(lambda (x)
(if ($struct? x)
(rtd-length ($struct-rtd x))
(error 'struct-length "~s is not a struct" x))))
(error 'struct-length "not a struct" x))))
(define struct-name
(lambda (x)
(if ($struct? x)
(rtd-name ($struct-rtd x))
(error 'struct-name "~s is not a struct" x))))
(error 'struct-name "not a struct" x))))
(define struct-printer
(lambda (x)
(if ($struct? x)
(rtd-printer ($struct-rtd x))
(error 'struct-printer "~s is not a struct" x))))
(error 'struct-printer "not a struct" x))))
(define struct-ref
(lambda (x i)
(unless ($struct? x) (error 'struct-ref "~s is not a struct" x))
(unless (fixnum? i) (error 'struct-ref "~s is not a valid index" i))
(unless ($struct? x) (error 'struct-ref "not a struct" x))
(unless (fixnum? i) (error '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 ~s is out of range for ~s" i x))
(error '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! "~s is not a struct" x))
(unless (fixnum? i) (error 'struct-set! "~s is not a valid index" i))
(unless ($struct? x) (error 'struct-set! "not a struct" x))
(unless (fixnum? i) (error '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 ~s is out of range for ~s" i x))
(error '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! "~s is not an rtd" x))
(error 'set-rtd-printer! "not an rtd" x))
(unless (procedure? p)
(error 'set-rtd-printer! "~s is not a procedure" p))
(error 'set-rtd-printer! "not a procedure" p))
($set-rtd-printer! x p))
(set-rtd-fields! (base-rtd) '(name fields length printer symbol))

48
scheme/ikarus.symbols.ss
View File

@ -25,7 +25,7 @@
($make-symbol s)
(if (symbol? s)
($make-symbol ($symbol-string s))
(error 'gensym "~s is neither a string nor a symbol" s)))]))
(error 'gensym "neither a string nor a symbol" s)))]))
(define gensym?
(lambda (x)
@ -36,7 +36,7 @@
(define top-level-value
(lambda (x)
(unless (symbol? x)
(error 'top-level-value "~s is not a symbol" x))
(error 'top-level-value "not a symbol" x))
(let ([v ($symbol-value x)])
(when ($unbound-object? v)
(error 'eval "unbound variable"
@ -47,39 +47,39 @@
(define top-level-bound?
(lambda (x)
(unless (symbol? x)
(error 'top-level-bound? "~s is not a symbol" x))
(error '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! "~s is not a symbol" x))
(error 'set-top-level-value! "not a symbol" x))
($set-symbol-value! x v)))
(define symbol-value
(lambda (x)
(unless (symbol? x)
(error 'symbol-value "~s is not a symbol" x))
(error 'symbol-value "not a symbol" x))
(let ([v ($symbol-value x)])
(when ($unbound-object? v)
(error 'symbol-value "unbound ~s" x))
(error 'symbol-value "unbound" x))
v)))
(define symbol-bound?
(lambda (x)
(unless (symbol? x)
(error 'symbol-bound? "~s is not a symbol" x))
(error '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! "~s is not a symbol" x))
(error 'set-symbol-value! "not a symbol" x))
($set-symbol-value! x v)
($set-symbol-proc! x
(if (procedure? v) v
(lambda args
(error 'apply "~s is not a procedure"
(error 'apply "not a procedure"
($symbol-value x)))))))
(define reset-symbol-proc!
@ -94,18 +94,18 @@
(error 'eval "unbound variable"
(string->symbol
(symbol->string x)))
(error 'apply "~s is not a procedure" v)))))))))
(error 'apply "not a procedure" v)))))))))
(define string->symbol
(lambda (x)
(unless (string? x)
(error 'string->symbol "~s is not a string" x))
(error 'string->symbol "not a string" x))
(foreign-call "ikrt_string_to_symbol" x)))
(define symbol->string
(lambda (x)
(unless (symbol? x)
(error 'symbol->string "~s is not a symbol" x))
(error 'symbol->string "not a symbol" x))
(let ([str ($symbol-string x)])
(or str
(let ([ct (gensym-count)])
@ -117,8 +117,8 @@
(define putprop
(lambda (x k v)
(unless (symbol? x) (error 'putprop "~s is not a symbol" x))
(unless (symbol? k) (error 'putprop "~s is not a symbol" k))
(unless (symbol? x) (error 'putprop "not a symbol" x))
(unless (symbol? k) (error 'putprop "not a symbol" k))
(let ([p ($symbol-plist x)])
(cond
[(assq k p) => (lambda (x) (set-cdr! x v))]
@ -127,8 +127,8 @@
(define getprop
(lambda (x k)
(unless (symbol? x) (error 'getprop "~s is not a symbol" x))
(unless (symbol? k) (error 'getprop "~s is not a symbol" k))
(unless (symbol? x) (error 'getprop "not a symbol" x))
(unless (symbol? k) (error 'getprop "not a symbol" k))
(let ([p ($symbol-plist x)])
(cond
[(assq k p) => cdr]
@ -136,8 +136,8 @@
(define remprop
(lambda (x k)
(unless (symbol? x) (error 'remprop "~s is not a symbol" x))
(unless (symbol? k) (error 'remprop "~s is not a symbol" k))
(unless (symbol? x) (error 'remprop "not a symbol" x))
(unless (symbol? k) (error 'remprop "not a symbol" k))
(let ([p ($symbol-plist x)])
(unless (null? p)
(let ([a ($car p)])
@ -156,7 +156,7 @@