src/maxmac.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   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 (function . rest)
 115   `(progn
 116      (defun-prop (,function mfexpr*) ,@rest)))
 117
 118 ;; Setf hacking.
 119
 120 (defun mget (atom ind)
 121   (let ((props (and (symbolp atom) (get atom 'mprops))))
 122     (and props (getf (cdr props) ind))))
 123
 124 (defsetf mget (sym tag) (value)
 125   `(mputprop ,sym ,value ,tag))
 126
 127 (defmacro old-get (plist tag)
 128   `(getf (cdr ,plist) ,tag))
 129
 130 (defmfun $get (atom ind)
 131   (prop1 '$get atom nil ind))
 132
 133 (defsetf $get (sym tag) (value)
 134   `($put ,sym ,value ,tag))
 135
 136 (defmacro  mdefprop (sym val indicator)
 137   `(mputprop ',sym ',val ',indicator))
 138
 139 (defun mputprop (atom val ind)
 140   (let ((props (get atom 'mprops)))
 141     (if (null props) (putprop atom (setq props (ncons nil)) 'mprops))
 142     (putprop props val ind)))