lsmacros.lsp

   1 ;;;; lsmacros -- Various macros
   2 ;;;;
   3 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
   4 ;;;; unrestricted use.
   5 ;;;;
   6
   7 (provide "lsmacros")
   8
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10 ;;;
  11 ;;;              Macros for LISP-STAT-BASICS Package
  12 ;;;
  13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14
  15 ;;;;
  16 ;;;; Package Setup
  17 ;;;;
  18
  19 #+:CLtL2
  20 (progn
  21   (defpackage "LISP-STAT-BASICS"
  22     (:nicknames "LS-BASICS")
  23     (:use "COMMON-LISP" "LISP-STAT-OBJECT-SYSTEM"))
  24
  25   (in-package lisp-stat-basics))
  26 #-:CLtL2
  27 (in-package 'lisp-stat-basics
  28             :nicknames '(ls-basics)
  29             :use '(lisp lsos))
  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.")))))
  48
  49 (defmacro make-rv-function (sym fcn &rest args)
  50   (cond
  51    ((and args (= (length args) 1))
  52     `(defun ,sym (,@args)
  53        ,@(fixup-vectorized-doc-list fcn)
  54        (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
  55        (if (cmpndp ,@args)
  56            (recursive-map-elements #',fcn #',sym ,@args)
  57            (,fcn ,@args))))
  58    (args
  59     `(defun ,sym (,@args)
  60        ,@(fixup-vectorized-doc-list fcn)
  61        (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
  62        (if ,(cons 'or (mapcar #'(lambda (x) (list 'cmpndp x)) args))
  63            (recursive-map-elements #',fcn #',sym ,@args)
  64            (,fcn ,@args))))
  65    (t
  66     `(defun ,sym (&optional (x nil has-x) (y nil has-y) &rest args)
  67        ,@(fixup-vectorized-doc-list fcn)
  68        (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
  69        (if has-x
  70            (if has-y
  71                (if (or args (cmpndp x) (cmpndp y))
  72                    (apply #'recursive-map-elements #',fcn #',sym x y args)
  73                    (,fcn x y))
  74                (if (cmpndp x)
  75                    (recursive-map-elements #',fcn #',sym x)
  76                    (,fcn x)))
  77            (,fcn))))))
  78
  79 (defmacro make-rv-function-1 (sym fcn &rest args)
  80   (cond
  81    ((and args (= (length args) 1))
  82     `(defun ,sym (,@args)
  83        ,@(fixup-vectorized-doc-list fcn)
  84        (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
  85        (if (cmpndp ,@args)
  86            (recursive-map-elements #',fcn #',sym ,@args)
  87            (,fcn ,@args))))
  88    (args
  89     `(defun ,sym (,@args)
  90        ,@(fixup-vectorized-doc-list fcn)
  91        (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
  92        (if ,(cons 'or (mapcar #'(lambda (x) (list 'cmpndp x)) args))
  93            (recursive-map-elements #',fcn #',sym ,@args)
  94            (,fcn ,@args))))
  95    (t
  96     `(defun ,sym (x &optional (y nil has-y) &rest args)
  97        ,@(fixup-vectorized-doc-list fcn)
  98        (declare (inline cmpndp ,fcn ,sym recursive-map-elements list))
  99        (if has-y
 100          (if (or args (cmpndp x) (cmpndp y))
 101            (apply #'recursive-map-elements #',fcn #',sym x y args)
 102            (,fcn x y))
 103          (if (cmpndp x)
 104            (recursive-map-elements #',fcn #',sym x)
 105            (,fcn x)))))))