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;; 'ttyoff' is a system independent way of expressing the Maclisp ^W. 21 22(defvar ttyoff '^w) 23 24;; Like PUSH, but works at the other end. 25 26(defmacro tuchus (list object) 27 `(setf ,list (nconc ,list (ncons ,object)))) 28 29;; The following macros pertain only to Macsyma. 30 31;; Except on the Lisp Machine, load the specified macro files. 32;; On the Lisp Machine, the DEFSYSTEM facility is used for loading 33;; macro files, so just check that the file is loaded. This is 34;; a useful error check that has saved a lot of time since Defsystem 35;; is far from fool-proof. 36 37(defun load-macsyma-macros-at-runtime (&rest l) 38 (mapcar #'(lambda (x) (unless (get x 'macsyma-module) 39 (error "Missing Maxima macro file -- ~A" x))) 40 l)) 41 42(defmacro load-macsyma-macros (&rest macro-files) 43 (apply #'load-macsyma-macros-at-runtime macro-files) 44 (values)) 45 46(defmacro with-new-context (sub-context &rest forms) 47 `(let ((my-context (gensym "$CTXT"))) 48 (mfuncall '$supcontext my-context ,@sub-context) 49 (unwind-protect 50 (prog1 ,@forms) 51 ($killcontext my-context)))) 52 53;; For creating a macsyma evaluator variable binding context. 54;; (MBINDING (VARIABLES &OPTIONAL VALUES FUNCTION-NAME) 55;; ... BODY ...) 56 57(defmacro mbinding (variable-specification &rest body &aux (temp (gensym))) 58 `(let ((,temp ,(car variable-specification))) 59 ;; Don't optimize out this temporary, even if (CAR VARIABLE-SPECICIATION) 60 ;; is an ATOM. We don't want to risk side-effects. 61 ,(case (length variable-specification) 62 ((1) 63 `(mbinding-sub ,temp ,temp nil ,@body)) 64 ((2) 65 `(mbinding-sub ,temp ,(cadr variable-specification) nil ,@body)) 66 ((3) 67 `(mbinding-sub ,temp ,(cadr variable-specification) 68 ,(caddr variable-specification) 69 ,@body)) 70 (t 71 (maxima-error "Bad variable specification: ~a" variable-specification))))) 72 73(defmacro mbinding-sub (variables values function-name &rest body &aux (win (gensym))) 74 `(let ((,win nil)) 75 (unwind-protect 76 (progn 77 (mbind ,variables ,values ,function-name) 78 (setq ,win t) 79 ,@body) 80 (if ,win (munbind ,variables))))) 81 82;; How About MTYPEP like (MTYPEP EXP 'ATAN) or (MTYPEP EXP '*) - Jim. 83;; Better, (EQ (MTYPEP EXP) 'ATAN). 84 85(defmacro matanp (x) 86 `(let ((thing ,x)) 87 (and (not (atom thing)) (eq (caar thing) '%atan)))) 88 89;; Macros used in LIMIT, DEFINT, RESIDU. 90;; If we get a lot of these, they can be split off into a separate macro 91;; package. 92 93(defmacro real-infinityp (x) 94 `(member ,x real-infinities :test #'eq)) 95 96(defun infinityp (x) 97 (member x infinities :test #'eq)) 98 99(defmacro real-epsilonp (x) 100 `(member ,x infinitesimals :test #'eq)) 101 102(defmacro free-epsilonp (x) 103 `(not (amongl infinitesimals ,x))) 104 105(defmacro free-infp (x) 106 `(not (amongl infinities ,x))) 107 108(defmacro inf-typep (x) 109 `(car (amongl infinities ,x))) 110 111(defmacro epsilon-typep (x) 112 `(car (amongl infinitesimals ,x))) 113 114(defmacro hot-coef (p) 115 `(pdis (caddr (cadr (rat-no-ratfac ,p))))) 116 117(defmacro defmspec (function . rest) 118 `(progn 119 (defun-prop (,function mfexpr*) ,@rest))) 120 121;; Setf hacking. 122 123(defun mget (atom ind) 124 (let ((props (and (symbolp atom) (get atom 'mprops)))) 125 (and props (getf (cdr props) ind)))) 126 127(defsetf mget (sym tag) (value) 128 `(mputprop ,sym ,value ,tag)) 129 130(defmacro old-get (plist tag) 131 `(getf (cdr ,plist) ,tag)) 132 133(defmfun $get (atom ind) 134 (prop1 '$get atom nil ind)) 135 136(defsetf $get (sym tag) (value) 137 `($put ,sym ,value ,tag)) 138 139(defmacro mdefprop (sym val indicator) 140 `(mputprop ',sym ',val ',indicator)) 141 142(defun mputprop (atom val ind) 143 (let ((props (get atom 'mprops))) 144 (if (null props) (putprop atom (setq props (ncons nil)) 'mprops)) 145 (putprop props val ind))) 146