fixing char comparison bug
accepting more numeric types in vector.alloc adding more aliases
This commit is contained in:
parent
3dc2275a07
commit
222eead750
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
Loading…
Reference in New Issue