archive/src/example.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;; This version of $example implements the following
   3 ;;; changes/improvements in the original version of example: 1)
   4 ;;; It handles %TH(2) correctly; 2) It makes effort to protect
   5 ;;; user-defined functions, variables, labels and arrays from
   6 ;;; being overwritten by an example; while protecting variables
   7 ;;; is quite straightforward, protecting functions is quite
   8 ;;; involved; it is done by moving the value of the property
   9 ;;; 'mprops' in a symbol property list to a property with a name
  10 ;;; generated by gensym; this happens before the examples are
  11 ;;; evaluated; afterwards the value of the property 'mprops' is
  12 ;;; restored; 3) rules and letrules are not being protected; it
  13 ;;; would be more complicated to make this feature work sanely;
  14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15
  16 (in-package "MAXIMA")
  17 (defmspec $example (item &optional (file
  18                                  (merge-pathnames "manual.demo"
  19                                                   $describe_documentation))
  20                       &aux tmp-name
  21                       )
  22   (and (symbolp file) (setq file (stripdollar file)))
  23   (or (probe-file file)
  24       (return-from $example "Please supply a file name as the second arg"))
  25   (and (symbolp item) (setq item (symbol-name item))
  26        (setq item (subseq item 1))
  27        (with-open-file
  28         (st file)
  29         (sloop with tem
  30                while (setq tem (read-char st nil))
  31                do
  32                (cond ((and (eql tem #\&)
  33                            (eql (setq tem (read-char st nil)) #\&))
  34                       (cond
  35                        ((and (symbolp (setq tem (read st nil)))
  36                              (string-search item (symbol-name tem)))
  37                         (format t "~%Examples for ~a :~%" tem)
  38                         ;; This code fulls maxima into thinking that it just
  39                         ;; started, by resetting the values of the special
  40                         ;; variables $labels and $linenum to their initial
  41                         ;; values. They will be reset just after $example
  42                         ;; is done. The d-labels will also not be disturbed
  43                         ;; by calling example.
  44                         ;;
  45                         ;; Hide the definitions of user functions.
  46                         (setq tmp-name
  47                               (hide-maxima-props
  48                                (mapcar #'caar (cdr $functions))))
  49                         (unwind-protect
  50                             (progv
  51                              ;; Protect the user labels, variables and functions
  52                              ;; from being overwritten.
  53                              (append '($linenum
  54                                        $labels
  55                                        $values
  56                                        $functions
  57                                        $arrays
  58                                        $%)
  59                                      (cdr $labels)
  60                                      (cdr $values)
  61                                      (cdr $arrays))
  62                              (list 1
  63                                    '((mlist simp))
  64                                    '((mlist simp))
  65                                    '((mlist simp))
  66                                    '((mlist simp)))
  67                              ;; Run the example.
  68                              (sloop until
  69                                     (or (null (setq tem (peek-char nil st nil)))
  70                                         (eql tem #\&))
  71                                     for expr = (mread st nil)
  72                                     do
  73                                     (let ($display2d) (displa (third  expr)))
  74                                     (let ((c-label (makelabel $inchar))
  75                                           (d-label (makelabel $outchar)))
  76                                       (set c-label (third expr))
  77                                       (format t "<~d>==>" $linenum)
  78                                       (displa (setq $% (meval* (third  expr))))
  79                                       (terpri )
  80                                       (set d-label $%)
  81                                       (incf $linenum)
  82                                       ))
  83                              ;; Clean-up time. Make all symbols used in
  84                              ;; the example unbound.
  85                              (mapc #'makunbound
  86                                    (append
  87                                     (cdr $labels)
  88                                     (cdr $values)
  89                                     (cdr $arrays))))
  90                           ;; Restore the defintions of functions.
  91                           (unhide-maxima-props
  92                            (mapcar #'caar (cdr $functions))
  93                            tmp-name))))))))))
  94
  95
  96 (defun hide-maxima-props (symbols
  97                           &aux tmp-name)
  98   ;; Rename the property mprops, under which the function
  99   ;; definition e.t.c. is stored, to tmp-name.
 100   (setq tmp-name (gensym))
 101   (dolist (symbol symbols)
 102           (putprop symbol (get symbol 'mprops) tmp-name)
 103           (remprop symbol 'mprops))
 104   ;; Return the temporary name of the property.
 105   tmp-name)
 106
 107 (defun unhide-maxima-props (symbols tmp-name)
 108   ;; Undo the action of hide-maxima-props.
 109   (dolist (symbol symbols)
 110           (putprop symbol (get symbol tmp-name) 'mprops)
 111           (remprop symbol tmp-name)))
 112