clean up loads, no substantial changes
[CommonLispStat.git] / lsmacros.lsp
blobafcec284ff62ff73a0585aaa2c30983458b536ad
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 ;;; Package Setup
20 (in-package :cl-user)
22 (defpackage :lisp-stat-macros
23 (:use :common-lisp
24 :lisp-stat-compound-data)
25 (:export make-rv-function make-rv-function-1))
27 (in-package :lisp-stat-macros)
29 ;;; Floating Point Macros
31 (defmacro declare-double (&rest vars) `(declare (long-float ,@vars)))
33 ;;; Macros for Defining Vectorized Funcitons
35 (defmacro make-vectorized-function (sym fcn)
36 `(defun ,sym (&rest args)
37 (apply #'map-elements #',fcn args)))
39 (defmacro fixup-vectorized-doc-list (sym)
40 `(let ((doc (documentation ',sym 'function)))
41 (if doc (list (format nil "~s~%Vectorized." ,sym)))))
43 ;;; Exported
45 ;; recursively vectorizes (rv) functions in dists and lispstat-math.
46 (defmacro make-rv-function (sym fcn &rest args)
47 (cond
48 ((and args (= (length args) 1))
49 `(defun ,sym (,@args)
50 ,@(fixup-vectorized-doc-list fcn)
51 (declare (inline compound-data-p ,fcn ,sym recursive-map-elements list))
52 (if (compound-data-p ,@args)
53 (recursive-map-elements #',fcn #',sym ,@args)
54 (,fcn ,@args))))
55 (args
56 `(defun ,sym (,@args)
57 ,@(fixup-vectorized-doc-list fcn)
58 (declare (inline compound-data-p ,fcn ,sym recursive-map-elements list))
59 (if ,(cons 'or (mapcar #'(lambda (x) (list 'compound-data-p x)) args))
60 (recursive-map-elements #',fcn #',sym ,@args)
61 (,fcn ,@args))))
63 `(defun ,sym (&optional (x nil has-x) (y nil has-y) &rest args)
64 ,@(fixup-vectorized-doc-list fcn)
65 (declare (inline compound-data-p ,fcn ,sym recursive-map-elements list))
66 (if has-x
67 (if has-y
68 (if (or args (compound-data-p x) (compound-data-p y))
69 (apply #'recursive-map-elements #',fcn #',sym x y args)
70 (,fcn x y))
71 (if (compound-data-p x)
72 (recursive-map-elements #',fcn #',sym x)
73 (,fcn x)))
74 (,fcn))))))
76 (defmacro make-rv-function-1 (sym fcn &rest args)
77 (cond
78 ((and args (= (length args) 1))
79 `(defun ,sym (,@args)
80 ,@(fixup-vectorized-doc-list fcn)
81 (declare (inline compound-data-p ,fcn ,sym recursive-map-elements list))
82 (if (compound-data-p ,@args)
83 (recursive-map-elements #',fcn #',sym ,@args)
84 (,fcn ,@args))))
85 (args
86 `(defun ,sym (,@args)
87 ,@(fixup-vectorized-doc-list fcn)
88 (declare (inline compound-data-p ,fcn ,sym recursive-map-elements list))
89 (if ,(cons 'or (mapcar #'(lambda (x) (list 'compound-data-p x)) args))
90 (recursive-map-elements #',fcn #',sym ,@args)
91 (,fcn ,@args))))
93 `(defun ,sym (x &optional (y nil has-y) &rest args)
94 ,@(fixup-vectorized-doc-list fcn)
95 (declare (inline compound-data-p ,fcn ,sym recursive-map-elements list))
96 (if has-y
97 (if (or args (compound-data-p x) (compound-data-p y))
98 (apply #'recursive-map-elements #',fcn #',sym x y args)
99 (,fcn x y))
100 (if (compound-data-p x)
101 (recursive-map-elements #',fcn #',sym x)
102 (,fcn x)))))))