src/macdes.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
   9 (in-package :maxima)
  10
  11 (defvar $manual_demo "manual.demo")
  12
  13 (defvar *debug-display-html-help* nil
  14   "Set to non-NIL to get some debugging messages from hdescribe.")
  15
  16 (defmspec $example (l)
  17   (declare (special *need-prompt*))
  18   (let ((example (second l)))
  19     (when (symbolp example)
  20       ;; Coerce a symbol to be a string.
  21       ;; Remove the first character if it is a dollar sign.
  22       (setq example (coerce (exploden (stripdollar example)) 'string)))
  23     (unless (stringp example)
  24       (merror
  25         (intl:gettext "example: argument must be a symbol or a string; found: ~M") example))
  26     ;; Downcase the string. $example is not case sensitive.
  27     (setq example (string-downcase example))
  28     (with-open-file (st ($file_search1 $manual_demo '((mlist) $file_search_demo)))
  29       (prog (tem all c-tag d-tag)
  30        again
  31        (setq tem (read-char st nil))
  32        (unless tem (go notfound))
  33        (unless (eql tem #\&) (go again))
  34        (setq tem (read-char st nil))
  35        (unless (eql tem #\&) (go again))
  36        ;; so we are just after having read &&
  37
  38        (setq tem (read st nil nil))
  39        (unless tem (go notfound))
  40        ;; Coerce the topic in tem to be a string.
  41        (setq tem (coerce (exploden tem) 'string))
  42        (cond ((string= tem example)
  43               (go doit))
  44              (t (push tem all)
  45                 (go again)))
  46        ;; at this stage we read maxima forms and print and eval
  47        ;; until a peek sees '&' as the first character of next expression,
  48        ;; but at first skip over whitespaces.
  49        doit
  50        (when (member (setq tem (peek-char nil st nil))
  51                      '(#\tab #\space #\newline #\linefeed #\return #\page))
  52          ;; Found whitespace. Read char and look for next char.
  53          ;; The && label can be positioned anywhere before the next topic.
  54          (setq tem (read-char st nil))
  55          (go doit))
  56        (cond ((or (null tem) (eql tem #\&))
  57               (setf *need-prompt* t)
  58               (return '$done)))
  59        (setq tem (dbm-read st nil nil))
  60        (incf $linenum)
  61        (setq c-tag (makelabel $inchar))
  62        (unless $nolabels (setf (symbol-value c-tag) (nth 2 tem)))
  63        (let ($display2d)
  64          (displa `((mlabel) ,c-tag ,(nth 2 tem))))
  65        (setq $% (meval* (nth 2 tem)))
  66        (setq d-tag (makelabel $outchar))
  67        (unless $nolabels (setf (symbol-value d-tag) $%))
  68        (when (eq (caar tem) 'displayinput)
  69          (displa `((mlabel) ,d-tag ,$%)))
  70        (go doit)
  71
  72        notfound
  73        (setf *need-prompt* t)
  74        (if (= (length l) 1)
  75          (return `((mlist) ,@(nreverse all)))
  76          (progn
  77            (mtell (intl:gettext "example: ~M not found. 'example();' returns the list of known examples.~%") example)
  78            (return '$done)))))))
  79
  80 (defun mread-noprompt (&rest read-args)
  81   (let ((*mread-prompt* "") (*prompt-on-read-hang*))
  82     (declare (special *mread-prompt* *prompt-on-read-hang*))
  83     (unless read-args (setq read-args (list #+(or sbcl cmu) *standard-input*
  84                                             #-(or sbcl cmu) *query-io*)))
  85     (caddr (apply #'mread read-args))))
  86
  87 ;; Some list creation utilities.
  88
  89 (defmspec $create_list (l)
  90   (cons '(mlist) (apply #'create-list1 (cadr l) (cddr l))))
  91
  92 (defun create-list1 (form &rest l &aux lis var1 top)
  93   (cond ((null l) (list (meval* form)))
  94         (t
  95          (setq var1 (first l)
  96                lis (second l)
  97                l (cddr l))
  98          (unless (symbolp var1) (merror (intl:gettext "create_list: expected a symbol; found: ~A") var1))
  99          (setq lis (meval* lis))
 100          (mbinding ((list var1))
 101            (cond ((and (numberp lis)
 102                        (progn
 103                          (setq top (car l) l (cdr l))
 104                          (setq top (meval* top))
 105                          (numberp top)))
 106                   (loop for i from lis to top
 107                      do (mset var1 i)
 108                      append
 109                      (apply #'create-list1 form l)))
 110                  (($listp lis)
 111                   (loop for v in (cdr lis)
 112                      do (mset var1 v)
 113                      append
 114                      (apply #'create-list1 form l)))
 115                  (t (merror (intl:gettext "create_list: unexpected arguments."))))))))
 116
 117 ;; The documentation is now in INFO format and can be printed using
 118 ;; tex, or viewed using info or gnu emacs or using a web browser.  All
 119 ;; versions of maxima have a builtin info retrieval mechanism.
 120
 121 (defmspec $describe (x)
 122   (let ((topic ($sconcat (cadr x)))
 123         (exact-p (or (null (caddr x)) (eq (caddr x) '$exact))))
 124     (if exact-p
 125         (cl-info::info-exact topic)
 126         (cl-info::info-inexact topic))))
 127
 128 (defmspec $apropos (s)
 129   (setq s (car (margs s)))
 130   (cond ((or (stringp s)
 131              (and (symbolp s) (setq s (string (stripdollar s)))))
 132          ;; A list of all Maxima names which contain the string S.
 133          (let ((acc (apropos-list s :maxima)))
 134            ;; Filter the names which are Maxima User symbols starting
 135            ;; with % or $ and remove duplicates.
 136            (remove-duplicates
 137             (cons '(mlist)
 138                    (delete-if-not
 139                     #'(lambda (x)
 140                         (cond ((eq x '||) nil)
 141                               ((char= (get-first-char x) #\$) x)
 142                               ;; Change to a verb, when present.
 143                               ((char= (get-first-char x) #\%) (or (get x 'noun) x))
 144                               (t nil)))
 145                     acc)) :test #'eq)))
 146         (t
 147          (merror
 148           (intl:gettext "apropos: argument must be a string or symbol; found: ~M") s))))
 149
 150 \f
 151 ;;; Display help in browser instead of the terminal
 152 (defun display-html-help (x)
 153   ;; The pattern is basically " <nnn>" where "nnn" is any number of
 154   ;; digits.
 155   (let* ((topic ($sconcat x))
 156          (found-it (gethash topic cl-info::*html-index*)))
 157     (when *debug-display-html-help*
 158       (format *debug-io* "topic = ~S~%" topic)
 159       (format *debug-io* "found-it = ~S~%" found-it))
 160     (when found-it
 161       (destructuring-bind (base-name . id)
 162           found-it
 163         (let ((url (concatenate 'string
 164                                 ;; If BASE-NAME is an absolute path,
 165                                 ;; use "FILE://" as the protocol.
 166                                 ;; Otherwise use $URL_BASE.
 167                                 (if (eq :absolute (car (pathname-directory base-name)))
 168                                     "file://"
 169                                     $url_base)
 170                                 "/"
 171                                 (namestring base-name)
 172                                 "#"
 173                                 id))
 174               command)
 175           (when *debug-display-html-help*
 176             (format *debug-io* "URL: ~S~%" url))
 177           (setf command (ignore-errors (format nil $browser url)))
 178           (cond (command
 179                  (when *debug-display-html-help*
 180                    (format *debug-io* "Command: ~S~%" command))
 181                  ($system command))
 182                 (t
 183                  (merror "Browser command must contain exactly one ~~A:  ~S" $browser))))))
 184     topic))
 185
 186 (defun display-html-topics (wanted)
 187   (when maxima::*debug-display-html-help*
 188     (format *debug-io* "wanted = ~S~%" wanted))
 189   (loop for (dir entry) in wanted
 190         do (display-html-help (car entry))))
 191
 192 (defun display-text-topics (wanted)
 193   (loop for item in wanted
 194         do (let ((doc (cl-info::read-info-text (first item) (second item))))
 195              (if doc
 196                  (format t "~A~%~%" doc)
 197                  (format t "Unable to find documentation for `~A'.~%~
 198                                 Possible bug maxima-index.lisp or build_index.pl?~%"
 199                          (first (second item)))))))
 200
 201 ;; Escape the characters that are special to XML. This mechanism excludes
 202 ;; the possibility that any keyword might coincide with the any xml tag
 203 ;; start or tag end marker.
 204 #+(or)
 205 (defun xml-fix-string (x)
 206   (when (stringp x)
 207     (let* ((tmp-x (wxxml-string-substitute "&amp;" #\& x))
 208            (tmp-x (wxxml-string-substitute "&lt;" #\< tmp-x))
 209            (tmp-x (wxxml-string-substitute "&gt;" #\> tmp-x))
 210            (tmp-x (wxxml-string-substitute "&#13;" #\Return tmp-x))
 211            (tmp-x (wxxml-string-substitute "&#13;" #\Linefeed tmp-x))
 212            (tmp-x (wxxml-string-substitute "&#13;" #\Newline tmp-x))
 213            (tmp-x (wxxml-string-substitute "&quot;" #\" tmp-x)))
 214       tmp-x)
 215     x))
 216
 217
 218 #+(or)
 219 (defun display-wxmaxima-topics (wanted)
 220   (loop for (dir entry) in wanted
 221         do
 222            ;; Tell wxMaxima to jump to the manual entry for "keyword"
 223            (format t "<html-manual-keyword>~a</html-manual-keyword>~%"
 224                    (xml-fix-string (car entry)))
 225            ;; Tell the lisp to make sure that this string is actually output
 226            ;; as soon as possible
 227            (finish-output)))
 228
 229 ;; When a frontend is running, this function should be redefined to
 230 ;; display the help in whatever way the frontend wants to.
 231 (defun display-frontend-topics (wanted)
 232   (declare (ignore wanted))
 233   (merror (intl:gettext "output_format_for_help: frontend not implemented.")))
 234
 235 (defun set-output-format-for-help (assign-var val)
 236   "When $output_format_for_help is set, this function validates the
 237   value and sets *help-display-function* to the function to display
 238   the help item in the specified format."
 239   ;; Don't need assign-var here.  It should be $output_format_for_help
 240   ;; since this function is only called when $output_format_for_help
 241   ;; is assigned.
 242   (declare (ignore assign-var))
 243   (case val
 244     ($text
 245      (setf *help-display-function* 'display-text-topics))
 246     ($html
 247      (setf *help-display-function* 'display-html-topics))
 248     ($frontend
 249      (if $maxima_frontend
 250          (setf *help-display-function* 'display-frontend-topics)
 251          (merror (intl:gettext "output_format_for_help set to frontend, but no frontend is running."))))
 252     (otherwise
 253      (merror (intl:gettext "output_format_for_help should be one of text, html, or frontend: ~M")
 254              val))))