merged from ansiClib
[CommonLispStat.git] / lsmacros.lsp
blob05f6450dc93d93742fdaee93b5aafe95dbef6ff3
1 ;;; -*- mode: lisp -*-
2 ;;; Copyright (c) 2005--2007, by A.J. Rossini <blindglobe@gmail.com>
3 ;;; See COPYRIGHT file for any additional restrictions (BSD license).
4 ;;; Since 1991, ANSI was finally finished. Edited for ANSI Common Lisp.
6 ;;;; lsmacros -- Various macros
7 ;;;;
8 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
9 ;;;; unrestricted use.
10 ;;;;
12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13 ;;;
14 ;;; Macros for LISP-STAT-BASICS Package
15 ;;;
16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18 ;;;;
19 ;;;; Package Setup
20 ;;;;
22 (defpackage :lisp-stat-macros
23 (:use :common-lisp)
24 (:export make-rv-function make-rv-function-1))
26 (in-package :lisp-stat-macros)
28 ;;;;
29 ;;;; Floating Point Macros
30 ;;;;
32 (defmacro declare-double (&rest vars) `(declare (long-float ,@vars)))
34 ;;;;
35 ;;;; Macros for Defining Vectorized Funcitons
36 ;;;;
38 (defmacro make-vectorized-function (sym fcn)
39 `(defun ,sym (&rest args)
40 (apply #'map-elements #',fcn args)))
42 (defmacro fixup-vectorized-doc-list (sym)
43 `(let ((doc (documentation ',sym 'function)))
44 (if doc (list (format nil "~s~%Vectorized." ,sym))))) ;; AJR: new version
45 ;; (if doc (list (format nil "~s~%Vectorized.")))))
48 ;;; Exported
50 ;;; recursively vectorizes (rv) functions in dists and lispstat-math.
52 (defmacro make-rv-function (sym fcn &rest args)
53 (cond
54 ((and args (= (length args) 1))
55 `(defun ,sym (,@args)
56 ,@(fixup-vectorized-doc-list fcn)
57 (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
58 (if (cmpndp ,@args)
59 (recursive-map-elements #',fcn #',sym ,@args)
60 (,fcn ,@args))))
61 (args
62 `(defun ,sym (,@args)
63 ,@(fixup-vectorized-doc-list fcn)
64 (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
65 (if ,(cons 'or (mapcar #'(lambda (x) (list 'cmpndp x)) args))
66 (recursive-map-elements #',fcn #',sym ,@args)
67 (,fcn ,@args))))
69 `(defun ,sym (&optional (x nil has-x) (y nil has-y) &rest args)
70 ,@(fixup-vectorized-doc-list fcn)
71 (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
72 (if has-x
73 (if has-y
74 (if (or args (cmpndp x) (cmpndp y))
75 (apply #'recursive-map-elements #',fcn #',sym x y args)
76 (,fcn x y))
77 (if (cmpndp x)
78 (recursive-map-elements #',fcn #',sym x)
79 (,fcn x)))
80 (,fcn))))))
82 (defmacro make-rv-function-1 (sym fcn &rest args)
83 (cond
84 ((and args (= (length args) 1))
85 `(defun ,sym (,@args)
86 ,@(fixup-vectorized-doc-list fcn)
87 (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
88 (if (cmpndp ,@args)
89 (recursive-map-elements #',fcn #',sym ,@args)
90 (,fcn ,@args))))
91 (args
92 `(defun ,sym (,@args)
93 ,@(fixup-vectorized-doc-list fcn)
94 (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
95 (if ,(cons 'or (mapcar #'(lambda (x) (list 'cmpndp x)) args))
96 (recursive-map-elements #',fcn #',sym ,@args)
97 (,fcn ,@args))))
99 `(defun ,sym (x &optional (y nil has-y) &rest args)
100 ,@(fixup-vectorized-doc-list fcn)
101 (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
102 (if has-y
103 (if (or args (cmpndp x) (cmpndp y))
104 (apply #'recursive-map-elements #',fcn #',sym x y args)
105 (,fcn x y))
106 (if (cmpndp x)
107 (recursive-map-elements #',fcn #',sym x)
108 (,fcn x)))))))