Enable to set dicimal digits for printing floating number

.travis.sh

@@ -170,7 +170,7 @@ fi
     # run test in jskeus/irteus
     for test_l in irteus/test/*.l; do
 
-        [[ ("`uname -m`" == "arm"* || "`uname -m`" == "aarch"*) && $test_l =~ geo.l|mathtest.l|interpolator.l|test-irt-motion.l|test-pointcloud.l|irteus-demo.l ]] && continue;
+        [[ ("`uname -m`" == "arm"* || "`uname -m`" == "aarch"*) && $test_l =~ geo.l|mathtest.l|interpolator.l|test-irt-motion.l|irteus-demo.l ]] && continue;
 
         travis_time_start irteus.${test_l##*/}.test
 

doc/jlatex/jio.tex

@@ -319,6 +319,7 @@ \subsection{プリンタ(printer)}
 \item[*print-escape*] 現在使用されていない。
 \item[*print-pretty*] 現在使用されていない。
 \item[*print-base*] 印刷時の基数；デフォルトは10進数
+\item[*print-precision*] 浮動少数点印刷時の桁数；64ビット時に17、32ビット時に9を選択すると、その文字列から元の値を保持できる。
 \end{description}
 
 再帰的参照を持つオブジェクトを印刷するためには、

doc/latex/io.tex

@@ -333,6 +333,7 @@ \subsection{Printer}
 \item[*print-escape*] currently not used
 \item[*print-pretty*] currently not used
 \item[*print-base*] number base in printing; defaulted to decimal ten
+\item[*print-precision*] dicimal digits of floating number. to recover original number from character representation, choose 17 for 64 bit machine and 9 for 32bit machine
 \end{description}
 
 In order to print objects containing recursive references 

lisp/c/eus.c

@@ -168,7 +168,7 @@ static pointer reploop(context *, char *);
 
 pointer ALLOWOTHERKEYS,K_ALLOWOTHERKEYS;
 pointer OPTIONAL,REST,KEY,AUX,MACRO,LAMBDA,LAMCLOSURE,COMCLOSURE;
-pointer PRCIRCLE,PROBJECT,PRSTRUCTURE,PRCASE,PRLENGTH,PRLEVEL;
+pointer PRCIRCLE,PROBJECT,PRSTRUCTURE,PRCASE,PRLENGTH,PRLEVEL,PRPRECISION;
 pointer RANDSTATE,FEATURES,READBASE,PRINTBASE,QREADTABLE,QTERMIO;
 pointer GCMERGE,GCMARGIN, QLDENT;
 pointer K_PRIN1;
@@ -656,6 +656,7 @@ static void initsymbols()
   PRSTRUCTURE=deflocal(ctx,"*PRINT-STRUCTURE*",NIL,lisppkg);
   PRLENGTH=deflocal(ctx,"*PRINT-LENGTH*",NIL,lisppkg);
   PRLEVEL=deflocal(ctx,"*PRINT-LEVEL*",NIL,lisppkg);
+  PRPRECISION=deflocal(ctx,"*PRINT-PRECISION*",NIL,lisppkg);
   QREADTABLE=deflocal(ctx,"*READTABLE*",NIL,lisppkg);
   TOPLEVEL=defvar(ctx,"*TOPLEVEL*",NIL,lisppkg);
   ERRHANDLER=deflocal(ctx,"*ERROR-HANDLER*",NIL,lisppkg);

lisp/c/printer.c

@@ -20,7 +20,7 @@ static char *rcsid="@(#)$Id$";
 #define to_upper(c) (islower(c) ? ((c)-'a'+'A') : (c))
 #define to_lower(c) (isupper(c) ? ((c)-'A'+'a') : (c))
 
-extern pointer PRCIRCLE,PROBJECT,PRSTRUCTURE,PRCASE,PRLENGTH,PRLEVEL,PRINTBASE;
+extern pointer PRCIRCLE,PROBJECT,PRSTRUCTURE,PRCASE,PRLENGTH,PRLEVEL,PRINTBASE,PRPRECISION;
 extern pointer QREADTABLE;
 extern pointer K_PRIN1;
 static void prin1(context *, pointer, pointer, int);
@@ -182,6 +182,20 @@ int base, field1, field2;
   writestr(f,(byte *)&work[i],65-i);
   }
 
+static pointer printfltpre(num,f,p)
+double num;
+pointer f;
+int p;
+{ char* work;
+  register int len;
+  if (num==0.0) writestr(f,(byte *)"0.0",3);
+  else{
+    work=(char *)malloc((p+6)*sizeof(char));
+    sprintf(work,"%1.*g",p,num);
+    len=strlen(work);
+    writestr(f,(byte *)work,len);
+    free(work);}}
+
 static pointer printflt(num,f)
 double num;
 pointer f;
@@ -279,6 +293,7 @@ int field1, field2;
 { numunion nu;
 
   if (isint(nump)) printint(ctx,intval(nump), strm, base, field1, field2);
+  else if (isflt(nump) && Spevalof(PRPRECISION)!=NIL && isint(Spevalof(PRPRECISION))) printfltpre(fltval(nump),strm,intval(Spevalof(PRPRECISION)));
   else if (isflt(nump)) printflt(fltval(nump),strm);
   else if (pisbignum(nump)) printbig(ctx,nump, strm, base, field1, field2);
   else if (pisratio(nump)) printratio(ctx, nump, strm, base);
@@ -377,7 +392,10 @@ int prlevel;
     case ELM_FLOAT:
 	  writestr(f,(byte *)"#f(",3);
 	  while (i<n && prlength>0) {
-	    printflt(vec->c.fvec.fv[i++],f);
+	    if (Spevalof(PRPRECISION)!=NIL && isint(Spevalof(PRPRECISION)))
+	      printfltpre(vec->c.fvec.fv[i++],f,intval(Spevalof(PRPRECISION)));
+	    else
+	      printflt(vec->c.fvec.fv[i++],f);
 	    if(i<n) writech(f,' ');
 	    prlength--; }
 	  if (i<n) writestr(f,(byte *)"... ",4);
@@ -427,7 +445,11 @@ int prlevel,index;
 			0,0);
 	  break;
     case ELM_FLOAT:
-	  printflt(vec->c.fvec.fv[index],f); break;
+	  if (Spevalof(PRPRECISION)!=NIL && isint(Spevalof(PRPRECISION)))
+	    printfltpre(vec->c.fvec.fv[index],f,intval(Spevalof(PRPRECISION)));
+	  else
+	    printflt(vec->c.fvec.fv[index],f);
+	  break;
     default:
 	  prin1(ctx,vec->c.vec.v[index],f,prlevel);
     }}

lisp/comp/trans.l

@@ -168,13 +168,13 @@
 	     f))))
  (:load-t () (send self :push "T"))
  (:load-nil () (send self :push "NIL"))
-#-:x86_64
+ #-(or :x86_64 :aarch64)
  (:load-int (x) (send self :push (format nil "makeint(~d)" x)))
-#+:x86_64
+#+(or :x86_64 :aarch64)
  (:load-int (x) (send self :push (format nil "makeint((eusinteger_t)~dL)" x)))
-#-:x86_64
+#-(or :x86_64 :aarch64)
  (:load-float (x) (send self :push (format nil "makeflt(~8,8e)" x)))
-#+:x86_64
+#+(or :x86_64 :aarch64)
  (:load-float (x) (send self :push (format nil "makeflt(~22,22e)" x)))
 )
 
@@ -676,6 +676,8 @@ register context *ctx; int n; pointer *argv; pointer env;~%" entry)
     (format hfile "#define QUOTE_STRINGS_SIZE ~d~%" (length quotev))
     (format hfile "~astatic char *quote_strings[QUOTE_STRINGS_SIZE]={~%"
 	(if (memq :solaris2 *features*) "const " ""))
+    (let ((pre lisp::*print-precision*))
+    (setq lisp::*print-precision* (if (= lisp::sizeof-* 4) 9 17))
     (dolist (q quotev)
        (let* ((s (prin1-to-string q)) (len (length s)) (ch))
 	  (format hfile "    \"")
@@ -689,6 +691,7 @@ register context *ctx; int n; pointer *argv; pointer env;~%" entry)
 		   (t (write-byte (char s i) hfile))))
 	  (format hfile "\",~%")))
      (format hfile "  };~%")
+     (setq lisp::*print-precision* pre))
     )
  (:declare-ftab ()
     (if (> ftab-next 0)

lisp/l/exports.l

@@ -20,7 +20,7 @@
   ;; type specifiers
   (export '(integer float fixnum number))
   (export '(*print-case* *print-circle* *print-object* *print-structure*
-		*print-length* *print-level*
+		*print-length* *print-level* *print-precision*
 		*readtable* *toplevel* *read-base* *print-base*
 		*error-handler* *evalhook* *debug*
 		*unbound* *random-state* *features*

test/mathtest.l

@@ -152,6 +152,13 @@
     (format *error-output* "~A ~A~%" (+ (expt 2 32) 1234) (abs (+ (expt 2 32) 1234)))
     ))
 
+(deftest compile-float-vector
+  ;; if (float-vector 792.732209445) translated to local[1]= makeflt(7.92732209e+02), it reduces precision
+  (warning-message 2 "#f(792.732209445) ~A~%" #f(792.732209445))
+  (warning-message 2 "(float-vector 792.732209445) ~A~%" (float-vector 792.732209445))
+  (assert (< (norm (v- #f(792.732209445) (float-vector 792.732209445))) 1.0e-7)
+	  (format nil "(norm (v- #f(792.732209445) (float-vector 792.732209445))) should be zero, but ~A~%" (norm (v- #f(792.732209445) (float-vector 792.732209445))))))
+
 (eval-when (load eval)
   (run-all-tests)
   (exit))