cmpnum.lsp 3.82 KB
Newer Older
jgarcia's avatar
jgarcia committed
1
2
;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
3
4
5
6
7
8
9
10
11
12
13
14
15
16
;;;; CMPNUM -- Optimizer for numerical expressions.

;;;;  Copyright (c) 2005, Juan Jose Garcia Ripoll
;;;;
;;;;    ECoLisp is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Library General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 2 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../Copyright' for full details.

(in-package "COMPILER")

(defun simplify-arithmetic (operator args whole)
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
  (if (every #'numberp args)
      (apply operator args)
      (let ((l (length args)))
        (cond ((> l 2)
               (simplify-arithmetic
                operator
                (list* (simplify-arithmetic operator
                                            (list (first args) (second args))
                                            nil)
                       (cddr args))
                nil))
              ((= l 2)
               (or whole (list* operator args)))
              ((= l 1)
               (if (or (eq operator '*) (eq operator '+))
                   (first args)
                   (or whole (list* operator args))))
              ((eq operator '*)
               1)
              ((eq operator '+)
               0)
              (t
               (error 'simple-program-error
                      :format-error "Wrong number of arguments for operator ~a in ~a"
                      :format-arguments (list operators (or whole
                                                            (list* operator args)))))))))
43
44
45
46
47
48
49
50
51
52
53
54
55

(define-compiler-macro * (&whole all &rest args)
  (simplify-arithmetic '* args all))

(define-compiler-macro + (&whole all &rest args)
  (simplify-arithmetic '+ args all))

(define-compiler-macro / (&whole all &rest args)
  (simplify-arithmetic '/ args all))

(define-compiler-macro - (&whole all &rest args)
  (simplify-arithmetic '- args all))

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
;;;
;;; The following are type propagators for arithmetic operations. Note
;;; that some of they have become binary operators.
;;;

(defun maximum-number-type (t1 t2)
  (let ((t1-eq nil)
        (t2-eq nil)
        (output nil))
    (dolist (i '(FIXNUM INTEGER RATIONAL
                 #+short-float SHORT-FLOAT SINGLE-FLOAT
                 DOUBLE-FLOAT #+long-float LONG-FLOAT FLOAT REAL
                 COMPLEX NUMBER)
             (values (if (and t1-eq t2-eq output)
                         output
                         t)
                     t1 t2))
      (when (and (null t1-eq) (type>= i t1))
        (if (equalp t1 t2)
            (setf t2-eq i))
76
        (setf t1-eq i output i))
77
      (when (and (null t2-eq) (type>= i t2))
78
        (setf t2-eq i output i)))))
79

80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
(defun arithmetic-propagator (op1 others integer-result)
  (loop with op1-type = (c1form-primary-type op1)
     with result-type = (maximum-number-type op1-type op1-type)
     with arg-types = (list (setf op1-type result-type))
     for op2 in others
     for op2-type = (c1form-primary-type op2)
     do (progn
          (multiple-value-setq (result-type op1-type op2-type)
            (maximum-number-type op1-type op2-type))
          (when (and (or (eq op1-type 'FIXNUM) (eq op1-type 'INTEGER))
                     (or (eq op2-type 'FIXNUM) (eq op2-type 'INTEGER)))
            (setf result-type integer-result))
          (setf arg-types (cons op2-type arg-types)
                op1-type result-type))
     finally (return (values (nreverse arg-types) result-type))))
95

96
97
(def-type-propagator * (fname op1 &rest others)
  (arithmetic-propagator op1 others 'integer))
98

99
100
(def-type-propagator + (fname op1 &rest others)
  (arithmetic-propagator op1 others 'integer))
101

102
103
(def-type-propagator - (fname op1 &rest others)
  (arithmetic-propagator op1 others 'integer))
104

105
106
(def-type-propagator / (fname op1 &rest others)
  (arithmetic-propagator op1 others 'rational))