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