src/basics/lsmacros.lsp

   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.
   5
   6 ;;;; lsmacros -- Various macros
   7 ;;;;
   8 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
   9 ;;;; unrestricted use.
  10 ;;;;
  11
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13 ;;;
  14 ;;;              Macros for LISP-STAT-BASICS Package
  15 ;;;
  16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17
  18 (in-package :lisp-stat-macros)
  19
  20 ;;; Floating Point Macros
  21
  22 (defmacro declare-double (&rest vars) `(declare (long-float ,@vars)))
  23
  24 ;;; Macros for Defining Vectorized Funcitons
  25
  26 (defmacro make-vectorized-function (sym fcn)
  27   `(defun ,sym (&rest args)
  28      (apply #'map-elements #',fcn args)))
  29
  30 (defmacro fixup-vectorized-doc-list (sym)
  31   `(let ((doc (documentation ',sym 'function)))
  32     (if doc (list (format nil "~s~%Vectorized." ,sym)))))
  33
  34 ;;; Exported
  35
  36 ;; recursively vectorizes (rv) functions in dists and lispstat-math.
  37 (defmacro make-rv-function (sym fcn &rest args)
  38   (cond
  39    ((and args (= (length args) 1))
  40     `(defun ,sym (,@args)
  41        ,@(fixup-vectorized-doc-list fcn)
  42        (declare (inline compound-data-p ,fcn ,sym recursive-map-elements list))
  43        (if (compound-data-p ,@args)
  44            (recursive-map-elements #',fcn #',sym ,@args)
  45            (,fcn ,@args))))
  46    (args
  47     `(defun ,sym (,@args)
  48        ,@(fixup-vectorized-doc-list fcn)
  49        (declare (inline compound-data-p ,fcn ,sym recursive-map-elements list))
  50        (if ,(cons 'or (mapcar #'(lambda (x) (list 'compound-data-p x)) args))
  51            (recursive-map-elements #',fcn #',sym ,@args)
  52            (,fcn ,@args))))
  53    (t
  54     `(defun ,sym (&optional (x nil has-x) (y nil has-y) &rest args)
  55        ,@(fixup-vectorized-doc-list fcn)
  56        (declare (inline compound-data-p ,fcn ,sym recursive-map-elements list))
  57        (if has-x
  58            (if has-y
  59                (if (or args (compound-data-p x) (compound-data-p y))
  60                    (apply #'recursive-map-elements #',fcn #',sym x y args)
  61                    (,fcn x y))
  62                (if (compound-data-p x)
  63                    (recursive-map-elements #',fcn #',sym x)
  64                    (,fcn x)))
  65            (,fcn))))))
  66
  67 (defmacro make-rv-function-1 (sym fcn &rest args)
  68   (cond
  69    ((and args (= (length args) 1))
  70     `(defun ,sym (,@args)
  71        ,@(fixup-vectorized-doc-list fcn)
  72        (declare (inline compound-data-p ,fcn ,sym recursive-map-elements list))
  73        (if (compound-data-p ,@args)
  74            (recursive-map-elements #',fcn #',sym ,@args)
  75            (,fcn ,@args))))
  76    (args
  77     `(defun ,sym (,@args)
  78        ,@(fixup-vectorized-doc-list fcn)
  79        (declare (inline compound-data-p ,fcn ,sym recursive-map-elements list))
  80        (if ,(cons 'or (mapcar #'(lambda (x) (list 'compound-data-p x)) args))
  81            (recursive-map-elements #',fcn #',sym ,@args)
  82            (,fcn ,@args))))
  83    (t
  84     `(defun ,sym (x &optional (y nil has-y) &rest args)
  85        ,@(fixup-vectorized-doc-list fcn)
  86        (declare (inline compound-data-p ,fcn ,sym recursive-map-elements list))
  87        (if has-y
  88          (if (or args (compound-data-p x) (compound-data-p y))
  89            (apply #'recursive-map-elements #',fcn #',sym x y args)
  90            (,fcn x y))
  91          (if (compound-data-p x)
  92            (recursive-map-elements #',fcn #',sym x)
  93            (,fcn x)))))))