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