src/maxmac.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancements.                   ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;  (c) Copyright 1976, 1983 Massachusetts Institute of Technology      ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module maxmac macro)
  14
  15 ;; This file contains miscellaneous macros used in Macsyma source files.
  16
  17 ;; General purpose macros which are used in Lisp code, but not widely enough
  18 ;; accepted to be a part of Lisp systems.
  19
  20 ;; Like PUSH, but works at the other end.
  21
  22 (defmacro tuchus (list object)
  23   `(setf ,list (nconc ,list (ncons ,object))))
  24
  25 ;; The following macros pertain only to Macsyma.
  26
  27 ;; Except on the Lisp Machine, load the specified macro files.
  28 ;; On the Lisp Machine, the DEFSYSTEM facility is used for loading
  29 ;; macro files, so just check that the file is loaded. This is
  30 ;; a useful error check that has saved a lot of time since Defsystem
  31 ;; is far from fool-proof.
  32
  33 (defun load-macsyma-macros-at-runtime (&rest l)
  34   (mapcar #'(lambda (x) (unless (get x 'macsyma-module)
  35                           (error  "Missing Maxima macro file -- ~A" x)))
  36           l))
  37
  38 (defmacro load-macsyma-macros (&rest macro-files)
  39   (apply #'load-macsyma-macros-at-runtime macro-files)
  40   (values))
  41
  42 (defmacro with-new-context (sub-context &rest forms)
  43   (let ((my-context (gensym)))
  44     `(let ((,my-context (gensym "$CTXT")))
  45        (mfuncall '$supcontext ,my-context ,@sub-context)
  46        (unwind-protect
  47          (progn ,@forms)
  48          ($killcontext ,my-context)))))
  49
  50 ;; For creating a macsyma evaluator variable binding context.
  51 ;; (MBINDING (VARIABLES &OPTIONAL VALUES FUNCTION-NAME)
  52 ;;    ... BODY ...)
  53
  54 (defmacro mbinding (variable-specification &rest body &aux (temp (gensym)))
  55   `(let ((,temp ,(car variable-specification)))
  56      ;; Don't optimize out this temporary, even if (CAR VARIABLE-SPECICIATION)
  57      ;; is an ATOM. We don't want to risk side-effects.
  58      ,(case (length variable-specification)
  59             ((1)
  60              `(mbinding-sub ,temp ,temp nil ,@body))
  61             ((2)
  62              `(mbinding-sub ,temp ,(cadr variable-specification) nil ,@body))
  63             ((3)
  64              `(mbinding-sub ,temp ,(cadr variable-specification)
  65                             ,(caddr variable-specification)
  66                             ,@body))
  67             (t
  68              (maxima-error "Bad variable specification: ~a" variable-specification)))))
  69
  70 (defmacro mbinding-sub (variables values function-name &rest body &aux (win (gensym)))
  71   `(let ((,win nil))
  72      (unwind-protect
  73           (progn
  74             (mbind ,variables ,values ,function-name)
  75             (setq ,win t)
  76             ,@body)
  77        (if ,win (munbind ,variables)))))
  78
  79 ;; How About MTYPEP like (MTYPEP EXP 'ATAN) or (MTYPEP EXP '*) - Jim.
  80 ;; Better, (EQ (MTYPEP EXP) 'ATAN).
  81
  82 (defmacro matanp (x)
  83   `(let ((thing ,x))
  84      (and (not (atom thing)) (eq (caar thing) '%atan))))
  85
  86 ;; Macros used in LIMIT, DEFINT, RESIDU.
  87 ;; If we get a lot of these, they can be split off into a separate macro
  88 ;; package.
  89
  90 (defmacro real-infinityp (x)
  91   `(member ,x *real-infinities* :test #'eq))
  92
  93 (defun infinityp (x)
  94   (member x *infinities* :test #'eq))
  95
  96 (defmacro real-epsilonp (x)
  97   `(member ,x *infinitesimals* :test #'eq))
  98
  99 (defmacro free-epsilonp (x)
 100   `(not (amongl *infinitesimals* ,x)))
 101
 102 (defmacro free-infp (x)
 103   `(not (amongl *infinities* ,x)))
 104
 105 (defmacro inf-typep (x)
 106   `(car (amongl *infinities* ,x)))
 107
 108 (defmacro epsilon-typep (x)
 109   `(car (amongl *infinitesimals* ,x)))
 110
 111 (defmacro hot-coef (p)
 112   `(pdis (caddr (cadr (rat-no-ratfac ,p)))))
 113
 114 (defmacro defmspec (name-or-list &rest rest)
 115   ;; NAME-OR-LIST is either a symbol or a list.  If a symbol, then
 116   ;; it's the name of the function.  If a list it must be of the form
 117   ;; (function :properties plist) where plist is a list of properties
 118   ;; that should be set for this function.  The format of plist is the
 119   ;; same as for defmvar :properties.
 120   (destructuring-bind (function &key properties)
 121       (if (symbolp name-or-list)
 122           (list name-or-list)
 123           name-or-list)
 124     `(progn
 125        (defun-prop (,function mfexpr*) ,@rest)
 126        ,@(mapcar #'(lambda (p)
 127                      (destructuring-bind (ind val)
 128                          p
 129                        `(putprop ',function ',val ',ind)))
 130                  properties))))
 131
 132 ;; Setf hacking.
 133
 134 (defun mget (atom ind)
 135   (let ((props (and (symbolp atom) (get atom 'mprops))))
 136     (and props (getf (cdr props) ind))))
 137
 138 (defsetf mget (sym tag) (value)
 139   `(mputprop ,sym ,value ,tag))
 140
 141 (defmacro old-get (plist tag)
 142   `(getf (cdr ,plist) ,tag))
 143
 144 (defmfun $get (atom ind)
 145   (prop1 '$get atom nil ind))
 146
 147 (defsetf $get (sym tag) (value)
 148   `($put ,sym ,value ,tag))
 149
 150 (defmacro  mdefprop (sym val indicator)
 151   `(mputprop ',sym ',val ',indicator))
 152
 153 (defun mputprop (atom val ind)
 154   (let ((props (get atom 'mprops)))
 155     (if (null props) (putprop atom (setq props (ncons nil)) 'mprops))
 156     (putprop props val ind)))