src/inmis.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 (macsyma-module inmis)
  13
  14 (declare-top (special listofvars))
  15
  16 (defmvar $listdummyvars t)
  17
  18 (defmfun $unknown (f) (catch 'unknown (unknown (specrepcheck f))))
  19
  20 (defun unknown (f)
  21   (and (not (mapatom f))
  22        (cond ((and (eq (caar f) 'mqapply)
  23                    (not (zl-get (caaadr f) 'specsimp)))
  24               (throw 'unknown t))
  25              ((not (zl-get (caar f) 'operators)) (throw 'unknown t))
  26              (t (mapc #'unknown (cdr f)) nil))))
  27
  28 (defmfun $listofvars (e)
  29   (let ((listofvars (ncons '(mlist))))
  30     (when ($ratp e)
  31       (and (member 'trunc (cddar e) :test #'eq) (setq e ($taytorat e)))
  32       (setq e (cons '(mlist)
  33                     (sublis (mapcar #'cons
  34                                     (car (cdddar e))
  35                                     ;; GENSYMLIST
  36                                     (caddar e))
  37                             ;; VARLIST
  38                             (union* (listovars (cadr e))
  39                                     (listovars (cddr e)))))))
  40     (atomvars e)
  41     (if (not $listdummyvars)
  42         (dolist (u (cdr listofvars))
  43           (if (freeof u e)
  44               (setq listofvars (delete u listofvars :count 1 :test #'equal)))))
  45     listofvars))
  46
  47 (defun atomvars (e)
  48   (cond ((and (symbolp e)
  49               (or $listconstvars
  50                   ;; Do not add constants or boolean values to list of vars.
  51                   (and (not ($constantp e))
  52                        (not (member e '(t $true nil $false))))))
  53          (add2lnc e listofvars))
  54         ((atom e))
  55         ((specrepp e) (atomvars (specdisrep e)))
  56         ((member 'array (car e) :test #'eq) (myadd2lnc e listofvars))
  57         (t (mapc #'atomvars (margs e)))))
  58
  59 (defun myadd2lnc (item list)
  60   (and (not (memalike item list)) (nconc list (ncons item))))
  61
  62 ;; Bind variables declared with DEFMVAR to their initial values.
  63 ;; Some initial values are non-Maxima expressions, e.g., (2 3 5 7)
  64 ;; Attempt to handle those as well as Maxima expressions.
  65 ;; No attempt is made to handle variables declare with DEFVAR or by other means.
  66
  67 (defun maybe-reset (key val actually-reset reset-verbose)
  68   ; MAYBE DEFMVAR VALUES SHOULD ONLY BE MAXIMA EXPRESSIONS ??
  69   (let ((non-maxima (and (consp val) (not (consp (car val))))))
  70     (when
  71       ; TEST (BOUNDP KEY), OTHERWISE ATTEMPT TO COMPARE VALUES FAILS ...
  72       (and (boundp key)
  73         (if non-maxima
  74           ; Apply EQUALP to non-Maxima expressions.
  75           (not (equalp (symbol-value key) val))
  76           ; Apply ALIKE1 to Maxima expressions.
  77           (not (alike1 (symbol-value key) val))))
  78
  79       (when reset-verbose
  80         ; ATTEMPT TO COPE WITH NON-MAXIMA EXPRESSIONS FOR BENEFIT OF DISPLA
  81         (let ((displa-val (if non-maxima `((mprogn) ,@val) val)))
  82           (displa `((mtext) "reset: bind " ,key " to " ,displa-val))))
  83       (nconc actually-reset (list key))
  84       (let ((munbindp t))
  85         (meval `((msetq) ,key ((mquote) ,val)))))))
  86
  87 (defmspec $reset_verbosely (L)
  88   (reset-do-the-work (cdr L) t))
  89
  90 (defmspec $reset (L)
  91   (reset-do-the-work (cdr L) nil))
  92
  93 (defun reset-do-the-work (args reset-verbose)
  94
  95   (let ((actually-reset (copy-tree '((mlist)))) ($lispdisp t))
  96     (if args
  97       (mapcar
  98         #'(lambda (key)
  99             (multiple-value-bind (val found-p) (gethash key *variable-initial-values*)
 100               (if found-p (maybe-reset key val actually-reset reset-verbose))))
 101         args)
 102
 103       (maphash
 104         #'(lambda (key val)
 105             (maybe-reset key val actually-reset reset-verbose))
 106         *variable-initial-values*))
 107
 108     actually-reset))