shithub: femtolisp

Info  •  Files  •  Log  •  Branches

make nan? a builtin; remove float nans

Fixes: https://todo.sr.ht/~ft/femtolisp/36

--- a/3rd/mp/test.c

+++ b/3rd/mp/test.c

@@ -4,7 +4,6 @@

 #include "ieee754.h"

 double D_PNAN, D_NNAN, D_PINF, D_NINF;

-float F_PNAN, F_NNAN, F_PINF, F_NINF;

 static int loops = 1;

 static char str[16][8192];

--- a/3rd/mp/test/main.c

+++ b/3rd/mp/test/main.c

@@ -5,7 +5,6 @@

 #include "ieee754.h"

 double D_PNAN, D_NNAN, D_PINF, D_NINF;

-float F_PNAN, F_NNAN, F_PINF, F_NINF;

 int anyfail = 0;

 void

@@ -20,12 +19,6 @@

 {

 	D_PNAN = D_NNAN = strtod("+NaN", nil);

 	D_PINF = D_NINF = strtod("+Inf", nil);

-

-	union ieee754_double *d;

-	d = (union ieee754_double *)&D_NNAN;

-	d->ieee.negative = 1;

-	d = (union ieee754_double *)&D_NINF;

-	d->ieee.negative = 1;

 	convtests();

 	tests();

--- a/compiler.lsp

+++ b/compiler.lsp

@@ -370,7 +370,7 @@

                     eq? 'eq?  symbol? 'symbol?

                     div0 'div0  builtin? 'builtin?

                     aset! 'aset!  - '-  boolean? 'boolean?  not 'not

-                    apply 'apply  atom? 'atom?

+                    apply 'apply  atom? 'atom? nan? 'nan?

                     set-cdr! 'set-cdr!  / '/

                     function? 'function?  vector 'vector

                     list 'list  bound? 'bound?

--- a/docs_extra.lsp

+++ b/docs_extra.lsp

@@ -12,6 +12,9 @@

 (doc-for (= a . rest)

   "Return #t if the arguments are equal.")

+(doc-for (nan? x)

+  "Return #t if the argument is NaN, regardless of the sign.")

+

 (doc-for (vm-stats)

   "Print various VM-related information, such as the number of GC calls

 so far, heap and stack size, etc.")

--- a/flisp.boot

+++ b/flisp.boot

@@ -13,11 +13,12 @@

 	      #fn("8000z0700}2:" #(/)) #fn("8000z0700}2:" #(div0))

 	      #fn("8000z0700}2:" #(=)) #fn("6000n201m:" #()) 0 #fn("8000z0700}2:" #(vector))

 	      #fn("8000z0700}2:" #(aset!)) 0 0 0 0 0 0 0 0 0 0 0 #fn("9000n3012082>1|:" #(#fn("6000n1A061:" #())))

-	      0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #fn("8000z0700}2:" #(aref)) 0 0)

+	      0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #fn("8000z0700}2:" #(aref)) 0 #fn("5000n10\x8e:" #())

+	      0)

 	    *properties* #table(*funvars* #table(>= ((a . rest))  void? ((x))  length= ((lst n))  help ((term))  lz-unpack ((data

   :to destination)

   (data :size decompressed-bytes))  = ((a . rest))  <= ((a . rest))  car ((lst))  /= ((a . rest))  void (rest)  *prompt* (nil)  nan? ((x))  lz-pack ((data

-  (level 0)))  cons? ((value))  vm-stats (nil)  * ((number…))  cdr ((lst))  > ((a . rest))  + ((number…)))  *doc* #table(+ "Return sum of the numbers or 0 with no arguments."  >= "Return #t if the arguments are in non-increasing order (previous\none is greater than or equal to the next one)."  void? "Return #t if x is #<void> and #f otherwise."  length= "Bounded length test.\nUse this instead of (= (length lst) n), since it avoids unnecessary\nwork and always terminates."  help "Display documentation for the specified term, if available."  lz-unpack "Return decompressed data previously compressed using lz-pack.\nEither destination for the decompressed data or the expected size of\nthe decompressed data must be specified.  In the latter case a new\narray is allocated."  = "Return #t if the arguments are equal."  <= "Return #t if the arguments are in non-decreasing order (previous\none is less than or equal to the next one)."  *builtins* "VM instructions as closures."  car "Returns the first element of a list or nil if not available."  /= "Return #t if not all arguments are equal. Shorthand for (not (= …))."  void "Return the constant #<void> while ignoring any arguments.\n#<void> is mainly used when a function has side effects but does not\nproduce any meaningful value to return, so even though #t or nil could\nbe returned instead, in case of #<void> alone, REPL will not print\nit."  arg-counts "VM instructions mapped to their expected arguments count."  nan? "Return #t if the argument is equal to NaN, regardless of the sign."  *prompt* "Function called by REPL to signal the user input is required.\nDefault function prints \"#;> \"."  Instructions "VM instructions mapped to their encoded byte representation."  lz-pack "Return data compressed using Lempel-Ziv.\nThe data must be an array, returned value will have the same type.\nThe optional level is between 0 and 10.  With level 0 a simple LZSS\nusing hashing will be performed.  Levels between 1 and 9 offer a\ntrade-off between time/space and ratio.  Level 10 is optimal but very\nslow."  vm-stats "Print various VM-related information, such as the number of GC calls\nso far, heap and stack size, etc."  cons? "Returns #t if the value is a cons cell."  * "Return product of the numbers or 1 with no arguments."  > "Return #t if the arguments are in strictly decreasing order (previous\none is greater than the next one)."  cdr "Returns the tail of a list or nil if not available."  *properties* "All properties of symbols recorded with putprop are recorded in this table."))

+  (level 0)))  cons? ((value))  vm-stats (nil)  * ((number…))  cdr ((lst))  > ((a . rest))  + ((number…)))  *doc* #table(+ "Return sum of the numbers or 0 with no arguments."  >= "Return #t if the arguments are in non-increasing order (previous\none is greater than or equal to the next one)."  void? "Return #t if x is #<void> and #f otherwise."  length= "Bounded length test.\nUse this instead of (= (length lst) n), since it avoids unnecessary\nwork and always terminates."  help "Display documentation for the specified term, if available."  lz-unpack "Return decompressed data previously compressed using lz-pack.\nEither destination for the decompressed data or the expected size of\nthe decompressed data must be specified.  In the latter case a new\narray is allocated."  = "Return #t if the arguments are equal."  <= "Return #t if the arguments are in non-decreasing order (previous\none is less than or equal to the next one)."  *builtins* "VM instructions as closures."  car "Returns the first element of a list or nil if not available."  /= "Return #t if not all arguments are equal. Shorthand for (not (= …))."  void "Return the constant #<void> while ignoring any arguments.\n#<void> is mainly used when a function has side effects but does not\nproduce any meaningful value to return, so even though #t or nil could\nbe returned instead, in case of #<void> alone, REPL will not print\nit."  arg-counts "VM instructions mapped to their expected arguments count."  *prompt* "Function called by REPL to signal the user input is required.\nDefault function prints \"#;> \"."  nan? "Return #t if the argument is NaN, regardless of the sign."  Instructions "VM instructions mapped to their encoded byte representation."  lz-pack "Return data compressed using Lempel-Ziv.\nThe data must be an array, returned value will have the same type.\nThe optional level is between 0 and 10.  With level 0 a simple LZSS\nusing hashing will be performed.  Levels between 1 and 9 offer a\ntrade-off between time/space and ratio.  Level 10 is optimal but very\nslow."  vm-stats "Print various VM-related information, such as the number of GC calls\nso far, heap and stack size, etc."  cons? "Returns #t if the value is a cons cell."  * "Return product of the numbers or 1 with no arguments."  > "Return #t if the arguments are in strictly decreasing order (previous\none is greater than the next one)."  cdr "Returns the tail of a list or nil if not available."  *properties* "All properties of symbols recorded with putprop are recorded in this table."))

 	    *runestring-type* (array rune) *string-type* (array byte)

 	    *syntax-environment* #table(throw #fn("9000n220212223e201e4e2:" #(raise list quote

 									      thrown-value))  unwind-protect #fn("A000n220502050218722q1e3e2e1232402286e12587e12686e2e3e3e387e1e3e3:" #(#fn(gensym)

@@ -52,12 +53,12 @@

 	    #fn("6000n10K~:" #() 1-) 1arg-lambda? #fn("7000n10B;3E04700<51;3:04710TK62:" #(is-lambda?

   length=) 1arg-lambda?)

 	    <= #fn("<000z1\x8d\x8a620862186>1_51486<0152S:" #(#0#

-							      #fn("7000n21J40O:1<0L2;IE0470051;I;04A<1<1=62:" #(nan?) f)) <=)

+							      #fn("7000n21J40O:1<0L2;IB040\x8e;I;04A<1<1=62:" #() f)) <=)

 	    > #fn("<000z1\x8d\x8a620862186>1_51486<0162:" #(#0#

 							    #fn("7000n21V;IE041<0L2;3;04A<1<1=62:" #() f)) >)

 	    >= #fn("<000z1\x8d\x8a620862186>1_51486<0152S:" #(#0#

-							      #fn("7000n21J40O:01<L2;IE0470051;I;04A<1<1=62:" #(nan?) f)) >=)

-	    Instructions #table(call.l 81  trycatch 75  largc 79  loadg.l 68  aref2 23  box 90  cadr 36  argc 62  setg 71  load0 21  vector? 45  fixnum? 41  loadc0 17  loada0 0  div0 59  keyargs 89  call 5  loada.l 69  brt.l 50  sub2 78  add2 29  loadc.l 70  loadc 9  builtin? 43  set-car! 47  brt 25  ret 10  loadi8 66  tapply 77  loadvoid 93  loada1 1  shift 46  boolean? 39  atom? 24  cdr 13  brne.l 83  / 58  loadf 31  equal? 52  apply 54  dup 11  loadt 20  jmp.l 48  null? 38  not 35  = 60  set-cdr! 30  eq? 33  * 57  load1 27  bound? 42  brf 3  function? 44  box.l 91  < 28  brnn.l 84  jmp 16  loadv 2  for 76  lvargc 80  dummy_eof 94  + 55  brne 19  compare 61  neg 37  loadv.l 67  number? 40  vargc 74  brn 85  brbound 88  vector 63  loadc1 22  setg.l 72  cons? 18  brf.l 49  aref 92  symbol? 34  aset! 64  car 12  cons 32  tcall.l 82  - 56  brn.l 86  optargs 87  closure 14  pop 4  eqv? 51  list 53  seta 15  seta.l 73  brnn 26  loadnil 65  loadg 7  loada 8  tcall 6)

+							      #fn("7000n21J40O:01<L2;IB040\x8e;I;04A<1<1=62:" #() f)) >=)

+	    Instructions #table(call.l 81  trycatch 75  largc 79  loadg.l 68  aref2 23  box 90  cadr 36  argc 62  setg 71  load0 21  nan? 94  vector? 45  fixnum? 41  loadc0 17  loada0 0  div0 59  keyargs 89  call 5  loada.l 69  brt.l 50  sub2 78  add2 29  loadc.l 70  loadc 9  builtin? 43  set-car! 47  brt 25  ret 10  loadi8 66  tapply 77  loadvoid 93  loada1 1  shift 46  boolean? 39  atom? 24  cdr 13  brne.l 83  / 58  loadf 31  equal? 52  apply 54  dup 11  loadt 20  jmp.l 48  null? 38  not 35  = 60  set-cdr! 30  eq? 33  * 57  load1 27  bound? 42  brf 3  function? 44  box.l 91  < 28  brnn.l 84  jmp 16  loadv 2  for 76  lvargc 80  dummy_eof 95  + 55  brne 19  compare 61  neg 37  loadv.l 67  number? 40  vargc 74  brn 85  brbound 88  vector 63  loadc1 22  setg.l 72  cons? 18  brf.l 49  aref 92  symbol? 34  aset! 64  car 12  cons 32  tcall.l 82  - 56  brn.l 86  optargs 87  closure 14  pop 4  eqv? 51  list 53  seta 15  seta.l 73  brnn 26  loadnil 65  loadg 7  loada 8  tcall 6)

 	    __init_globals #fn("5000n020w1422w3424w5476w7478w947:w;:" #(#fn("6000n0702161:" #(princ

   "#;> ")) *prompt* "/" *directory-separator* "\n" *linefeed* *stdout* *output-stream* *stdin*

 									*input-stream* *stderr*

@@ -75,7 +76,7 @@

 											__rcscript

 											repl #fn(exit)) __start)

 	    abs #fn("6000n10EL23500U:0:" #() abs) any

-	    #fn("7000n21B;3D0401<51;I:047001=62:" #(any) any) arg-counts #table(bound? 1  function? 1  symbol? 1  car 1  cons 2  cadr 1  for 3  boolean? 1  fixnum? 1  vector? 1  cdr 1  atom? 1  div0 2  equal? 2  eqv? 2  compare 2  null? 1  not 1  number? 1  set-cdr! 2  builtin? 1  eq? 2  cons? 1  set-car! 2)

+	    #fn("7000n21B;3D0401<51;I:047001=62:" #(any) any) arg-counts #table(bound? 1  function? 1  symbol? 1  car 1  cons 2  cadr 1  nan? 1  for 3  boolean? 1  fixnum? 1  vector? 1  cdr 1  atom? 1  div0 2  equal? 2  eqv? 2  compare 2  null? 1  not 1  number? 1  set-cdr! 2  builtin? 1  eq? 2  cons? 1  set-car! 2)

 	    argc-error #fn(";000n2702102211Kl237023@402465:" #(error "compile error: " " expects "

 							       " argument." " arguments.") argc-error)

 	    array? #fn("7000n10];IF042005185B;390485<21Q:" #(#fn(typeof) array) array?) assoc

@@ -99,7 +100,7 @@

   any splice-form? lastcdr #fn(map) #fn("7000n1700A62:" #(bq-bracket1))

   #fn(nconc) list* #fn("=000n20J;02071151P:0B3o00<22CX020731AEl23700=@C07425e2760=AK~52e252P:F<0=770<A521P62:2071760A521P51P:" #(nconc

   reverse! unquote nreconc list 'unquote bq-process bq-bracket))) bq-process)

-	    builtin->instruction #fn("8000n120A0O63:" #(#fn(get)) #(#table(#.cadr cadr  #.aset! aset!  #.+ +  #.- -  #.equal? equal?  #.eq? eq?  #.builtin? builtin?  #.not not  #.cons? cons?  #.cdr cdr  #./ /  #.div0 div0  #.set-car! set-car!  #.vector vector  #.set-cdr! set-cdr!  #.< <  #.for for  #.cons cons  #.apply apply  #.eqv? eqv?  #.vector? vector?  #.list list  #.aref aref  #.car car  #.bound? bound?  #.function? function?  #.null? null?  #.symbol? symbol?  #.compare compare  #.boolean? boolean?  #.fixnum? fixnum?  #.atom? atom?  #.= =  #.number? number?  #.* *)))

+	    builtin->instruction #fn("8000n120A0O63:" #(#fn(get)) #(#table(#.cadr cadr  #.aset! aset!  #.nan? nan?  #.+ +  #.- -  #.equal? equal?  #.eq? eq?  #.builtin? builtin?  #.not not  #.cons? cons?  #.cdr cdr  #./ /  #.div0 div0  #.set-car! set-car!  #.vector vector  #.set-cdr! set-cdr!  #.< <  #.for for  #.cons cons  #.apply apply  #.eqv? eqv?  #.vector? vector?  #.list list  #.aref aref  #.car car  #.bound? bound?  #.function? function?  #.null? null?  #.symbol? symbol?  #.compare compare  #.boolean? boolean?  #.fixnum? fixnum?  #.atom? atom?  #.= =  #.number? number?  #.* *)))

 	    caaaar #fn("5000n10<<<<:" #() caaaar) caaadr

 	    #fn("5000n10T<<:" #() caaadr) caaar #fn("5000n10<<<:" #() caaar) caadar

 	    #fn("5000n10<T<:" #() caadar) caaddr #fn("5000n10=T<:" #() caaddr) caadr

@@ -324,11 +325,11 @@

 	    #fn(";000z11J400:70210163:" #(foldl #fn("6000n201L23401:0:" #())) max) member #fn("7000n21J40O:1<0d3401:7001=62:" #(member) member)

 	    memv #fn("7000n21J40O:1<0c3401:7001=62:" #(memv) memv) min

 	    #fn(";000z11J400:70210163:" #(foldl #fn("6000n201L23400:1:" #())) min) mod #fn("8000n207001521i2~:" #(div) mod)

-	    mod0 #fn("7000n2001k1i2~:" #() mod0) nan?

-	    #fn("6000n1020d;I704021d:" #(+nan.0 -nan.0) nan?) negative? #fn("6000n10EL2:" #() negative?)

-	    nestlist #fn(":000n37082E52340q:1710015182K~53P:" #(<= nestlist) nestlist) newline

-	    #fn("8000\x8700001000\x880000I7070?04210725247360:" #(*output-stream* #fn(io-write)

-								  *linefeed* void) newline)

+	    mod0 #fn("7000n2001k1i2~:" #() mod0) negative?

+	    #fn("6000n10EL2:" #() negative?) nestlist #fn(":000n37082E52340q:1710015182K~53P:" #(<=

+  nestlist) nestlist)

+	    newline #fn("8000\x8700001000\x880000I7070?04210725247360:" #(*output-stream* #fn(io-write)

+									  *linefeed* void) newline)

 	    nreconc #fn("7000n2701062:" #(reverse!-) nreconc) odd?

 	    #fn("6000n170051S:" #(even?) odd?) partition #fn(":000n2\x8d2021?65148601qe1qe164:" #(#0#

   #fn("9000n48283P\x8d1B3Z0401<513?0821<qPN=?2@<0831<qPN=?341=?1@\x05/47088<=88==62:" #(values) partition-)) partition)

binary files a/flisp.boot.builtin b/flisp.boot.builtin differ

--- a/flisp.h

+++ b/flisp.h

@@ -446,6 +446,5 @@

 extern value_t FL_stringtypesym, FL_runestringtypesym;

 extern double D_PNAN, D_NNAN, D_PINF, D_NINF;

-extern float F_PNAN, F_NNAN, F_PINF, F_NINF;

 _Noreturn void flmain(const uint8_t *boot, int bootsz, int argc, char **argv);

--- a/flmain.c

+++ b/flmain.c

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

 #include "brieflz.h"

 double D_PNAN, D_NNAN, D_PINF, D_NINF;

-float F_PNAN, F_NNAN, F_PINF, F_NINF;

 static value_t

 argv_list(int argc, char *argv[])

--- a/gen.lsp

+++ b/gen.lsp

@@ -99,6 +99,7 @@

     OP_BOXL           box.l      #f      0 ()

     OP_AREF           aref       -2      (λ rest (apply aref rest)) ()

     OP_LOADVOID       loadvoid   #f      0 ()

+    OP_NANP           nan?       1       (λ (x) (nan? x)) ()

     OP_EOF_OBJECT     dummy_eof  #f      0 ()

 ))

--- a/ieee754.h

+++ b/ieee754.h

@@ -1,25 +1,5 @@

 #pragma once

-union ieee754_float {

-	float f;

-

-	struct {

-#if BYTE_ORDER == BIG_ENDIAN

-	unsigned int negative:1;

-	unsigned int exponent:8;

-	unsigned int mantissa:23;

-#elif BYTE_ORDER == LITTLE_ENDIAN

-	unsigned int mantissa:23;

-	unsigned int exponent:8;

-	unsigned int negative:1;

-#else

-#error which endian?

-#endif

-	}ieee;

-};

-

-#define IEEE754_FLOAT_BIAS 0x7f

-

 union ieee754_double {

 	double d;

--- a/main_plan9.c

+++ b/main_plan9.c

@@ -9,11 +9,5 @@

 	argv0 = argv[0];

 	setfcr(FPPDBL|FPRNR|FPOVFL);

 	tmfmtinstall();

-

-	*(uint32_t*)&F_PNAN = 0x7fc00000;

-	*(uint32_t*)&F_NNAN = 0xffc00000;

-	*(uint32_t*)&F_PINF = 0x7f800000;

-	*(uint32_t*)&F_NINF = 0xff800000;

-

 	flmain(bootcode, bootlen, argc, argv);

 }

--- a/main_posix.c

+++ b/main_posix.c

@@ -1,5 +1,4 @@

 #include "flisp.h"

-#include "ieee754.h"

 static const uint8_t boot[] = {

 #include "flisp.boot.h"

@@ -8,15 +7,6 @@

 int

 main(int argc, char **argv)

 {

-	union ieee754_float *f;

-	F_PNAN = F_NNAN = strtof("+NaN", nil);

-	F_PINF = F_NINF = strtof("+Inf", nil);

-	f = (union ieee754_float *)&F_NNAN;

-	f->ieee.negative = 1;

-	f = (union ieee754_float *)&F_NINF;

-	f->ieee.negative = 1;

-

 	setlocale(LC_NUMERIC, "C");

-

 	flmain(boot, sizeof(boot), argc, argv);

 }

--- a/maxstack.inc

+++ b/maxstack.inc

@@ -150,7 +150,7 @@

 		case OP_CONSP: case OP_ATOMP: case OP_SYMBOLP:

 		case OP_NULLP: case OP_BOOLEANP: case OP_NUMBERP:

 		case OP_FIXNUMP: case OP_BOUNDP: case OP_BUILTINP:

-		case OP_FUNCTIONP: case OP_VECTORP:

+		case OP_FUNCTIONP: case OP_VECTORP: case OP_NANP:

 			continue;

 		case OP_EOF_OBJECT: case N_OPCODES:

--- a/opcodes.c

+++ b/opcodes.c

@@ -2,6 +2,7 @@

 const Builtin builtins[N_OPCODES] = {

 	[OP_SETCAR] = {"set-car!", 2},

+	[OP_NANP] = {"nan?", 1},

 	[OP_CDR] = {"cdr", 1},

 	[OP_BOOLEANP] = {"boolean?", 1},

 	[OP_FUNCTIONP] = {"function?", 1},

--- a/opcodes.h

+++ b/opcodes.h

@@ -93,6 +93,7 @@

 	OP_BOXL,

 	OP_AREF,

 	OP_LOADVOID,

+	OP_NANP,

 	OP_EOF_OBJECT,

 	N_OPCODES

 }opcode_t;

--- a/system.lsp

+++ b/system.lsp

@@ -173,11 +173,6 @@

         ((eqv? (caar lst) item) (car lst))

         (#t                     (assv item (cdr lst)))))

-(define (nan? x)

-  "Return #t if the argument is equal to NaN, regardless of the sign."

-  (or (equal? x +nan.0)

-      (equal? x -nan.0)))

-

 (define (> a . rest)

   "Return #t if the arguments are in strictly decreasing order (previous

 one is greater than the next one)."

--- a/test/unittest.lsp

+++ b/test/unittest.lsp

@@ -118,6 +118,10 @@

          (ash 11112222333344445555666677778888 64)))

 ; NaNs

+(assert (nan? +nan.0))

+(assert (nan? -nan.0))

+(assert (nan? (float +nan.0)))

+(assert (nan? (float -nan.0)))

 (assert (equal? +nan.0 +nan.0))

 (assert (equal? -nan.0 -nan.0))

 (assert (/= +nan.0 +nan.0))

--- a/vm.inc

+++ b/vm.inc

@@ -425,6 +425,29 @@

 	FL(stack)[FL(sp)-1] = fl_neg(FL(stack)[FL(sp)-1]);

 	NEXT_OP;

+OP(OP_NANP)

+	{

+		value_t x = FL(stack)[FL(sp)-1];

+		v = FL_f;

+		if(iscprim(x)){

+			void *data = cp_data(ptr(x));

+			switch(cp_numtype(ptr(x))){

+			case T_DOUBLE:

+				if(isnan(*(double*)data))

+					v = FL_t;

+				break;

+			case T_FLOAT:

+				if(isnan(*(float*)data))

+					v = FL_t;

+				break;

+			default:

+				break;

+			}

+		}

+		FL(stack)[FL(sp)-1] = v;

+	}

+	NEXT_OP;

+

 OP(OP_NULLP)

 	FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-1] == FL_nil ? FL_t : FL_f;

 	NEXT_OP;

--- a/vm_goto.inc

+++ b/vm_goto.inc

@@ -92,3 +92,4 @@

 GOTO_OP_OFFSET(OP_BOXL),

 GOTO_OP_OFFSET(OP_SHIFT),

 GOTO_OP_OFFSET(OP_LOADVOID),

+GOTO_OP_OFFSET(OP_NANP),