shithub: femtolisp

--- a/femtolisp/aliases.scm

+++ b/femtolisp/aliases.scm

@@ -49,6 +49,7 @@

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

@@ -55,6 +56,13 @@

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

--- a/femtolisp/builtins.c

+++ b/femtolisp/builtins.c

@@ -281,7 +281,7 @@

     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)

--- a/femtolisp/equal.c

+++ b/femtolisp/equal.c

@@ -64,6 +64,8 @@

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

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

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

--- a/femtolisp/flisp.boot

+++ b/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

--- a/femtolisp/system.lsp

+++ b/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

--- a/femtolisp/unittest.lsp

+++ b/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))