(in-package 'si) ;; by William F. Schelter ;; Conveniently and economically make operators which declare the type ;; and result of numerical operations. For example (def-op f+ fixnum +) ;; defines a macro f+ which will give optimal code for calling + on ;; several fixnum args expecting a fixnum result. ;; Details: ;; Note these will be macros and cannot be `funcalled'. If you add the ;; feature :debug, then code to check the types of the arguments and ;; result will be inserted, and generic operations will be used. This is ;; useful for checking that you did not insert the wrong type ;; declarations. The code will continue running if *dbreak* is nil, ;; returning the correct result but printing out the type mismatch, as ;; well as the actual args given so that you may more easily locate the ;; bad call in the editor. ;; It is economical, beause all the macros defined are just variations ;; of one closure, and so code is not duplicated. ;; Sample usage (with :debug in *features*): ;; The call will generate warning messages if the args or result are bad. ;; (defun foo (x a) (f+ (* 2 x) a)) ;; SYSTEM>(foo 7.0 9) ;; Bad call (F+ (* 2 X) A) types:(LONG-FLOAT FIXNUM) ;; 23.0 ;; Without debug (f+ a b c) becomes ;; (the fixnum (+ (the fixnum a) (the fixnum ;; (+ (the fixnum b) (the fixnum c))))) ;; which is painful to write by hand, but which will give the best code. (defmacro def-op (name type op &optional return-type) `(setf (macro-function ',name) (make-operation ',type ',op ',return-type))) (defun make-operation (.type .op .return) (or .return (setf .return .type)) #'(lambda (bod env) env (sloop for v in (cdr bod) when (eq t .type) collect v into body else collect `(the , .type ,v) into body finally (setq body `(, .op ,@ body)) (return (if (eq t .return) body `(the , .return ,body)))))) #+debug (progn ;; Enable this to insert type error checking code. (defvar *dbreak* t) (defun callchk-type (lis old na typ sho return-type &aux result) (setq result (apply old lis)) (or (and (sloop for v in lis always (typep v typ)) (or (null return-type) (typep result return-type))) (format t "~%Bad call ~a types:~a" (cons na sho) (sloop:sloop for v in lis collect (type-of v))) (and *dbreak* (break "hi"))) result) ;; debug version: (defmacro def-op (name type old &optional return-type) `(defmacro ,name (&rest l) `(callchk-type (list ,@ l) ',',old ',',name ',',type ',l ',',return-type ))) ) (def-op f+ fixnum +) (def-op f* fixnum *) (def-op f- fixnum -) (def-op +$ double-float +) (def-op *$ double-float *) (def-op -$ double-float -) (def-op 1-$ double-float 1-) (def-op 1+$ double-float 1+) (def-op f1- fixnum 1-) (def-op f1+ fixnum 1+) (def-op //$ double-float quot) (def-op ^ fixnum expt) (def-op ^$ double-float expt) (def-op f> fixnum > t) (def-op f< fixnum < t) (def-op f= fixnum = t) (def-op lsh fixnum ash) (def-op fixnum-remainder fixnum rem)