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 ;;;;
  19 ;;;; Package Setup
  20 ;;;;
  21
  22 (in-package :lisp-stat-basics)
  23
  24 ;;;;
  25 ;;;; Floating Point Macros
  26 ;;;;
  27
  28 (defmacro declare-double (&rest vars) `(declare (long-float ,@vars)))
  29
  30 ;;;;
  31 ;;;; Macros for Defining Vectorized Funcitons
  32 ;;;;
  33
  34 (defmacro make-vectorized-function (sym fcn)
  35   `(defun ,sym (&rest args)
  36      (apply #'map-elements #',fcn args)))
  37
  38 (defmacro fixup-vectorized-doc-list (sym)
  39   `(let ((doc (documentation ',sym 'function)))
  40     (if doc (list (format nil "~s~%Vectorized." ,sym))))) ;; AJR: newvers
  41 ;;    (if doc (list (format nil "~s~%Vectorized.")))))  ;;
  42
  43
  44 ;;; Exported
  45 ;;; recursively vectorizes (rv) functions in dists and lispstat-math.
  46
  47 (defmacro make-rv-function (sym fcn &rest args)
  48   (cond
  49    ((and args (= (length args) 1))
  50     `(defun ,sym (,@args)
  51        ,@(fixup-vectorized-doc-list fcn)
  52        (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
  53        (if (cmpndp ,@args)
  54            (recursive-map-elements #',fcn #',sym ,@args)
  55            (,fcn ,@args))))
  56    (args
  57     `(defun ,sym (,@args)
  58        ,@(fixup-vectorized-doc-list fcn)
  59        (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
  60        (if ,(cons 'or (mapcar #'(lambda (x) (list 'cmpndp x)) args))
  61            (recursive-map-elements #',fcn #',sym ,@args)
  62            (,fcn ,@args))))
  63    (t
  64     `(defun ,sym (&optional (x nil has-x) (y nil has-y) &rest args)
  65        ,@(fixup-vectorized-doc-list fcn)
  66        (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
  67        (if has-x
  68            (if has-y
  69                (if (or args (cmpndp x) (cmpndp y))
  70                    (apply #'recursive-map-elements #',fcn #',sym x y args)
  71                    (,fcn x y))
  72                (if (cmpndp x)
  73                    (recursive-map-elements #',fcn #',sym x)
  74                    (,fcn x)))
  75            (,fcn))))))
  76
  77 (defmacro make-rv-function-1 (sym fcn &rest args)
  78   (cond
  79    ((and args (= (length args) 1))
  80     `(defun ,sym (,@args)
  81        ,@(fixup-vectorized-doc-list fcn)
  82        (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
  83        (if (cmpndp ,@args)
  84            (recursive-map-elements #',fcn #',sym ,@args)
  85            (,fcn ,@args))))
  86    (args
  87     `(defun ,sym (,@args)
  88        ,@(fixup-vectorized-doc-list fcn)
  89        (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
  90        (if ,(cons 'or (mapcar #'(lambda (x) (list 'cmpndp x)) args))
  91            (recursive-map-elements #',fcn #',sym ,@args)
  92            (,fcn ,@args))))
  93    (t
  94     `(defun ,sym (x &optional (y nil has-y) &rest args)
  95        ,@(fixup-vectorized-doc-list fcn)
  96        (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
  97        (if has-y
  98          (if (or args (cmpndp x) (cmpndp y))
  99            (apply #'recursive-map-elements #',fcn #',sym x y args)
 100            (,fcn x y))
 101          (if (cmpndp x)
 102            (recursive-map-elements #',fcn #',sym x)
 103            (,fcn x)))))))