diff --git a/femtolisp/aliases.scm b/femtolisp/aliases.scm index 78700e8..3e00163 100644 --- a/femtolisp/aliases.scm +++ b/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) diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index d45f899..5613277 100644 --- a/femtolisp/builtins.c +++ b/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) diff --git a/femtolisp/equal.c b/femtolisp/equal.c index ef92f53..c953364 100644 --- a/femtolisp/equal.c +++ b/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); diff --git a/femtolisp/flisp.boot b/femtolisp/flisp.boot index 04dd1fc..a331b21 100644 --- 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;2ek?;" [linux + __init_globals #fn("7000r0e0c1<17B02e0c2<17802e0c3<6>0c4k52c6k75;0c8k52c9k72e:k;2ek?;" [*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 diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 51062ad..854c04b 100644 --- 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 diff --git a/femtolisp/unittest.lsp b/femtolisp/unittest.lsp index 7b1fd4b..27254b0 100644 --- 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))