src/macdes.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 (defvar $manual_demo "manual.demo")
  12
  13 (defmspec $example (l)
  14   (declare (special *need-prompt*))
  15   (let ((example (second l)))
  16     (when (symbolp example)
  17       ;; Coerce a symbol to be a string.
  18       ;; Remove the first character if it is a dollar sign.
  19       (setq example (coerce (exploden (stripdollar example)) 'string)))
  20     (unless (stringp example)
  21       (merror
  22         (intl:gettext "example: argument must be a symbol or a string; found: ~M") example))
  23     ;; Downcase the string. $example is not case sensitive.
  24     (setq example (string-downcase example))
  25     (with-open-file (st ($file_search1 $manual_demo '((mlist) $file_search_demo)))
  26       (prog (tem all c-tag d-tag)
  27        again
  28        (setq tem (read-char st nil))
  29        (unless tem (go notfound))
  30        (unless (eql tem #\&) (go again))
  31        (setq tem (read-char st nil))
  32        (unless (eql tem #\&) (go again))
  33        ;; so we are just after having read &&
  34
  35        (setq tem (read st nil nil))
  36        (unless tem (go notfound))
  37        ;; Coerce the topic in tem to be a string.
  38        (setq tem (coerce (exploden tem) 'string))
  39        (cond ((string= tem example)
  40               (go doit))
  41              (t (push tem all)
  42                 (go again)))
  43        ;; at this stage we read maxima forms and print and eval
  44        ;; until a peek sees '&' as the first character of next expression,
  45        ;; but at first skip over whitespaces.
  46        doit
  47        (when (member (setq tem (peek-char nil st nil))
  48                      '(#\tab #\space #\newline #\linefeed #\return #\page))
  49          ;; Found whitespace. Read char and look for next char.
  50          ;; The && label can be positioned anywhere before the next topic.
  51          (setq tem (read-char st nil))
  52          (go doit))
  53        (cond ((or (null tem) (eql tem #\&))
  54               (setf *need-prompt* t)
  55               (return '$done)))
  56        (setq tem (dbm-read st nil nil))
  57        (incf $linenum)
  58        (setq c-tag (makelabel $inchar))
  59        (unless $nolabels (setf (symbol-value c-tag) (nth 2 tem)))
  60        (let ($display2d)
  61          (displa `((mlabel) ,c-tag ,(nth 2 tem))))
  62        (setq $% (meval* (nth 2 tem)))
  63        (setq d-tag (makelabel $outchar))
  64        (unless $nolabels (setf (symbol-value d-tag) $%))
  65        (when (eq (caar tem) 'displayinput)
  66          (displa `((mlabel) ,d-tag ,$%)))
  67        (go doit)
  68
  69        notfound
  70        (setf *need-prompt* t)
  71        (if (= (length l) 1)
  72          (return `((mlist) ,@(nreverse all)))
  73          (progn
  74            (mtell (intl:gettext "example: ~M not found. 'example();' returns the list of known examples.~%") example)
  75            (return '$done)))))))
  76
  77 (defun mread-noprompt (&rest read-args)
  78   (let ((*mread-prompt* "") (*prompt-on-read-hang*))
  79     (declare (special *mread-prompt* *prompt-on-read-hang*))
  80     (unless read-args (setq read-args (list #+(or sbcl cmu) *standard-input*
  81                                             #-(or sbcl cmu) *query-io*)))
  82     (caddr (apply #'mread read-args))))
  83
  84 ;; Some list creation utilities.
  85
  86 (defmspec $create_list (l)
  87   (cons '(mlist) (apply #'create-list1 (cadr l) (cddr l))))
  88
  89 (defun create-list1 (form &rest l &aux lis var1 top)
  90   (cond ((null l) (list (meval* form)))
  91         (t
  92          (setq var1 (first l)
  93                lis (second l)
  94                l (cddr l))
  95          (unless (symbolp var1) (merror (intl:gettext "create_list: expected a symbol; found: ~A") var1))
  96          (setq lis (meval* lis))
  97          (mbinding ((list var1))
  98            (cond ((and (numberp lis)
  99                        (progn
 100                          (setq top (car l) l (cdr l))
 101                          (setq top (meval* top))
 102                          (numberp top)))
 103                   (loop for i from lis to top
 104                      do (mset var1 i)
 105                      append
 106                      (apply #'create-list1 form l)))
 107                  (($listp lis)
 108                   (loop for v in (cdr lis)
 109                      do (mset var1 v)
 110                      append
 111                      (apply #'create-list1 form l)))
 112                  (t (merror (intl:gettext "create_list: unexpected arguments."))))))))
 113
 114 ;; The documentation is now in INFO format and can be printed using
 115 ;; tex, or viewed using info or gnu emacs or using a web browser.  All
 116 ;; versions of maxima have a builtin info retrieval mechanism.
 117
 118 (defmspec $describe (x)
 119   (let ((topic ($sconcat (cadr x)))
 120         (exact-p (or (null (caddr x)) (eq (caddr x) '$exact))))
 121     (if exact-p
 122         (cl-info::info-exact topic)
 123         (cl-info::info-inexact topic))))
 124
 125 (defmspec $apropos (s)
 126   (setq s (car (margs s)))
 127   (cond ((or (stringp s)
 128              (and (symbolp s) (setq s (string (stripdollar s)))))
 129          ;; A list of all Maxima names which contain the string S.
 130          (let ((acc (apropos-list s :maxima)))
 131            ;; Filter the names which are Maxima User symbols starting
 132            ;; with % or $ and remove duplicates.
 133            (remove-duplicates
 134             (cons '(mlist)
 135                    (delete-if-not
 136                     #'(lambda (x)
 137                         (cond ((eq x '||) nil)
 138                               ((char= (get-first-char x) #\$) x)
 139                               ;; Change to a verb, when present.
 140                               ((char= (get-first-char x) #\%) (or (get x 'noun) x))
 141                               (t nil)))
 142                     acc)) :test #'eq)))
 143         (t
 144          (merror
 145           (intl:gettext "apropos: argument must be a string or symbol; found: ~M") s))))