/[gcl]/gcl/lsp/gcl_fdecl.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_fdecl.lsp

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

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:05 2003 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

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