1 |
|
(in-package 'si) |
2 |
|
|
3 |
|
;; by William F. Schelter |
4 |
|
|
5 |
|
;; Conveniently and economically make operators which declare the type |
6 |
|
;; and result of numerical operations. For example (def-op f+ fixnum +) |
7 |
|
;; defines a macro f+ which will give optimal code for calling + on |
8 |
|
;; several fixnum args expecting a fixnum result. |
9 |
|
|
10 |
|
;; Details: |
11 |
|
;; Note these will be macros and cannot be `funcalled'. If you add the |
12 |
|
;; feature :debug, then code to check the types of the arguments and |
13 |
|
;; result will be inserted, and generic operations will be used. This is |
14 |
|
;; useful for checking that you did not insert the wrong type |
15 |
|
;; declarations. The code will continue running if *dbreak* is nil, |
16 |
|
;; returning the correct result but printing out the type mismatch, as |
17 |
|
;; well as the actual args given so that you may more easily locate the |
18 |
|
;; bad call in the editor. |
19 |
|
|
20 |
|
;; It is economical, beause all the macros defined are just variations |
21 |
|
;; of one closure, and so code is not duplicated. |
22 |
|
|
23 |
|
;; Sample usage (with :debug in *features*): |
24 |
|
;; The call will generate warning messages if the args or result are bad. |
25 |
|
|
26 |
|
;; (defun foo (x a) (f+ (* 2 x) a)) |
27 |
|
;; SYSTEM>(foo 7.0 9) |
28 |
|
|
29 |
|
;; Bad call (F+ (* 2 X) A) types:(LONG-FLOAT FIXNUM) |
30 |
|
;; 23.0 |
31 |
|
|
32 |
|
;; Without debug (f+ a b c) becomes |
33 |
|
;; (the fixnum (+ (the fixnum a) (the fixnum |
34 |
|
;; (+ (the fixnum b) (the fixnum c))))) |
35 |
|
;; which is painful to write by hand, but which will give the best code. |
36 |
|
|
37 |
|
|
38 |
|
(defmacro def-op (name type op &optional return-type) |
39 |
|
`(setf (macro-function ',name) (make-operation ',type ',op |
40 |
|
',return-type))) |
41 |
|
|
42 |
|
(defun make-operation (.type .op .return) |
43 |
|
(or .return (setf .return .type)) |
44 |
|
#'(lambda (bod env) env |
45 |
|
(sloop for v in (cdr bod) |
46 |
|
when (eq t .type) collect v into body |
47 |
|
else |
48 |
|
collect `(the , .type ,v) into body |
49 |
|
finally (setq body `(, .op ,@ body)) |
50 |
|
(return |
51 |
|
(if (eq t .return) body |
52 |
|
`(the , .return ,body)))))) |
53 |
|
|
54 |
|
#+debug |
55 |
|
(progn |
56 |
|
;; Enable this to insert type error checking code. |
57 |
|
(defvar *dbreak* t) |
58 |
|
(defun callchk-type (lis old na typ sho return-type &aux result) |
59 |
|
(setq result (apply old lis)) |
60 |
|
(or (and (sloop for v in lis |
61 |
|
always (typep v typ)) |
62 |
|
(or (null return-type) (typep result return-type))) |
63 |
|
(format t "~%Bad call ~a types:~a" (cons na sho) |
64 |
|
(sloop:sloop for v in lis collect (type-of v))) |
65 |
|
(and *dbreak* (break "hi"))) |
66 |
|
result) |
67 |
|
|
68 |
|
;; debug version: |
69 |
|
(defmacro def-op (name type old &optional return-type) |
70 |
|
`(defmacro ,name (&rest l) |
71 |
|
`(callchk-type (list ,@ l) ',',old ',',name ',',type ',l ',',return-type |
72 |
|
))) |
73 |
|
) |
74 |
|
|
75 |
|
(def-op f+ fixnum +) |
76 |
|
(def-op f* fixnum *) |
77 |
|
(def-op f- fixnum -) |
78 |
|
(def-op +$ double-float +) |
79 |
|
(def-op *$ double-float *) |
80 |
|
(def-op -$ double-float -) |
81 |
|
(def-op 1-$ double-float 1-) |
82 |
|
(def-op 1+$ double-float 1+) |
83 |
|
(def-op f1- fixnum 1-) |
84 |
|
(def-op f1+ fixnum 1+) |
85 |
|
(def-op //$ double-float quot) |
86 |
|
(def-op ^ fixnum expt) |
87 |
|
(def-op ^$ double-float expt) |
88 |
|
(def-op f> fixnum > t) |
89 |
|
(def-op f< fixnum < t) |
90 |
|
(def-op f= fixnum = t) |
91 |
|
(def-op lsh fixnum ash) |
92 |
|
(def-op fixnum-remainder fixnum rem) |
93 |
|
|