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 (defpackage :lisp-stat-macros
  23   (:use :common-lisp)
  24   (:export make-rv-function make-rv-function-1))
  25
  26 (in-package :lisp-stat-macros)
  27
  28 ;;;;
  29 ;;;; Floating Point Macros
  30 ;;;;
  31
  32 (defmacro declare-double (&rest vars) `(declare (long-float ,@vars)))
  33
  34 ;;;;
  35 ;;;; Macros for Defining Vectorized Funcitons
  36 ;;;;
  37
  38 (defmacro make-vectorized-function (sym fcn)
  39   `(defun ,sym (&rest args)
  40      (apply #'map-elements #',fcn args)))
  41
  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.")))))
  46
  47
  48 ;;; Exported
  49
  50 ;;; recursively vectorizes (rv) functions in dists and lispstat-math.
  51
  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))))
  68    (t
  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))))))
  81
  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))))
  98    (t
  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)))))))