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