* removed formatted errors from all source codes.
This commit is contained in:
Abdulaziz Ghuloum
parent
4141d699c5
commit
b640d98cbc
|
|
@ -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))
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)]))
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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? | ||||