diff --git a/.travis.sh b/.travis.sh index cffda89cb..5e9321c3c 100755 --- a/.travis.sh +++ b/.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 diff --git a/doc/jlatex/jio.tex b/doc/jlatex/jio.tex index b01235fd0..924e3b1b4 100644 --- a/doc/jlatex/jio.tex +++ b/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} 再帰的参照を持つオブジェクトを印刷するためには、 diff --git a/doc/latex/io.tex b/doc/latex/io.tex index eea9bf9a1..42cf56fc9 100644 --- a/doc/latex/io.tex +++ b/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 diff --git a/lisp/c/eus.c b/lisp/c/eus.c index a476c72f5..9c683572c 100644 --- a/lisp/c/eus.c +++ b/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); diff --git a/lisp/c/printer.c b/lisp/c/printer.c index d7e8d41f2..1f07565f8 100644 --- a/lisp/c/printer.c +++ b/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 (i0) { - 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(ic.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); }} diff --git a/lisp/comp/trans.l b/lisp/comp/trans.l index ab8012706..3d7880e91 100644 --- a/lisp/comp/trans.l +++ b/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) diff --git a/lisp/l/exports.l b/lisp/l/exports.l index d74d3c120..a169d762a 100644 --- a/lisp/l/exports.l +++ b/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* diff --git a/test/mathtest.l b/test/mathtest.l index 52f142578..d8b9716cb 100644 --- a/test/mathtest.l +++ b/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))