~ chicken-core (chicken-5) 039a8d5c2519cb2e9b5c8f516ad20cf0607158b4
commit 039a8d5c2519cb2e9b5c8f516ad20cf0607158b4
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Jan 31 21:37:38 2015 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:15:51 2015 +0200
Convert most ##sys#check-exact calls to the new ##sys#check-fixnum, because that's what's usually really meant.
diff --git a/c-platform.scm b/c-platform.scm
index 204a0edf..b59a87c0 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -556,6 +556,7 @@
(rewrite 'string-length 2 1 "C_i_string_length" #t)
(rewrite '##sys#check-exact 2 1 "C_i_check_exact" #t)
+(rewrite '##sys#check-fixnum 2 1 "C_i_check_fixnum" #t)
(rewrite '##sys#check-number 2 1 "C_i_check_number" #t)
(rewrite '##sys#check-list 2 1 "C_i_check_list" #t)
(rewrite '##sys#check-pair 2 1 "C_i_check_pair" #t)
@@ -568,6 +569,7 @@
(rewrite '##sys#check-structure 2 2 "C_i_check_structure" #t)
(rewrite '##sys#check-char 2 1 "C_i_check_char" #t)
(rewrite '##sys#check-exact 2 2 "C_i_check_exact_2" #t)
+(rewrite '##sys#check-fixnum 2 2 "C_i_check_fixnum_2" #t)
(rewrite '##sys#check-number 2 2 "C_i_check_number_2" #t)
(rewrite '##sys#check-list 2 2 "C_i_check_list_2" #t)
(rewrite '##sys#check-pair 2 2 "C_i_check_pair_2" #t)
diff --git a/chicken.h b/chicken.h
index bb1fef12..65878c84 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1488,6 +1488,7 @@ extern double trunc(double);
#define C_i_check_closure(x) C_i_check_closure_2(x, C_SCHEME_FALSE)
#define C_i_check_exact(x) C_i_check_exact_2(x, C_SCHEME_FALSE)
+#define C_i_check_fixnum(x) C_i_check_fixnum_2(x, C_SCHEME_FALSE)
#define C_i_check_inexact(x) C_i_check_inexact_2(x, C_SCHEME_FALSE)
#define C_i_check_number(x) C_i_check_number_2(x, C_SCHEME_FALSE)
#define C_i_check_string(x) C_i_check_string_2(x, C_SCHEME_FALSE)
@@ -2026,6 +2027,7 @@ C_fctexport C_word C_fcall C_u_i_length(C_word lst) C_regparm;
/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_i_inexact_to_exact(C_word n) C_regparm;
C_fctexport C_word C_fcall C_i_check_closure_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_fixnum_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_exact_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_inexact_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_number_2(C_word x, C_word loc) C_regparm;
diff --git a/data-structures.scm b/data-structures.scm
index bce7fdfc..695fc382 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -153,7 +153,7 @@
(define chop
(lambda (lst n)
- (##sys#check-exact n 'chop)
+ (##sys#check-fixnum n 'chop)
(when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))
(let ([len (length lst)])
(let loop ([lst lst] [i len])
@@ -310,7 +310,7 @@
(let* ((wherelen (##sys#size where))
(whichlen (##sys#size which))
(end (fx- wherelen whichlen)))
- (##sys#check-exact start loc)
+ (##sys#check-fixnum start loc)
(if (and (fx>= start 0)
(fx> wherelen start))
(let loop ((istart start))
@@ -375,8 +375,8 @@
(let ((len (or n
(fxmin (fx- (##sys#size s1) start1)
(fx- (##sys#size s2) start2) ) ) ) )
- (##sys#check-exact start1 'substring=?)
- (##sys#check-exact start2 'substring=?)
+ (##sys#check-fixnum start1 'substring=?)
+ (##sys#check-fixnum start2 'substring=?)
(##core#inline "C_substring_compare" s1 s2 start1 start2 len) ) )
(define (substring=? s1 s2 #!optional (start1 0) (start2 0) len)
@@ -388,8 +388,8 @@
(let ((len (or n
(fxmin (fx- (##sys#size s1) start1)
(fx- (##sys#size s2) start2) ) ) ) )
- (##sys#check-exact start1 'substring-ci=?)
- (##sys#check-exact start2 'substring-ci=?)
+ (##sys#check-fixnum start1 'substring-ci=?)
+ (##sys#check-fixnum start2 'substring-ci=?)
(##core#inline "C_substring_compare_case_insensitive"
s1 s2 start1 start2 len) ) )
@@ -546,7 +546,7 @@
(define (string-chop str len)
(##sys#check-string str 'string-chop)
- (##sys#check-exact len 'string-chop)
+ (##sys#check-fixnum len 'string-chop)
(let ([total (##sys#size str)])
(let loop ([total total] [pos 0])
(cond [(fx<= total 0) '()]
diff --git a/eval.scm b/eval.scm
index ce66ce22..8114838e 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1460,7 +1460,7 @@
(##sys#setslot r5n 2 (strip (##sys#slot r5n 2)))
(set! scheme-report-environment
(lambda (n)
- (##sys#check-exact n 'scheme-report-environment)
+ (##sys#check-fixnum n 'scheme-report-environment)
(case n
((4) r4s)
((5) r5s)
@@ -1470,7 +1470,7 @@
"unsupported scheme report environment version" n)) ) ) )
(set! null-environment
(lambda (n)
- (##sys#check-exact n 'null-environment)
+ (##sys#check-fixnum n 'null-environment)
(case n
((4) r4n)
((5) r5n)
@@ -1540,7 +1540,7 @@
(define ##sys#clear-trace-buffer (foreign-lambda void "C_clear_trace_buffer"))
(define (##sys#resize-trace-buffer i)
- (##sys#check-exact i)
+ (##sys#check-fixnum i)
(##core#inline "C_resize_trace_buffer" i))
(define repl
diff --git a/extras.scm b/extras.scm
index 427a49a9..dec70d23 100644
--- a/extras.scm
+++ b/extras.scm
@@ -59,11 +59,11 @@
(let ((nn (if (null? n)
(##sys#flo2fix (fp/ (current-seconds) 1000.0)) ; wall clock time
(car n))))
- (##sys#check-exact nn 'randomize)
+ (##sys#check-fixnum nn 'randomize)
(##core#inline "C_randomize" nn) ) )
(define (random n)
- (##sys#check-exact n 'random)
+ (##sys#check-fixnum n 'random)
(if (eq? n 0)
0
(##core#inline "C_random_fixnum" n) ) )
@@ -167,11 +167,11 @@
(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
(##sys#check-input-port port #t 'read-string!)
(##sys#check-string dest 'read-string!)
- (when n (##sys#check-exact n 'read-string!))
+ (when n (##sys#check-fixnum n 'read-string!))
(let ((dest-size (##sys#size dest)))
(unless (and n (fx<= (fx+ start n) dest-size))
(set! n (fx- dest-size start))))
- (##sys#check-exact start 'read-string!)
+ (##sys#check-fixnum start 'read-string!)
(##sys#read-string! n dest port start) )
(define-constant read-string-buffer-size 2048)
@@ -179,7 +179,7 @@
(define ##sys#read-string/port
(lambda (n p)
(##sys#check-input-port p #t 'read-string)
- (cond (n (##sys#check-exact n 'read-string)
+ (cond (n (##sys#check-fixnum n 'read-string)
(let* ((str (##sys#make-string n))
(n2 (##sys#read-string! n str p 0)) )
(if (eq? n n2)
@@ -235,7 +235,7 @@
(##sys#check-string s 'write-string)
(let-optionals more ([n #f] [port ##sys#standard-output])
(##sys#check-output-port port #t 'write-string)
- (when n (##sys#check-exact n 'write-string))
+ (when n (##sys#check-fixnum n 'write-string))
((##sys#slot (##sys#slot port 2) 3) ; write-string
port
(if (and n (fx< n (##sys#size s)))
@@ -253,7 +253,7 @@
(char->integer x) ) ) )
(define (write-byte byte #!optional (port ##sys#standard-output))
- (##sys#check-exact byte 'write-byte)
+ (##sys#check-fixnum byte 'write-byte)
(##sys#check-output-port port #t 'write-byte)
(##sys#write-char-0 (integer->char byte) port) )
diff --git a/library.scm b/library.scm
index 0d84496e..16d58c3d 100644
--- a/library.scm
+++ b/library.scm
@@ -276,6 +276,11 @@ EOF
(##core#inline "C_i_check_number_2" x (car loc))
(##core#inline "C_i_check_number" x) ) )
+(define (##sys#check-fixnum x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_fixnum_2" x (car loc))
+ (##core#inline "C_i_check_fixnum" x) ) )
+
(define (##sys#check-exact x . loc)
(if (pair? loc)
(##core#inline "C_i_check_exact_2" x (car loc))
@@ -329,7 +334,7 @@ EOF
(##sys#error-bad-real x (and (pair? loc) (car loc))) ) )
(define (##sys#check-range i from to . loc)
- (##sys#check-exact i loc)
+ (##sys#check-fixnum i loc)
(unless (and (fx<= from i) (fx< i to))
(##sys#error-hook
(foreign-value "C_OUT_OF_RANGE_ERROR" int)
@@ -526,7 +531,7 @@ EOF
(%make-string size fill))
(define (make-string size . fill)
- (##sys#check-exact size 'make-string)
+ (##sys#check-fixnum size 'make-string)
(when (fx< size 0)
(##sys#signal-hook #:bounds-error 'make-string "size is negative" size))
(%make-string
@@ -596,10 +601,10 @@ EOF
(define (substring s start . end)
(##sys#check-string s 'substring)
- (##sys#check-exact start 'substring)
+ (##sys#check-fixnum start 'substring)
(let ([end (if (pair? end)
(let ([end (car end)])
- (##sys#check-exact end 'substring)
+ (##sys#check-fixnum end 'substring)
end)
(##sys#size s) ) ] )
(let ([len (##sys#size s)])
@@ -2108,7 +2113,7 @@ EOF
(define (flonum-print-precision #!optional prec)
(let ([prev (##core#inline "C_get_print_precision")])
(when prec
- (##sys#check-exact prec 'flonum-print-precision)
+ (##sys#check-fixnum prec 'flonum-print-precision)
(##core#inline "C_set_print_precision" prec) )
prev ) )
@@ -2292,7 +2297,7 @@ EOF
bv) )
(define (make-blob size)
- (##sys#check-exact size 'make-blob)
+ (##sys#check-fixnum size 'make-blob)
(##sys#make-blob size) )
(define (blob? x)
@@ -2333,7 +2338,7 @@ EOF
(define (vector-set! v i x) (##core#inline "C_i_vector_set" v i x))
(define (make-vector size . fill)
- (##sys#check-exact size 'make-vector)
+ (##sys#check-fixnum size 'make-vector)
(when (fx< size 0) (##sys#error 'make-vector "size is negative" size))
(##sys#allocate-vector
size #f
@@ -2382,7 +2387,7 @@ EOF
(let* ((len-from (##sys#size from))
(len-to (##sys#size to))
(n (if (pair? n) (car n) (fxmin len-to len-from))) )
- (##sys#check-exact n 'vector-copy!)
+ (##sys#check-fixnum n 'vector-copy!)
(when (or (fx> n len-to) (fx> n len-from))
(##sys#signal-hook
#:bounds-error 'vector-copy!
@@ -2405,7 +2410,7 @@ EOF
(define (vector-resize v n #!optional init)
(##sys#check-vector v 'vector-resize)
- (##sys#check-exact n 'vector-resize)
+ (##sys#check-fixnum n 'vector-resize)
(##sys#vector-resize v n init) )
(define (##sys#vector-resize v n init)
@@ -2424,7 +2429,7 @@ EOF
(##core#inline "C_fix" (##core#inline "C_character_code" c)) )
(define (integer->char n)
- (##sys#check-exact n 'integer->char)
+ (##sys#check-fixnum n 'integer->char)
(##core#inline "C_make_character" (##core#inline "C_unfix" n)) )
(define (char=? c1 c2)
@@ -2824,7 +2829,7 @@ EOF
(else
(fx+ act len) ) ) )))
(lambda (p rlimit) ; read-line
- (if rlimit (##sys#check-exact rlimit 'read-line))
+ (if rlimit (##sys#check-fixnum rlimit 'read-line))
(let ((sblen read-line-buffer-initial-size))
(unless (##sys#slot p 12)
(##sys#setslot p 12 (##sys#make-string sblen)))
@@ -4873,7 +4878,7 @@ EOF
(thread ##sys#current-thread)
(header "\n\tCall history:\n") )
(##sys#check-output-port port #t 'print-call-chain)
- (##sys#check-exact start 'print-call-chain)
+ (##sys#check-fixnum start 'print-call-chain)
(##sys#check-string header 'print-call-chain)
(let ((ct (##sys#get-call-chain start thread)))
(##sys#really-print-call-chain port ct header)
@@ -4940,7 +4945,7 @@ EOF
(define exit-handler
(make-parameter
(lambda (#!optional (code 0))
- (##sys#check-exact code)
+ (##sys#check-fixnum code)
(cond (exit-in-progress
(##sys#warn "\"exit\" called while processing on-exit tasks"))
(else
diff --git a/posix-common.scm b/posix-common.scm
index 69b625d7..245f6e21 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -313,8 +313,8 @@ EOF
(define set-file-position!
(lambda (port pos . whence)
(let ((whence (if (pair? whence) (car whence) _seek_set)))
- (##sys#check-exact pos 'set-file-position!)
- (##sys#check-exact whence 'set-file-position!)
+ (##sys#check-fixnum pos 'set-file-position!)
+ (##sys#check-fixnum whence 'set-file-position!)
(unless (cond ((port? port)
(and (eq? (##sys#slot port 7) 'stream)
(##core#inline "C_fseek" port pos whence) ) )
@@ -371,11 +371,11 @@ EOF
port) ) )
(set! open-input-file*
(lambda (fd . m)
- (##sys#check-exact fd 'open-input-file*)
+ (##sys#check-fixnum fd 'open-input-file*)
(check 'open-input-file* fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m 'open-input-file*))) ) )
(set! open-output-file*
(lambda (fd . m)
- (##sys#check-exact fd 'open-output-file*)
+ (##sys#check-fixnum fd 'open-output-file*)
(check 'open-output-file* fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m 'open-output-file*)) ) ) ) )
(define port->fileno
@@ -396,11 +396,11 @@ EOF
(define duplicate-fileno
(lambda (old . new)
- (##sys#check-exact old duplicate-fileno)
+ (##sys#check-fixnum old duplicate-fileno)
(let ([fd (if (null? new)
(##core#inline "C_dup" old)
(let ([n (car new)])
- (##sys#check-exact n 'duplicate-fileno)
+ (##sys#check-fixnum n 'duplicate-fileno)
(##core#inline "C_dup2" old n) ) ) ] )
(when (fx< fd 0)
(posix-error #:file-error 'duplicate-fileno "cannot duplicate file-descriptor" old) )
@@ -541,12 +541,12 @@ EOF
(define file-creation-mode
(getter-with-setter
(lambda (#!optional um)
- (when um (##sys#check-exact um 'file-creation-mode))
+ (when um (##sys#check-fixnum um 'file-creation-mode))
(let ((um2 (##core#inline "C_umask" (or um 0))))
(unless um (##core#inline "C_umask" um2)) ; restore
um2))
(lambda (um)
- (##sys#check-exact um 'file-creation-mode)
+ (##sys#check-fixnum um 'file-creation-mode)
(##core#inline "C_umask" um))
"(file-creation-mode mode)"))
@@ -633,14 +633,14 @@ EOF
;;; Signals
(define (set-signal-handler! sig proc)
- (##sys#check-exact sig 'set-signal-handler!)
+ (##sys#check-fixnum sig 'set-signal-handler!)
(##core#inline "C_establish_signal_handler" sig (and proc sig))
(vector-set! ##sys#signal-vector sig proc) )
(define signal-handler
(getter-with-setter
(lambda (sig)
- (##sys#check-exact sig 'signal-handler)
+ (##sys#check-fixnum sig 'signal-handler)
(##sys#slot ##sys#signal-vector sig) )
set-signal-handler!))
@@ -653,7 +653,7 @@ EOF
(lambda args
(let-optionals* args ([pid #f] [nohang #f])
(let ([pid (or pid -1)])
- (##sys#check-exact pid 'process-wait)
+ (##sys#check-fixnum pid 'process-wait)
(receive [epid enorm ecode] (##sys#process-wait pid nohang)
(if (fx= epid -1)
(posix-error #:process-error 'process-wait "waiting for child process failed" pid)
diff --git a/posixunix.scm b/posixunix.scm
index 45bd288d..b7784646 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -492,8 +492,8 @@ EOF
(define file-control
(let ([fcntl (foreign-lambda int fcntl int int long)])
(lambda (fd cmd #!optional (arg 0))
- (##sys#check-exact fd 'file-control)
- (##sys#check-exact cmd 'file-control)
+ (##sys#check-fixnum fd 'file-control)
+ (##sys#check-fixnum cmd 'file-control)
(let ([res (fcntl fd cmd arg)])
(if (fx= res -1)
(posix-error #:file-error 'file-control "cannot control file" fd cmd)
@@ -504,8 +504,8 @@ EOF
(lambda (filename flags . mode)
(let ([mode (if (pair? mode) (car mode) defmode)])
(##sys#check-string filename 'file-open)
- (##sys#check-exact flags 'file-open)
- (##sys#check-exact mode 'file-open)
+ (##sys#check-fixnum flags 'file-open)
+ (##sys#check-fixnum mode 'file-open)
(let ([fd (##core#inline "C_open" (##sys#make-c-string filename 'file-open) flags mode)])
(when (eq? -1 fd)
(posix-error #:file-error 'file-open "cannot open file" filename flags mode) )
@@ -513,14 +513,14 @@ EOF
(define file-close
(lambda (fd)
- (##sys#check-exact fd 'file-close)
+ (##sys#check-fixnum fd 'file-close)
(when (fx< (##core#inline "C_close" fd) 0)
(posix-error #:file-error 'file-close "cannot close file" fd) ) ) )
(define file-read
(lambda (fd size . buffer)
- (##sys#check-exact fd 'file-read)
- (##sys#check-exact size 'file-read)
+ (##sys#check-fixnum fd 'file-read)
+ (##sys#check-fixnum size 'file-read)
(let ([buf (if (pair? buffer) (car buffer) (make-string size))])
(unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
(##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
@@ -531,11 +531,11 @@ EOF
(define file-write
(lambda (fd buffer . size)
- (##sys#check-exact fd 'file-write)
+ (##sys#check-fixnum fd 'file-write)
(unless (and (##core#inline "C_blockp" buffer) (##core#inline "C_byteblockp" buffer))
(##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or blob" buffer) )
(let ([size (if (pair? size) (car size) (##sys#size buffer))])
- (##sys#check-exact size 'file-write)
+ (##sys#check-fixnum size 'file-write)
(let ([n (##core#inline "C_write" fd buffer size)])
(when (eq? -1 n)
(posix-error #:file-error 'file-write "cannot write to file" fd size) )
@@ -638,7 +638,7 @@ EOF
name)))
(define (change-directory* fd)
- (##sys#check-exact fd 'change-directory*)
+ (##sys#check-fixnum fd 'change-directory*)
(unless (fx= 0 (##core#inline "C_fchdir" fd))
(posix-error #:file-error 'change-directory* "cannot change current directory" fd) )
fd)
@@ -809,7 +809,7 @@ EOF
(##core#inline "C_sigemptyset" 0)
(for-each
(lambda (s)
- (##sys#check-exact s 'set-signal-mask!)
+ (##sys#check-fixnum s 'set-signal-mask!)
(##core#inline "C_sigaddset" s) )
sigs)
(when (fx< (##core#inline "C_sigprocmask_set" 0) 0)
@@ -828,19 +828,19 @@ EOF
set-signal-mask!))
(define (signal-masked? sig)
- (##sys#check-exact sig 'signal-masked?)
+ (##sys#check-fixnum sig 'signal-masked?)
(##core#inline "C_sigprocmask_get" 0)
(##core#inline "C_sigismember" sig) )
(define (signal-mask! sig)
- (##sys#check-exact sig 'signal-mask!)
+ (##sys#check-fixnum sig 'signal-mask!)
(##core#inline "C_sigemptyset" 0)
(##core#inline "C_sigaddset" sig)
(when (fx< (##core#inline "C_sigprocmask_block" 0) 0)
(posix-error #:process-error 'signal-mask! "cannot block signal") ))
(define (signal-unmask! sig)
- (##sys#check-exact sig 'signal-unmask!)
+ (##sys#check-fixnum sig 'signal-unmask!)
(##core#inline "C_sigemptyset" 0)
(##core#inline "C_sigaddset" sig)
(when (fx< (##core#inline "C_sigprocmask_unblock" 0) 0)
@@ -996,14 +996,14 @@ EOF
(##sys#update-errno)
(##sys#error 'set-groups! "cannot set supplementary group ids" lst0) ) )
(let ([n (##sys#slot lst 0)])
- (##sys#check-exact n 'set-groups!)
+ (##sys#check-fixnum n 'set-groups!)
(##core#inline "C_set_gid" i n) ) ) )
(define initialize-groups
(let ([init (foreign-lambda int "initgroups" c-string int)])
(lambda (user id)
(##sys#check-string user 'initialize-groups)
- (##sys#check-exact id 'initialize-groups)
+ (##sys#check-fixnum id 'initialize-groups)
(when (fx< (init user id) 0)
(##sys#update-errno)
(##sys#error 'initialize-groups "cannot initialize supplementary group ids" user id) ) ) ) )
@@ -1057,15 +1057,15 @@ EOF
(define change-file-mode
(lambda (fname m)
(##sys#check-string fname 'change-file-mode)
- (##sys#check-exact m 'change-file-mode)
+ (##sys#check-fixnum m 'change-file-mode)
(when (fx< (##core#inline "C_chmod" (##sys#make-c-string fname 'change-file-mode) m) 0)
(posix-error #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) )
(define change-file-owner
(lambda (fn uid gid)
(##sys#check-string fn 'change-file-owner)
- (##sys#check-exact uid 'change-file-owner)
- (##sys#check-exact gid 'change-file-owner)
+ (##sys#check-fixnum uid 'change-file-owner)
+ (##sys#check-fixnum gid 'change-file-owner)
(when (fx< (##core#inline "C_chown" (##sys#make-c-string fn 'change-file-owner) uid gid) 0)
(posix-error #:file-error 'change-file-owner "cannot change file owner" fn uid gid) ) ) )
@@ -1093,15 +1093,15 @@ EOF
(define process-group-id
(getter-with-setter
(lambda (pid)
- (##sys#check-exact pid 'process-group-id)
+ (##sys#check-fixnum pid 'process-group-id)
(let ([a (##core#inline "C_getpgid" pid)])
(when (fx< a 0)
(##sys#update-errno)
(##sys#error 'process-group-id "cannot retrieve process group ID" pid) )
a))
(lambda (pid pgid)
- (##sys#check-exact pid 'set-process-group-id!)
- (##sys#check-exact pgid 'set-process-group-id!)
+ (##sys#check-fixnum pid 'set-process-group-id!)
+ (##sys#check-fixnum pgid 'set-process-group-id!)
(when (fx< (##core#inline "C_setpgid" pid pgid) 0)
(##sys#update-errno)
(##sys#error 'set-process-group-id! "cannot set process group ID" pid pgid) ) )
@@ -1410,7 +1410,7 @@ EOF
(lambda (fname . mode)
(##sys#check-string fname 'create-fifo)
(let ([mode (if (pair? mode) (car mode) (fxior _s_irwxu (fxior _s_irwxg _s_irwxo)))])
- (##sys#check-exact mode 'create-fifo)
+ (##sys#check-fixnum mode 'create-fifo)
(when (fx< (##core#inline "C_mkfifo" (##sys#make-c-string fname 'create-fifo) mode) 0)
(posix-error #:file-error 'create-fifo "cannot create FIFO" fname mode) ) ) ) )
@@ -1483,7 +1483,7 @@ EOF
[(#:line) _iolbf]
[(#:none) _ionbf]
[else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
- (##sys#check-exact size 'set-buffering-mode!)
+ (##sys#check-fixnum size 'set-buffering-mode!)
(when (fx< (if (eq? 'stream (##sys#slot port 7))
(##core#inline "C_setvbuf" port mode size)
-1)
@@ -1614,8 +1614,8 @@ EOF
(define process-signal
(lambda (id . sig)
(let ([sig (if (pair? sig) (car sig) _sigterm)])
- (##sys#check-exact id 'process-signal)
- (##sys#check-exact sig 'process-signal)
+ (##sys#check-fixnum id 'process-signal)
+ (##sys#check-fixnum sig 'process-signal)
(let ([r (##core#inline "C_kill" id sig)])
(when (fx= r -1) (posix-error #:process-error 'process-signal "could not send signal to process" id sig) ) ) ) ) )
diff --git a/posixwin.scm b/posixwin.scm
index 5c9aa220..445095b3 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -732,8 +732,8 @@ EOF
(lambda (filename flags . mode)
(let ([mode (if (pair? mode) (car mode) defmode)])
(##sys#check-string filename 'file-open)
- (##sys#check-exact flags 'file-open)
- (##sys#check-exact mode 'file-open)
+ (##sys#check-fixnum flags 'file-open)
+ (##sys#check-fixnum mode 'file-open)
(let ([fd (##core#inline "C_open" (##sys#make-c-string filename 'file-open) flags mode)])
(when (eq? -1 fd)
(##sys#update-errno)
@@ -742,15 +742,15 @@ EOF
(define file-close
(lambda (fd)
- (##sys#check-exact fd 'file-close)
+ (##sys#check-fixnum fd 'file-close)
(when (fx< (##core#inline "C_close" fd) 0)
(##sys#update-errno)
(##sys#signal-hook #:file-error 'file-close "cannot close file" fd) ) ) )
(define file-read
(lambda (fd size . buffer)
- (##sys#check-exact fd 'file-read)
- (##sys#check-exact size 'file-read)
+ (##sys#check-fixnum fd 'file-read)
+ (##sys#check-fixnum size 'file-read)
(let ([buf (if (pair? buffer) (car buffer) (make-string size))])
(unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
(##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
@@ -762,11 +762,11 @@ EOF
(define file-write
(lambda (fd buffer . size)
- (##sys#check-exact fd 'file-write)
+ (##sys#check-fixnum fd 'file-write)
(unless (and (##core#inline "C_blockp" buffer) (##core#inline "C_byteblockp" buffer))
(##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or blob" buffer) )
(let ([size (if (pair? size) (car size) (##sys#size buffer))])
- (##sys#check-exact size 'file-write)
+ (##sys#check-fixnum size 'file-write)
(let ([n (##core#inline "C_write" fd buffer size)])
(when (eq? -1 n)
(##sys#update-errno)
@@ -1040,7 +1040,7 @@ EOF
(define change-file-mode
(lambda (fname m)
(##sys#check-string fname 'change-file-mode)
- (##sys#check-exact m 'change-file-mode)
+ (##sys#check-fixnum m 'change-file-mode)
(when (fx< (##core#inline "C_chmod" (##sys#make-c-string fname 'change-file-mode) m) 0)
(##sys#update-errno)
(##sys#signal-hook #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) )
@@ -1091,11 +1091,11 @@ EOF
port) ) )
(set! open-input-file*
(lambda (fd . m)
- (##sys#check-exact fd 'open-input-file*)
+ (##sys#check-fixnum fd 'open-input-file*)
(check fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m 'open-input-file*))) ) )
(set! open-output-file*
(lambda (fd . m)
- (##sys#check-exact fd 'open-output-file*)
+ (##sys#check-fixnum fd 'open-output-file*)
(check fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m 'open-output-file*)) ) ) ) )
(define port->fileno
@@ -1111,11 +1111,11 @@ EOF
(define duplicate-fileno
(lambda (old . new)
- (##sys#check-exact old duplicate-fileno)
+ (##sys#check-fixnum old duplicate-fileno)
(let ([fd (if (null? new)
(##core#inline "C_dup" old)
(let ([n (car new)])
- (##sys#check-exact n 'duplicate-fileno)
+ (##sys#check-fixnum n 'duplicate-fileno)
(##core#inline "C_dup2" old n) ) ) ] )
(when (fx< fd 0)
(##sys#update-errno)
@@ -1162,7 +1162,7 @@ EOF
[(###line) _iolbf]
[(###none) _ionbf]
[else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
- (##sys#check-exact size 'set-buffering-mode!)
+ (##sys#check-fixnum size 'set-buffering-mode!)
(when (fx< (if (eq? 'stream (##sys#slot port 7))
(##core#inline "C_setvbuf" port mode size)
-1)
@@ -1356,7 +1356,7 @@ EOF
(values -1 #f #f) ) )
(define (sleep s)
- (##sys#check-exact s 'sleep)
+ (##sys#check-fixnum s 'sleep)
(##core#inline "C_sleep" s))
(define-foreign-variable _hostname c-string "C_hostname")
diff --git a/runtime.c b/runtime.c
index 57d1e014..7dfdc322 100644
--- a/runtime.c
+++ b/runtime.c
@@ -6256,6 +6256,15 @@ C_regparm C_word C_fcall C_i_check_closure_2(C_word x, C_word loc)
return C_SCHEME_UNDEFINED;
}
+C_regparm C_word C_fcall C_i_check_fixnum_2(C_word x, C_word loc)
+{
+ if(!(x & C_FIXNUM_BIT)) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
C_regparm C_word C_fcall C_i_check_exact_2(C_word x, C_word loc)
{
diff --git a/srfi-4.scm b/srfi-4.scm
index 5cd346e0..dea9441a 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -41,17 +41,17 @@ EOF
;;; Helper routines:
-(declare (hide ##sys#check-exact-interval))
+(declare (hide ##sys#check-fixnum-interval))
-(define ##sys#check-exact-interval
+(define ##sys#check-fixnum-interval
(lambda (n from to loc)
- (##sys#check-exact n loc)
+ (##sys#check-fixnum n loc)
(if (or (##core#inline "C_fixnum_lessp" n from)
(##core#inline "C_fixnum_greaterp" n to) )
(##sys#error loc "numeric value is not in expected range" n from to) ) ) )
(define-inline (check-range i from to loc)
- (##sys#check-exact i loc)
+ (##sys#check-fixnum i loc)
(unless (and (fx<= from i) (fx< i to))
(##sys#error-hook
(foreign-value "C_OUT_OF_RANGE_ERROR" int)
@@ -98,7 +98,7 @@ EOF
(define (u8vector-set! x i y)
(##sys#check-structure x 'u8vector 'u8vector-set!)
(let ((len (##core#inline "C_u_i_8vector_length" x)))
- (##sys#check-exact y 'u8vector-set!)
+ (##sys#check-fixnum y 'u8vector-set!)
(when (fx< y 0)
(##sys#error 'u8vector-set! "argument may not be negative" y))
(check-range i 0 len 'u8vector-set!)
@@ -107,14 +107,14 @@ EOF
(define (s8vector-set! x i y)
(##sys#check-structure x 's8vector 's8vector-set!)
(let ((len (##core#inline "C_u_i_8vector_length" x)))
- (##sys#check-exact y 's8vector-set!)
+ (##sys#check-fixnum y 's8vector-set!)
(check-range i 0 len 's8vector-set!)
(##core#inline "C_u_i_s8vector_set" x i y)))
(define (u16vector-set! x i y)
(##sys#check-structure x 'u16vector 'u16vector-set!)
(let ((len (##core#inline "C_u_i_16vector_length" x)))
- (##sys#check-exact y 'u16vector-set!)
+ (##sys#check-fixnum y 'u16vector-set!)
(when (fx< y 0)
(##sys#error 'u16vector-set! "argument may not be negative" y))
(check-range i 0 len 'u16vector-set!)
@@ -123,7 +123,7 @@ EOF
(define (s16vector-set! x i y)
(##sys#check-structure x 's16vector 's16vector-set!)
(let ((len (##core#inline "C_u_i_16vector_length" x)))
- (##sys#check-exact y 's16vector-set!)
+ (##sys#check-fixnum y 's16vector-set!)
(check-range i 0 len 's16vector-set!)
(##core#inline "C_u_i_s16vector_set" x i y)))
@@ -281,85 +281,85 @@ EOF
(set! make-u8vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (##sys#check-exact len 'make-u8vector)
+ (##sys#check-fixnum len 'make-u8vector)
(let ((v (##sys#make-structure 'u8vector (alloc 'make-u8vector len ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
(begin
- (##sys#check-exact-interval init 0 #xff 'make-u8vector)
+ (##sys#check-fixnum-interval init 0 #xff 'make-u8vector)
(do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
(##core#inline "C_u_i_u8vector_set" v i init) ) ) ) ) ) )
(set! make-s8vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (##sys#check-exact len 'make-s8vector)
+ (##sys#check-fixnum len 'make-s8vector)
(let ((v (##sys#make-structure 's8vector (alloc 'make-s8vector len ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
(begin
- (##sys#check-exact-interval init -128 127 'make-s8vector)
+ (##sys#check-fixnum-interval init -128 127 'make-s8vector)
(do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
(##core#inline "C_u_i_s8vector_set" v i init) ) ) ) ) ) )
(set! make-u16vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (##sys#check-exact len 'make-u16vector)
+ (##sys#check-fixnum len 'make-u16vector)
(let ((v (##sys#make-structure 'u16vector (alloc 'make-u16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
(begin
- (##sys#check-exact-interval init 0 #xffff 'make-u16vector)
+ (##sys#check-fixnum-interval init 0 #xffff 'make-u16vector)
(do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
(##core#inline "C_u_i_u16vector_set" v i init) ) ) ) ) ) )
(set! make-s16vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (##sys#check-exact len 'make-s16vector)
+ (##sys#check-fixnum len 'make-s16vector)
(let ((v (##sys#make-structure 's16vector (alloc 'make-s16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
(begin
- (##sys#check-exact-interval init -32768 32767 'make-s16vector)
+ (##sys#check-fixnum-interval init -32768 32767 'make-s16vector)
(do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
(##core#inline "C_u_i_s16vector_set" v i init) ) ) ) ) ) )
(set! make-u32vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (##sys#check-exact len 'make-u32vector)
+ (##sys#check-fixnum len 'make-u32vector)
(let ((v (##sys#make-structure 'u32vector (alloc 'make-u32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
(begin
- (##sys#check-exact init 'make-u32vector)
+ (##sys#check-fixnum init 'make-u32vector)
(do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
(##core#inline "C_u_i_u32vector_set" v i init) ) ) ) ) ) )
(set! make-s32vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (##sys#check-exact len 'make-s32vector)
+ (##sys#check-fixnum len 'make-s32vector)
(let ((v (##sys#make-structure 's32vector (alloc 'make-s32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
(begin
- (##sys#check-exact init 'make-s32vector)
+ (##sys#check-fixnum init 'make-s32vector)
(do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
(##core#inline "C_u_i_s32vector_set" v i init) ) ) ) ) ) )
(set! make-f32vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (##sys#check-exact len 'make-f32vector)
+ (##sys#check-fixnum len 'make-f32vector)
(let ((v (##sys#make-structure 'f32vector (alloc 'make-f32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
@@ -374,7 +374,7 @@ EOF
(set! make-f64vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (##sys#check-exact len 'make-f64vector)
+ (##sys#check-fixnum len 'make-f64vector)
(let ((v (##sys#make-structure
'f64vector
(alloc 'make-f64vector (##core#inline "C_fixnum_shift_left" len 3) ext?))))
@@ -655,9 +655,9 @@ EOF
(define (read-u8vector! n dest #!optional (port ##sys#standard-input) (start 0))
(##sys#check-input-port port #t 'read-u8vector!)
- (##sys#check-exact start 'read-u8vector!)
+ (##sys#check-fixnum start 'read-u8vector!)
(##sys#check-structure dest 'u8vector 'read-u8vector!)
- (when n (##sys#check-exact n 'read-u8vector!))
+ (when n (##sys#check-fixnum n 'read-u8vector!))
(let* ((dest (##sys#slot dest 1))
(size (##sys#size dest)))
(unless (and n (fx<= (fx+ start n) size))
@@ -675,7 +675,7 @@ EOF
str2) ) )
(lambda (#!optional n (p ##sys#standard-input))
(##sys#check-input-port p #t 'read-u8vector)
- (cond (n (##sys#check-exact n 'read-u8vector)
+ (cond (n (##sys#check-fixnum n 'read-u8vector)
(let* ((str (##sys#allocate-vector n #t #f #t))
(n2 (##sys#read-string! n str p 0)) )
(##core#inline "C_string_to_bytevector" str)
diff --git a/tcp.scm b/tcp.scm
index 1652cbce..24a473b8 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -313,10 +313,10 @@ EOF
(define-constant default-backlog 100)
(define (tcp-listen port #!optional (backlog default-backlog) host)
- (##sys#check-exact port)
+ (##sys#check-fixnum port)
(when (or (fx< port 0) (fx> port 65535))
(##sys#signal-hook #:domain-error 'tcp-listen "invalid port number" port) )
- (##sys#check-exact backlog)
+ (##sys#check-fixnum backlog)
(let ((s (##net#bind-socket _sock_stream host port)))
(when (eq? _socket_error (##net#listen s backlog))
(network-error/close 'tcp-listen "cannot listen on socket" s port) )
@@ -343,7 +343,7 @@ EOF
(let ()
(define ((check loc) x)
- (when x (##sys#check-exact x loc))
+ (when x (##sys#check-fixnum x loc))
x)
(define minute (fx* 60 1000))
(set! tcp-read-timeout (make-parameter minute (check 'tcp-read-timeout)))
@@ -584,7 +584,7 @@ EOF
(unless port
(set!-values (host port) (##net#parse-host host "tcp"))
(unless port (##sys#signal-hook #:domain-error 'tcp-connect "no port specified" host)) )
- (##sys#check-exact port)
+ (##sys#check-fixnum port)
(unless (##net#gethostaddr addr host port)
(##sys#signal-hook #:network-error 'tcp-connect "cannot find host address" host) )
(let ((s (##net#socket _af_inet _sock_stream 0)) )
Trap