fixing char comparison bug

accepting more numeric types in vector.alloc
adding more aliases
This commit is contained in:
JeffBezanson 2009-11-18 17:38:16 +00:00
parent 3dc2275a07
commit 222eead750
6 changed files with 41 additions and 7 deletions

View File

@ -49,12 +49,20 @@
(define (rational? x) (integer? x))
(define (exact? x) (integer? x))
(define (inexact? x) (not (exact? x)))
(define (flonum? x) (not (exact? x)))
(define quotient div0)
(define remainder mod0)
(define (inexact x) x)
(define (exact x)
(if (exact? x) x
(error "exact real numbers not supported")))
(define (exact->inexact x) (double x))
(define (inexact->exact x)
(if (integer-valued? x)
(truncate x)
(error "exact real numbers not supported")))
(define (floor x) (if (< x 0) (truncate (- x 0.5)) (truncate x)))
(define (ceiling x) (if (< x 0) (truncate x) (truncate (+ x 0.5))))
(define (finite? x) (and (< x +inf.0) (> x -inf.0)))
(define (infinite? x) (or (equal? x +inf.0) (equal? x -inf.0)))
(define (nan? x) (or (equal? x +nan.0) (equal? x -nan.0)))
@ -146,6 +154,12 @@
(sizeof s))))
(io.write port s start (- end start))))
(define (io.skipws s)
(let ((c (io.peekc s)))
(if (and (not (eof-object? c)) (char-whitespace? c))
(begin (io.getc s)
(io.skipws s)))))
(define (with-output-to-file name thunk)
(let ((f (file name :write :create :truncate)))
(unwind-protect
@ -247,7 +261,14 @@
(and sp (has? sp key) (del! sp key))))))
; --- gambit
#|
(define arithmetic-shift ash)
(define bitwise-and logand)
(define bitwise-or logior)
(define bitwise-not lognot)
(define bitwise-xor logxor)
(define (include f) (load f))
(define (with-exception-catcher hand thk)
(trycatch (thk)
(lambda (e) (hand e))))
@ -255,5 +276,7 @@
(define make-table table)
(define table-ref get)
(define table-set! put!)
(define read-line io.readline)
|#
(define (read-line (s *input-stream*)) (io.readline s))
(define (shell-command s) 1)
(define (error-exception-message e) e)
(define (error-exception-parameters e) e)

View File

@ -281,7 +281,7 @@ static value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
value_t f, v;
if (nargs == 0)
lerror(ArgError, "vector.alloc: too few arguments");
i = tofixnum(args[0], "vector.alloc");
i = (fixnum_t)toulong(args[0], "vector.alloc");
if (i < 0)
lerror(ArgError, "vector.alloc: invalid size");
if (nargs == 2)

View File

@ -64,6 +64,8 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1);
}
if (iscprim(b)) {
if (cp_class((cprim_t*)ptr(b)) == wchartype)
return fixnum(1);
return fixnum(numeric_compare(a, b, eq, 1, NULL));
}
return fixnum(-1);
@ -77,6 +79,10 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
return bounded_vector_compare(a, b, bound, eq);
break;
case TAG_CPRIM:
if (cp_class((cprim_t*)ptr(a)) == wchartype &&
(!iscprim(b) ||
cp_class((cprim_t*)ptr(b)) != wchartype))
return fixnum(-1);
c = numeric_compare(a, b, eq, 1, NULL);
if (c != 2)
return fixnum(c);
@ -306,6 +312,8 @@ static uptrint_t bounded_hash(value_t a, int bound, int *oob)
case TAG_CPRIM:
cp = (cprim_t*)ptr(a);
data = cp_data(cp);
if (cp_class(cp) == wchartype)
return inthash(*(int32_t*)data);
nt = cp_numtype(cp);
u.d = conv_to_double(data, nt);
return doublehash(u.i64);

View File

@ -36,7 +36,7 @@
<= #fn("7000r2|}X17602|}W;" [] <=) >
#fn("7000r2}|X;" [] >) >= #fn("7000r2}|X17602|}W;" [] >=)
Instructions #table(not 16 vargc 67 load1 49 = 39 setc.l 64 sub2 72 brne.l 83 largc 74 brnn 85 loadc.l 58 loadi8 50 < 40 nop 0 set-cdr! 32 loada 55 bound? 21 / 37 neg 73 brn.l 88 lvargc 75 brt 7 trycatch 68 null? 17 load0 48 jmp.l 8 loadv 51 seta 61 keyargs 91 * 36 function? 26 builtin? 23 aref 43 optargs 89 vector? 24 loadt 45 brf 6 symbol? 19 cdr 30 for 69 loadc00 78 pop 2 pair? 22 cadr 84 closure 65 loadf 46 compare 41 loadv.l 52 setg.l 60 brn 87 eqv? 13 aset! 44 eq? 12 atom? 15 boolean? 18 brt.l 10 tapply 70 dummy_nil 94 loada0 76 brbound 90 list 28 dup 1 apply 33 loadc 57 loadc01 79 dummy_t 92 setg 59 loada1 77 tcall.l 81 jmp 5 fixnum? 25 cons 27 loadg.l 54 tcall 4 call 3 - 35 brf.l 9 + 34 dummy_f 93 add2 71 seta.l 62 loadnil 47 brnn.l 86 setc 63 set-car! 31 vector 42 loadg 53 loada.l 56 argc 66 div0 38 ret 11 number? 20 equal? 14 car 29 call.l 80 brne 82)
__init_globals #fn("7000r0c0c1<17B02c0c2<17802c0c3<6>0c4k52c6k75;0c8k52c9k72e:k;2e<k=2e>k?;" [linux
__init_globals #fn("7000r0e0c1<17B02e0c2<17802e0c3<6>0c4k52c6k75;0c8k52c9k72e:k;2e<k=2e>k?;" [*os-name*
win32 win64 windows "\\" *directory-separator* "\r\n" *linefeed* "/" "\n"
*stdout* *output-stream* *stdin* *input-stream* *stderr* *error-stream*] __init_globals)
__script #fn("7000r1c0qc1t;" [#fn("7000r0e0~41;" [load])
@ -275,7 +275,7 @@
*print-width*
*print-readably*
*print-level*
*print-length*)] make-system-image)
*print-length* *os-name*)] make-system-image)
map #fn("<000s2c0q^^42;" [#fn("9000r2c0m02c1qm12i02\x85;0|~\x7f_L143;}~\x7fi02K42;" [#fn("9000r3g2^}F6H02g2|}M31_KPNm22}Nm15\x17/2N;" [] map1)
#fn("<000r2}M\x8540_;|~c0}_L133Q2\x7f|~c1}_L13332K;" [#.car #.cdr] mapn)])] map)
map! #fn("9000r2}^}F6B02}|}M31O2}Nm15\x1d/2;" [] map!) map-int

View File

@ -966,7 +966,7 @@
(let ((f (file fname :write :create :truncate))
(excludes '(*linefeed* *directory-separator* *argv* that
*print-pretty* *print-width* *print-readably*
*print-level* *print-length*)))
*print-level* *print-length* *os-name*)))
(with-bindings ((*print-pretty* #t)
(*print-readably* #t))
(let ((syms

View File

@ -57,6 +57,9 @@
(assert (= (- 4999950000 4999941999) 8001))
(assert (not (eqv? 10 #\newline)))
(assert (not (eqv? #\newline 10)))
; tricky cases involving INT_MIN
(assert (< (- #uint32(0x80000000)) 0))
(assert (> (- #int32(0x80000000)) 0))