fixing char comparison bug

accepting more numeric types in vector.alloc
adding more aliases

femtolisp/aliases.scm

@@ -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)

femtolisp/builtins.c

@@ -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)

femtolisp/equal.c

@@ -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);

femtolisp/flisp.boot

@@ -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

femtolisp/system.lsp

@@ -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

femtolisp/unittest.lsp

@@ -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))