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 ;;; Package Setup
  19
  20 (in-package :cl-user)
  21
  22 (defpackage :lisp-stat-macros
  23   (:use :common-lisp
  24         :lisp-stat-compound-data)
  25   (:export make-rv-function make-rv-function-1))
  26
  27 (in-package :lisp-stat-macros)
  28
  29 ;;; Floating Point Macros
  30
  31 (defmacro declare-double (&rest vars) `(declare (long-float ,@vars)))
  32
  33 ;;; Macros for Defining Vectorized Funcitons
  34
  35 (defmacro make-vectorized-function (sym fcn)
  36   `(defun ,sym (&rest args)
  37      (apply #'map-elements #',fcn args)))
  38
  39 (defmacro fixup-vectorized-doc-list (sym)
  40   `(let ((doc (documentation ',sym 'function)))
  41     (if doc (list (format nil "~s~%Vectorized." ,sym)))))
  42
  43 ;;; Exported
  44
  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))))
  62    (t
  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))))))
  75
  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))))
  92    (t
  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)))))))