On Fri, 19 Mar 2004, David Hanley wrote:
> You can make your own primitives fairly easily.
>
> (defmacro f+(n1 n2)`(the fixnum (+ (the fixnum ,n1)
> (the fixnum ,n2))))
>
> Now you can use (f+ 1 2)
Better idea:
#|
tf's private spellbook of useful LISP functions and macros.
Inspired by many sources, in part by perl.
(C) 2001,2002 Thomas Fischbacher
|#
(in-package :tf-spellbook)
;;; === fast-compilation macros ===
;;; machine-integer arith
(defmacro i+ (&rest args)
`(the fixnum (+ ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args))))
(defmacro i* (&rest args)
`(the fixnum (* ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args))))
#|
One problem is that i* permanently generates notes like:
(* (THE FIXNUM J) (THE FIXNUM Z))
Note: Unable to recode as shift and add due to type uncertainty:
The second argument is a (INTEGER -9 19), not a (UNSIGNED-BYTE 32).
The result is a (INTEGER -8999991 18999981), not a (UNSIGNED-BYTE 32).
This can be avoided using explicit (unsigned-byte 32)
multiplication. The speed gain is a meager rough 6%.
|#
(defmacro u* (&rest args)
`(the (unsigned-byte 32) (* ,@(mapcar #'(lambda (x) `(the (unsigned-byte 32) ,x))
args))))
(defmacro i- (&rest args)
`(the fixnum (- ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args))))
;; XXX NOTE: does this round as usual for negative numbers?
(defmacro i/ (&rest args)
`(the fixnum (floor ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args))))
(defmacro i= (&rest args)
`(= ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args)))
(defmacro i< (&rest args)
`(< ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args)))
(defmacro i<= (&rest args)
`(<= ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args)))
(defmacro i> (&rest args)
`(> ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args)))
(defmacro i>= (&rest args)
`(>= ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args)))
(defmacro i/= (&rest args)
`(/= ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args)))
(defmacro i1+ (x) `(the fixnum (1+ (the fixnum ,x))))
(defmacro i1- (x) `(the fixnum (1- (the fixnum ,x))))
(defmacro i-incf (x) `(setf ,x (i1+ ,x)))
(defmacro i-decf (x) `(setf ,x (i1- ,x)))
(defmacro i-mod (&rest args)
`(the fixnum (mod ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args))))
(defmacro i-dotimes (rangespec &rest body)
(let ((var (car rangespec)))
`(dotimes ,rangespec
(declare (fixnum ,var))
,@body)))
;; machine-float arith
(defmacro f+ (&rest args)
`(the double-float (+ ,@(mapcar #'(lambda (x) `(the double-float ,x)) args))))
(defmacro f* (&rest args)
`(the double-float (* ,@(mapcar #'(lambda (x) `(the double-float ,x)) args))))
(defmacro f- (&rest args)
`(the double-float (- ,@(mapcar #'(lambda (x) `(the double-float ,x)) args))))
(defmacro f/ (&rest args)
`(the double-float (/ ,@(mapcar #'(lambda (x) `(the double-float ,x)) args))))
(defmacro f= (&rest args)
`(= ,@(mapcar #'(lambda (x) `(the double-float ,x)) args)))
(defmacro f< (&rest args)
`(< ,@(mapcar #'(lambda (x) `(the double-float ,x)) args)))
(defmacro f<= (&rest args)
`(<= ,@(mapcar #'(lambda (x) `(the double-float ,x)) args)))
(defmacro f> (&rest args)
`(> ,@(mapcar #'(lambda (x) `(the double-float ,x)) args)))
(defmacro f>= (&rest args)
`(>= ,@(mapcar #'(lambda (x) `(the double-float ,x)) args)))
(defmacro f/= (&rest args)
`(/= ,@(mapcar #'(lambda (x) `(the double-float ,x)) args)))
(defmacro with-arith-defs ((prefix-symbol type) &rest body)
(let* ((prefix (string-upcase (symbol-name prefix-symbol)))
(sym+ (intern (format nil "~A+" prefix)))
(sym* (intern (format nil "~A*" prefix)))
(sym- (intern (format nil "~A-" prefix)))
(sym/ (intern (format nil "~A/" prefix)))
(sym= (intern (format nil "~A=" prefix)))
(sym< (intern (format nil "~A<" prefix)))
(sym> (intern (format nil "~A>" prefix)))
(sym<= (intern (format nil "~A<=" prefix)))
(sym>= (intern (format nil "~A>=" prefix)))
(sym/= (intern (format nil "~A/=" prefix)))
(sym1+ (intern (format nil "~A1+" prefix)))
(sym1- (intern (format nil "~A1-" prefix)))
;; Strictly speaking, these two are not neccessary, since everything is under
control.
(sym-args (gensym "args-"))
(sym-x (gensym "x-")))
`(macrolet
((,sym+ (&rest ,sym-args) `(the ,',type (+ ,@(mapcar #'(lambda (,sym-x) `(the
,',type ,,sym-x)) ,sym-args))))
(,sym- (&rest ,sym-args) `(the ,',type (- ,@(mapcar #'(lambda (,sym-x) `(the
,',type ,,sym-x)) ,sym-args))))
(,sym* (&rest ,sym-args) `(the ,',type (* ,@(mapcar #'(lambda (,sym-x) `(the
,',type ,,sym-x)) ,sym-args))))
(,sym/ (&rest ,sym-args) `(the ,',type (/ ,@(mapcar #'(lambda (,sym-x) `(the
,',type ,,sym-x)) ,sym-args))))
(,sym= (&rest ,sym-args) `(= ,@(mapcar #'(lambda (,sym-x) `(the ,',type
,,sym-x)) ,sym-args)))
(,sym< (&rest ,sym-args) `(< ,@(mapcar #'(lambda (,sym-x) `(the ,',type
,,sym-x)) ,sym-args)))
(,sym> (&rest ,sym-args) `(> ,@(mapcar #'(lambda (,sym-x) `(the ,',type
,,sym-x)) ,sym-args)))
(,sym<= (&rest ,sym-args) `(<= ,@(mapcar #'(lambda (,sym-x) `(the ,',type
,,sym-x)) ,sym-args)))
(,sym>= (&rest ,sym-args) `(>= ,@(mapcar #'(lambda (,sym-x) `(the ,',type
,,sym-x)) ,sym-args)))
(,sym/= (&rest ,sym-args) `(/= ,@(mapcar #'(lambda (,sym-x) `(the ,',type
,,sym-x)) ,sym-args)))
(,sym1+ (&rest ,sym-args) `(the ,',type (1+ ,@(mapcar #'(lambda (,sym-x)
`(the ,',type ,,sym-x)) ,sym-args))))
(,sym1- (&rest ,sym-args) `(the ,',type (1- ,@(mapcar #'(lambda (,sym-x)
`(the ,',type ,,sym-x)) ,sym-args)))))
,@body)))
;; Note: compiler puts in extra checks for sines/cosines of arbitrary
;; double-float numbers. However, if you take a sin of >~1e9, then
;; rounding fuzz will certainly kill you anyway, hence it's reasonable
;; to just put in some assumptions.
(defmacro f-sin (x)
`(the (double-float -5d+18 5d+18) (sin (the (double-float -5d+18 5d+18) ,x))))
(defmacro f-cos (x)
`(the (double-float -5d+18 5d+18) (cos (the (double-float -5d+18 5d+18) ,x))))
(defmacro f-sqrt (x)
`(the (double-float 0.0d0 *) (sqrt (the (double-float 0.0d0) ,x))))
(defmacro f-exp (x)
`(the double-float (exp (the double-float ,x))))
(defmacro f-log (x)
`(the double-float (log (the (double-float 0.0d0) ,x))))
(defmacro cf+ (&rest args)
`(the (complex double-float) (+ ,@(mapcar #'(lambda (x) `(the (complex double-float)
,x)) args))))
(defmacro cf* (&rest args)
`(the (complex double-float) (* ,@(mapcar #'(lambda (x) `(the (complex double-float)
,x)) args))))
(defmacro cf- (&rest args)
`(the (complex double-float) (- ,@(mapcar #'(lambda (x) `(the (complex double-float)
,x)) args))))
(defmacro cf/ (&rest args)
`(the (complex double-float) (/ ,@(mapcar #'(lambda (x) `(the (complex double-float)
,x)) args))))
(defmacro cf= (&rest args)
`(= ,@(mapcar #'(lambda (x) `(the (complex double-float) ,x)) args)))
(defmacro cf/= (&rest args)
`(/= ,@(mapcar #'(lambda (x) `(the (complex double-float) ,x)) args)))
(...)
