/[emacs]/emacs/lisp/emacs-lisp/float.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/float.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.13 by pj, Sun Jul 15 16:15:34 2001 UTC revision 1.13.8.1 by miles, Fri Apr 4 06:20:16 2003 UTC
# Line 39  Line 39 
39  ;; function string-to-float converts from string to floating point  ;; function string-to-float converts from string to floating point
40  ;; function fint converts a floating point to integer (with truncation)  ;; function fint converts a floating point to integer (with truncation)
41  ;; function float-to-string converts from floating point to string  ;; function float-to-string converts from floating point to string
42  ;;                    ;;
43  ;; Caveats:  ;; Caveats:
44  ;; -  Exponents outside of the range of +/-100 or so will cause certain  ;; -  Exponents outside of the range of +/-100 or so will cause certain
45  ;;    functions (especially conversion routines) to take forever.  ;;    functions (especially conversion routines) to take forever.
46  ;; -  Very little checking is done for fixed point overflow/underflow.  ;; -  Very little checking is done for fixed point overflow/underflow.
47  ;; -  No checking is done for over/underflow of the exponent  ;; -  No checking is done for over/underflow of the exponent
48  ;;    (hardly necessary when exponent can be 2**23).  ;;    (hardly necessary when exponent can be 2**23).
49  ;;  ;;
50  ;;  ;;
51  ;; Bill Rosenblatt  ;; Bill Rosenblatt
52  ;; June 20, 1986  ;; June 20, 1986
# Line 131  Line 131 
131            (setq fnum (fashl fnum)))            (setq fnum (fashl fnum)))
132        (setq fnum _f0)))                 ; "standard 0"        (setq fnum _f0)))                 ; "standard 0"
133    fnum)    fnum)
134          
135  (defun abs (n)                          ; integer absolute value  (defun abs (n)                          ; integer absolute value
136    (if (>= n 0) n (- n)))    (if (>= n 0) n (- n)))
137    
# Line 204  Line 204 
204    (if (zerop (car a2))                  ; if divide by 0    (if (zerop (car a2))                  ; if divide by 0
205        (signal 'arith-error (list "attempt to divide by zero" a1 a2))        (signal 'arith-error (list "attempt to divide by zero" a1 a2))
206      (let ((bits (1- maxbit))      (let ((bits (1- maxbit))
207            (quotient 0)            (quotient 0)
208            (dividend (car (fabs a1)))            (dividend (car (fabs a1)))
209            (divisor (car (fabs a2)))            (divisor (car (fabs a2)))
210            (sign (not (same-sign a1 a2))))            (sign (not (same-sign a1 a2))))
# Line 218  Line 218 
218        (normalize        (normalize
219         (cons (if sign (- quotient) quotient)         (cons (if sign (- quotient) quotient)
220               (- (cdr (fabs a1)) (cdr (fabs a2)) (1- maxbit)))))))               (- (cdr (fabs a1)) (cdr (fabs a2)) (1- maxbit)))))))
221      
222  (defun f% (a1 a2)  (defun f% (a1 a2)
223    "Returns the remainder of first floating point number divided by second."    "Returns the remainder of first floating point number divided by second."
224    (f- a1 (f* (ftrunc (f/ a1 a2)) a2)))    (f- a1 (f* (ftrunc (f/ a1 a2)) a2)))
225              
226    
227  ;; Comparison functions  ;; Comparison functions
228  (defun f= (a1 a2)  (defun f= (a1 a2)
# Line 232  Line 232 
232  (defun f> (a1 a2)  (defun f> (a1 a2)
233    "Returns t if first floating point number is greater than second,    "Returns t if first floating point number is greater than second,
234  nil otherwise."  nil otherwise."
235    (cond ((and (natnump (car a1)) (< (car a2) 0))    (cond ((and (natnump (car a1)) (< (car a2) 0))
236           t)                             ; a1 nonnegative, a2 negative           t)                             ; a1 nonnegative, a2 negative
237          ((and (> (car a1) 0) (<= (car a2) 0))          ((and (> (car a1) 0) (<= (car a2) 0))
238           t)                             ; a1 positive, a2 nonpositive           t)                             ; a1 positive, a2 nonpositive
# Line 244  nil otherwise." Line 244  nil otherwise."
244           (> (car a1) (car a2)))))       ; same exponents.           (> (car a1) (car a2)))))       ; same exponents.
245    
246  (defun f>= (a1 a2)  (defun f>= (a1 a2)
247    "Returns t if first floating point number is greater than or equal to    "Returns t if first floating point number is greater than or equal to
248  second, nil otherwise."  second, nil otherwise."
249    (or (f> a1 a2) (f= a1 a2)))    (or (f> a1 a2) (f= a1 a2)))
250    
# Line 270  nil otherwise." Line 270  nil otherwise."
270  (defun fmax (a1 a2)  (defun fmax (a1 a2)
271    "Returns the maximum of two floating point numbers."    "Returns the maximum of two floating point numbers."
272    (if (f> a1 a2) a1 a2))    (if (f> a1 a2) a1 a2))
273          
274  (defun fzerop (fnum)  (defun fzerop (fnum)
275    "Returns t if the floating point number is zero, nil otherwise."    "Returns t if the floating point number is zero, nil otherwise."
276    (= (car fnum) 0))    (= (car fnum) 0))
# Line 290  nil otherwise." Line 290  nil otherwise."
290          (str "0x")          (str "0x")
291          (hex-chars "0123456789ABCDEF"))          (hex-chars "0123456789ABCDEF"))
292      (while (<= shiftval 0)      (while (<= shiftval 0)
293        (setq str (concat str (char-to-string        (setq str (concat str (char-to-string
294                          (aref hex-chars                          (aref hex-chars
295                                (logand (lsh int shiftval) 15))))                                (logand (lsh int shiftval) 15))))
296              shiftval (+ shiftval 4)))              shiftval (+ shiftval 4)))
# Line 304  nil otherwise." Line 304  nil otherwise."
304           '(0 . 1))           '(0 . 1))
305          (t                              ; otherwise mask out fractional bits          (t                              ; otherwise mask out fractional bits
306           (let ((mant (car fnum)) (exp (cdr fnum)))           (let ((mant (car fnum)) (exp (cdr fnum)))
307             (normalize             (normalize
308              (cons (if (natnump mant)    ; if negative, use absolute value              (cons (if (natnump mant)    ; if negative, use absolute value
309                        (ash (ash mant exp) (- exp))                        (ash (ash mant exp) (- exp))
310                      (- (ash (ash (- mant) exp) (- exp))))                      (- (ash (ash (- mant) exp) (- exp))))
311                    exp))))))                    exp))))))
312    
313  (defun fint (fnum)                      ; truncate and convert to integer  (defun fint (fnum)                      ; truncate and convert to integer
314    "Convert the floating point number to integer, with truncation,    "Convert the floating point number to integer, with truncation,
315  like a C cast operator."  like a C cast operator."
316    (let* ((tf (ftrunc fnum)) (tint (car tf)) (texp (cdr tf)))    (let* ((tf (ftrunc fnum)) (tint (car tf)) (texp (cdr tf)))
317      (cond ((>= texp mantissa-bits)      ; too high, return "maxint"      (cond ((>= texp mantissa-bits)      ; too high, return "maxint"
# Line 325  like a C cast operator." Line 325  like a C cast operator."
325    "Convert the floating point number to a decimal string.    "Convert the floating point number to a decimal string.
326  Optional second argument non-nil means use scientific notation."  Optional second argument non-nil means use scientific notation."
327    (let* ((value (fabs fnum)) (sign (< (car fnum) 0))    (let* ((value (fabs fnum)) (sign (< (car fnum) 0))
328           (power 0) (result 0) (str "")           (power 0) (result 0) (str "")
329           (temp 0) (pow10 _f1))           (temp 0) (pow10 _f1))
330    
331      (if (f= fnum _f0)      (if (f= fnum _f0)
# Line 386  Optional second argument non-nil means u Line 386  Optional second argument non-nil means u
386            (concat "-" str)            (concat "-" str)
387          str))))          str))))
388    
389        
390  ;; string to float conversion.  ;; string to float conversion.
391  ;; accepts scientific notation, but ignores anything after the first two  ;; accepts scientific notation, but ignores anything after the first two
392  ;; digits of the exponent.  ;; digits of the exponent.
393  (defun string-to-float (str)  (defun string-to-float (str)
394    "Convert the string to a floating point number.    "Convert the string to a floating point number.
395  Accepts a decimal string in scientific notation,  with exponent preceded  Accepts a decimal string in scientific notation, with exponent preceded
396  by either E or e.  Only the six most significant digits of the integer  by either E or e.  Only the six most significant digits of the integer
397  and fractional parts are used; only the first two digits of the exponent  and fractional parts are used; only the first two digits of the exponent
398  are used.  Negative signs preceding both the decimal number and the exponent  are used.  Negative signs preceding both the decimal number and the exponent
# Line 415  are recognized." Line 415  are recognized."
415               (setq leading-0s (1+ leading-0s)))               (setq leading-0s (1+ leading-0s)))
416             (setq power (- power leading-0s)             (setq power (- power leading-0s)
417                   digit-string (substring digit-string leading-0s))                   digit-string (substring digit-string leading-0s))
418              
419             ; if more than 6 digits, round off             ; if more than 6 digits, round off
420             (if (> (length digit-string) decimal-digits)             (if (> (length digit-string) decimal-digits)
421                 (setq round-up (>= (aref digit-string decimal-digits) ?5)                 (setq round-up (>= (aref digit-string decimal-digits) ?5)
# Line 426  are recognized." Line 426  are recognized."
426             (f (* (+ (string-to-int digit-string)             (f (* (+ (string-to-int digit-string)
427                      (if round-up 1 0))                      (if round-up 1 0))
428                   (if mant-sign -1 1))))                   (if mant-sign -1 1))))
429              
430           ; calculate the exponent (power of ten)           ; calculate the exponent (power of ten)
431           (let* ((expt-subst (extract-match str 9))           (let* ((expt-subst (extract-match str 9))
432                  (expt-sign (equal (extract-match str 8) "-"))                  (expt-sign (equal (extract-match str 8) "-"))
433                  (expt 0) (chunks 0) (tens 0) (exponent _f1)                  (expt 0) (chunks 0) (tens 0) (exponent _f1)
434                  (func 'f*))                  (func 'f*))
435    
436             (setq expt (+ (* (string-to-int             (setq expt (+ (* (string-to-int
437                               (substring expt-subst 0                               (substring expt-subst 0
438                                          (min expt-digits (length expt-subst))))                                          (min expt-digits (length expt-subst))))
# Line 445  are recognized." Line 445  are recognized."
445             (setq chunks (/ expt decimal-digits)             (setq chunks (/ expt decimal-digits)
446                   tens (% expt decimal-digits))                   tens (% expt decimal-digits))
447             ; divide or multiply by "chunks" of 10**6             ; divide or multiply by "chunks" of 10**6
448             (while (> chunks 0)               (while (> chunks 0)
449               (setq exponent (funcall func exponent highest-power-of-10)               (setq exponent (funcall func exponent highest-power-of-10)
450                     chunks (1- chunks)))                     chunks (1- chunks)))
451             ; divide or multiply by remaining power of ten             ; divide or multiply by remaining power of ten
452             (funcall func exponent (aref powers-of-10 tens)))))             (funcall func exponent (aref powers-of-10 tens)))))
453                      
454      _f0))                               ; if invalid, return 0      _f0))                               ; if invalid, return 0
455    
456  (provide 'float)  (provide 'float)

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.13.8.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26