src/dskfn.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
   9 (in-package :maxima)
  10
  11 ;;      ** (c) Copyright 1982 Massachusetts Institute of Technology **
  12
  13 (macsyma-module dskfn)
  14
  15 (declare-top (special opers $packagefile
  16                       aaaaa errset lessorder greatorder indlist
  17                       $labels $aliases varlist *mopl* $props
  18                       $infolists $features featurel savefile $gradefs
  19                       $values $functions $arrays
  20                       $contexts context $activecontexts))
  21
  22 (defmvar $packagefile nil)
  23 (defvar indlist '(evfun evflag bindtest nonarray sp2 sp2subs opers
  24                   special autoload assign mode))
  25
  26 (defun infolstchk (x)
  27   (let ((iteml (cond ((not (and x (or (member (car x) '($all $contexts) :test #'eq)
  28                                       (member (car x) (cdr $infolists) :test #'eq))))
  29                       t)
  30                      ((eq (car x) '$all)
  31                       (infolstchk (append (cdr $infolists)
  32                                           '($linenum $ratvars *ratweights
  33                                             tellratlist *alphabet* $dontfactor $features $contexts))))
  34                      ((eq (car x) '$labels) (reverse (cdr $labels)))
  35                      ((member (car x) '($functions $macros $gradefs $dependencies $structures) :test #'eq)
  36                       (mapcar #'caar (cdr (symbol-value (car x)))))
  37                      ((eq (car x) '$contexts) (delete '$global (reverse (cdr $contexts)) :count 1 :test #'eq))
  38                      (t (cdr (symbol-value (car x)))))))
  39     (if (eq iteml t)
  40         x
  41         (append (or iteml '(nil)) (cdr x)))))
  42
  43 (defmacro with-maxima-io-syntax (&rest forms)
  44   `(let ((*readtable* (copy-readtable nil)) (*print-readably* t) *print-gensym*
  45         (*print-circle* nil) (*print-level* nil) (*print-length* nil) (*print-base* 10.) (*print-radix* t)
  46         #-gcl (*print-pprint-dispatch* (copy-pprint-dispatch)))
  47     #-gcl
  48     (progn
  49       #-(or scl allegro)
  50       (setf (readtable-case *readtable*) :invert)
  51       #+(or scl allegro)
  52       (unless #+scl (eq ext:*case-mode* :lower)
  53               #+allegro (eq excl:*current-case-mode* :case-sensitive-lower)
  54         (setf (readtable-case *readtable*) :invert))
  55       (set-pprint-dispatch '(cons (member maxima::defmtrfun))
  56                            #'pprint-defmtrfun))
  57     ,@forms))
  58
  59 (defmspec $save (form)
  60   (with-maxima-io-syntax ; $save stores Lisp expressions.
  61     (dsksetup (cdr form) nil '$save)))
  62
  63 (defvar *dsksetup-errset-value* t)
  64
  65 (defun dsksetup (x storefl fn)
  66   (let (file (fname (meval (car x))) list maxima-error (errset *dsksetup-errset-value*))
  67     (unless (stringp fname)
  68       (merror (intl:gettext "~a: first argument must be a string; found: ~M") fn fname))
  69     (setq savefile
  70           (if (or (eq $file_output_append '$true) (eq $file_output_append t))
  71               (open fname :direction :output :if-exists :append :if-does-not-exist :create)
  72               (open fname :direction :output :if-exists :supersede :if-does-not-exist :create)))
  73     (setq file (list (car x)))
  74     (princ ";;; -*- Mode: LISP; package:maxima; syntax:common-lisp; -*- " savefile)
  75     (terpri savefile)
  76     (princ "(in-package :maxima)" savefile)
  77     ;; Check arguments. First argument was checked above.
  78     ;; May want to relax requirement that all atoms be symbols.
  79     (dolist (u (cdr x))
  80       (cond ((atom u) (if (not (symbolp u)) (improper-arg-err u fn)))
  81             ((listargp u))
  82             ((or (not (eq (caar u) 'mequal)) (not (symbolp (cadr u))))
  83              (improper-arg-err u fn))))
  84     (setq list (ncons (car x))
  85           x (cdr x))
  86     (if (null (errset (dskstore x storefl file list)))
  87         (setq maxima-error t))
  88     (close savefile)
  89     (namestring (truename savefile))))
  90
  91 (defun dskstore (x storefl file list)
  92   (do ((x x (cdr x))
  93        (val)
  94        (rename)
  95        (item)
  96        (alrdystrd)
  97        (stfl storefl storefl)
  98        (nitemfl nil nil))
  99       ((null x))
 100     (cond ((setq val (listargp (car x)))
 101            (setq x (nconc (getlabels (car val) (cdr val) nil) (cdr x))))
 102           ((setq val (assoc (car x) '(($inlabels . $inchar) ($outlabels . $outchar)
 103                                      ($linelabels . $linechar)) :test #'eq))
 104            (setq x (nconc (getlabels* (eval (cdr val)) nil) (cdr x)))))
 105     (if (not (atom (car x)))
 106         (setq rename (cadar x) item (getopr (caddar x)))
 107         (setq x (infolstchk x) item (setq rename (and x (getopr (car x))))))
 108     (cond ((not (symbolp item))
 109            (setq nitemfl item)
 110            (setq item (let ((nitem (gensym))) (setf (symbol-value nitem) (meval item)) nitem)))
 111           ((eq item '$ratweights) (setq item '*ratweights))
 112           ((eq item '$tellrats) (setq item 'tellratlist))
 113       ((eq item '$alphabet) (setq item '*alphabet*)))
 114     (cond
 115       ((null x) (return nil))
 116       ((null (car x)))
 117       ((and (setq val (assoc item alrdystrd :test #'eq)) (eq rename (cdr val))))
 118       ((null (setq alrdystrd (cons (cons item rename) alrdystrd))))
 119       ((and (or (not (boundp item))
 120                 (and (eq item '$ratvars) (null varlist))
 121                 (prog2 (setq val (symbol-value item))
 122                     (or (and (eq item '$dontfactor)
 123                              (null (cdr val)))
 124                         (and (member item '(tellratlist *alphabet* *ratweights) :test #'eq) (null val))
 125                         (and (eq item '$features) (alike (cdr val) featurel))
 126                         (and (eq item '$default_let_rule_package)
 127                              (eq item val)))))
 128             (or ;; This clause has been reformulated to cut out a test with
 129                 ;; dsksavep and unstorep, but to respect the side effects.
 130                 (null (setq val (safe-get item 'mprops)))
 131                 (equal val '(nil))
 132                 nil)
 133             (not (getl item '(operators reversealias grad noun verb expr op data)))
 134             (not (member item (cdr $props) :test #'eq))
 135             (or (not (member item (cdr $contexts) :test #'eq))
 136                 (not (eq item '$initial))
 137                 (let ((context '$initial)) (null (cdr ($facts '$initial)))))))
 138       (t (when (boundp item)
 139            (setq val (symbol-value item))
 140            (if (eq item '$context) (setq x (list* nil val (cdr x))))
 141            (dskatom item rename val)
 142            (if (not (optionp rename)) (infostore item file 'value stfl rename)))
 143          (when (setq val (and (member item (cdr $aliases) :test #'eq) (get item 'reversealias)))
 144            (dskdefprop rename val 'reversealias)
 145            (pradd2lnc rename '$aliases)
 146            (dskdefprop val rename 'alias)
 147            (and greatorder (not (assoc 'greatorder alrdystrd :test #'eq))
 148                 (setq x (list* nil 'greatorder (cdr x))))
 149            (and lessorder (not (assoc 'lessorder alrdystrd :test #'eq))
 150                 (setq x (list* nil 'lessorder (cdr x))))
 151            (setq x (list* nil val (cdr x))))
 152          (cond ((setq val (get item 'noun))
 153                 (setq x (list* nil val (cdr x)))
 154                 (dskdefprop rename val 'noun))
 155                ((setq val (get item 'verb))
 156                 (setq x (list* nil val (cdr x)))
 157                 (dskdefprop rename val 'verb)))
 158          (when (mget item '$rule)
 159            (if (setq val (ruleof item))
 160                (setq x (list* nil val (cdr x))))
 161            (pradd2lnc (getop rename) '$rules))
 162          (when (and (setq val (cadr (getl-lm-fcn-prop item '(expr))))
 163                     (or (mget item '$rule) (get item 'translated)))
 164            (if (mget item 'trace)
 165                (let (val1)
 166                  (remprop item 'expr)
 167                  (if (setq val1 (get item 'expr))
 168                      (dskdefprop rename val1 'expr))
 169                  (setf (symbol-plist item) (list* 'expr val (symbol-plist item))))
 170                (dskdefprop rename val 'expr))
 171            (propschk item rename 'translated))
 172          (when (setq val (get item 'operators))
 173            (dskdefprop rename val 'operators)
 174            (when (setq val (get item 'rules))
 175              (dskdefprop rename val 'rules)
 176              (setq x (cons nil (append val (cdr x)))))
 177            (if (member item (cdr $props) :test #'eq) (pradd2lnc rename '$props))
 178            (setq val (mget item 'oldrules))
 179            (and val (setq x (cons nil (nconc (cdr (reverse val)) (cdr x))))))
 180          (if (member item (cdr $features) :test #'eq) (pradd2lnc rename '$features))
 181          (when (member (getop item) (cdr $props) :test #'eq)
 182            (dolist (ind indlist) (propschk item rename ind))
 183            (dolist (oper opers) (propschk item rename oper)))
 184          (when (and (setq val (get item 'op)) (member val (cdr $props) :test #'eq))
 185            (dskdefprop item val 'op)
 186            (dskdefprop val item 'opr)
 187            (pradd2lnc val '$props)
 188            (if (setq val (extopchk item val))
 189                (setq x (list* nil val (cdr x)))))
 190          (when (and (setq val (get item 'grad)) (assoc (ncons item) $gradefs :test #'equal))
 191            (dskdefprop rename val 'grad)
 192            (pradd2lnc (cons (ncons rename) (car val)) '$gradefs))
 193          (when (and (get item 'data)
 194                     (not (member item (cdr $contexts) :test #'eq))
 195                     (setq val (cdr ($facts item))))
 196            (fasprin `(restore-facts (quote ,val)))
 197            (if (member item (cdr $props) :test #'eq) (pradd2lnc item '$props)))
 198          (when (and (member item (cdr $contexts) :test #'eq)
 199                     (let ((context item)) (setq val (cdr ($facts item)))))
 200            (fasprint t `(dsksetq $context (quote ,item)))
 201            (if (member item (cdr $activecontexts) :test #'eq)
 202                (fasprint t `($activate (quote ,item))))
 203            (fasprint t `(restore-facts (quote ,val))))
 204          (mpropschk item rename file stfl)
 205          (if (not (get item 'verb))
 206              (nconc list (ncons (or nitemfl (getop item)))))))))
 207
 208 (defun dskatom (item rename val)
 209   (cond ((eq item '$ratvars)
 210          (fasprint t `(setq varlist (append varlist (quote ,varlist))))
 211          (fasprint t '(setq $ratvars (cons '(mlist simp) varlist)))
 212          (pradd2lnc '$ratvars '$myoptions))
 213         ((eq item '$dontfactor)
 214          (fasprin `(setq ,item (nconc (quote ,val) (cdr ,item))))
 215          (pradd2lnc item '$myoptions))
 216         ((eq item 'tellratlist)
 217          (fasprin `(setq tellratlist (nconc (quote ,val) tellratlist)))
 218          (pradd2lnc 'tellratlist '$myoptions))
 219     ((eq item '*alphabet*)
 220      (fasprin `(setq *alphabet* (nconc (quote ,val) *alphabet*))))
 221         ((eq item '*ratweights)
 222          (fasprin `(apply (function $ratweight) (quote ,(dot2l val)))))
 223         ((eq item '$features)
 224          (dolist (var (cdr $features))
 225            (if (not (member var featurel :test #'eq)) (pradd2lnc var '$features))))
 226         ((and (eq item '$linenum) (eq item rename))
 227          (fasprint t `(setq $linenum ,val)))
 228         (($ratp val) (fasprint t `(dsksetq ,rename (dskrat (quote ,val)))))
 229         (t
 230       (cond
 231         ;; Hash tables ("fast arrays") aren't printable in all Lisp implementations.
 232         ((hash-table-p val)
 233          (fasprint t `(dsksetq ,rename (fill-hash (make-hash-table :test 'equal) ',(list-hash-pairs val)))))
 234         ;; If there are other unprintable values, this is a place to handle them.
 235         (t
 236           (fasprint t (list 'dsksetq rename (list 'quote val))))))))
 237
 238 (defun fill-hash (h kv-list)
 239   (dolist (kv kv-list)
 240     (setf (gethash (first kv) h) (second kv)))
 241   h)
 242
 243 (defun list-hash-pairs (h)
 244   (loop for value being the hash-values of h using (hash-key key)
 245         collect (list key value)))
 246
 247 (defun mpropschk (item rename file stfl)
 248   (do ((props (cdr (or (get item 'mprops) '(nil))) (cddr props)) (val))
 249       ((null props))
 250     (cond ((or (member (car props) '(trace trace-type trace-level trace-oldfun) :test #'eq)
 251                ;; This clause has been reformulated to cut out a mfile-test,
 252                ;; but to respect the side effect of assigning a value to val.
 253                (and (setq val (cadr props)) nil)
 254                (and (eq (car props) 't-mfexpr)
 255                     (not (get item 'translated)))))
 256           ((not (member (car props) '(hashar array) :test #'eq))
 257            (fasprin (list 'mdefprop rename val (car props)))
 258            (if (not (member (car props) '(mlexprp mfexprp t-mfexpr) :test #'eq))
 259                (infostore item file (car props) stfl
 260                           (cond ((member (car props) '(mexpr mmacro) :test #'eq)
 261                                  (let ((val1 (get item 'function-mode)))
 262                                    (if val1 (dskdefprop rename
 263                                                         val1
 264                                                         'function-mode)))
 265                                  (cons (ncons rename) (cdadr val)))
 266                                 ((eq (car props) 'depends)
 267                                  (cons (ncons rename) val))
 268                                 (t rename)))))
 269           (t (dskary item (list 'quote rename) val (car props))
 270              (infostore item file (car props) stfl rename)))))
 271
 272 (defun dskary (item rename val ind)
 273   ;; Some small forms ordinarily non-EQ for fasdump must be output
 274   ;; in proper sequence with the big mungeables.
 275   ;; For this reason only they are output as EQ-forms.
 276   (let ((ary (cond ((and (eq ind 'array) (get item 'array)) rename)
 277                    ;; This code handles "complete" arrays.
 278                    (t (fasprint t '(defparameter aaaaa (gensym))) 'aaaaa)))
 279         (dims (arraydims val))
 280         val1)
 281     (if (eq ind 'hashar) (fasprint t `(remcompary ,rename)))
 282     (fasprint t `(mremprop ,rename (quote ,(if (eq ind 'array) 'hashar 'array))))
 283     (fasprint t `(mputprop ,rename ,ary (quote ,ind)))
 284     (fasprint t `(*array ,ary (quote ,(car dims)) ,.(cdr dims)))
 285     (fasprint t `(fillarray ,ary (quote ,(listarray val))))
 286     (if (setq val1 (get item 'array-mode))
 287         (fasprint t `(defprop ,(cadr rename) ,val1 array-mode)))))
 288
 289 (defun extopchk (item val)
 290     (when (or (get item 'nud) (get item 'led) (get item 'lbp))
 291       (fasprin `(define-symbol (quote ,val)))
 292       (if (member val *mopl* :test #'eq)
 293           (fasprin `(setq *mopl* (cons (quote ,val) *mopl*))))
 294       (when (setq val (get item 'dimension))
 295         (dskdefprop item val 'dimension)
 296         (dskdefprop item (get item 'dissym) 'dissym)
 297         (dskdefprop item (get item 'grind) 'grind))
 298       (if (setq val (get item 'lbp)) (dskdefprop item val 'lbp))
 299       (if (setq val (get item 'rbp)) (dskdefprop item val 'rbp))
 300       (if (setq val (get item 'nud)) (dskdefprop item val 'nud))
 301       (if (setq val (get item 'led)) (dskdefprop item val 'led))
 302       (when (setq val (get item 'verb))
 303         (dskdefprop val (get val 'dimension) 'dimension)
 304         (dskdefprop val (get val 'dissym) 'dissym))
 305       (when (setq val (get item 'match))
 306         (dskdefprop item val 'match) val)))
 307
 308 (defun propschk (item rename ind)
 309   (let ((val (get item ind)))
 310     (when val (dskdefprop rename val ind)
 311           (pradd2lnc (getop rename) '$props))))
 312
 313 (defun fasprin (form)
 314   (fasprint nil form))
 315
 316 (defun fasprint (eqfl form)
 317   (declare (ignore eqfl))
 318   (print form savefile))
 319
 320 (defun infostore (item file flag storefl rename)
 321   (let ((prop (cond ((eq flag 'value)
 322                      (if (member rename (cdr $labels) :test #'eq) '$labels '$values))
 323                     ((eq flag 'mexpr) '$functions)
 324                     ((eq flag 'mmacro) '$macros)
 325                     ((member flag '(array hashar) :test #'eq) '$arrays)
 326                     ((eq flag 'depends) (setq storefl nil) '$dependencies)
 327                     (t (setq storefl nil) '$props))))
 328     (cond ((eq prop '$labels)
 329            (fasprin `(addlabel (quote ,rename)))
 330            (if (get item 'nodisp) (dskdefprop rename t 'nodisp)))
 331           (t (pradd2lnc rename prop)))
 332     (cond (storefl
 333            (cond ((member flag '(mexpr mmacro) :test #'eq) (setq rename (caar rename)))
 334                  ((eq flag 'array) (remcompary item)))
 335            (setq prop (list '(mfile) file rename))
 336            (cond ((eq flag 'value) (setf (symbol-value item) prop))
 337                  ((member flag '(mexpr mmacro aexpr array hashar) :test #'eq)
 338                   (mputprop item prop flag)))))))
 339
 340 (defun pradd2lnc (item prop)
 341   (if (or (null $packagefile) (not (member prop (cdr $infolists) :test #'eq))
 342           (and (eq prop '$props) (getopr0 item)))
 343       (fasprin `(add2lnc (quote ,item) ,prop))))
 344
 345 (defun dskdefprop (name val ind)
 346   (declare (special *opr-table*))
 347   (fasprin
 348     (cond
 349       ((and (member ind '(expr fexpr macro) :test #'eq) (eq (car val) 'lambda))
 350        (list* 'defun name (if (eq ind 'expr) (cdr val) (cons ind (cdr val)))))
 351       ((eq ind 'opr)
 352        (if (symbolp name)
 353          (list 'defprop name val ind)
 354          `(setf (gethash ,name *opr-table*) ',val)))
 355       (t
 356         (list 'defprop name val ind)))))
 357