calc-prog.el

Revision 4220, 71.1 kB (checked in by miyoshi, 9 months ago)
Sync up with Emacs22.2.

Line
1	;;; calc-prog.el --- user programmability functions for Calc
2
3	;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4	;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5
6	;; Author: David Gillespie <daveg@synaptics.com>
7	;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
8
9	;; This file is part of GNU Emacs.
10
11	;; GNU Emacs is free software; you can redistribute it and/or modify
12	;; it under the terms of the GNU General Public License as published by
13	;; the Free Software Foundation; either version 3, or (at your option)
14	;; any later version.
15
16	;; GNU Emacs is distributed in the hope that it will be useful,
17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19	;; GNU General Public License for more details.
20
21	;; You should have received a copy of the GNU General Public License
22	;; along with GNU Emacs; see the file COPYING. If not, write to the
23	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24	;; Boston, MA 02110-1301, USA.
25
26	;;; Commentary:
27
28	;;; Code:
29
30	;; This file is autoloaded from calc-ext.el.
31
32	(require 'calc-ext)
33	(require 'calc-macs)
34
35
36	(defun calc-equal-to (arg)
37	(interactive "P")
38	(calc-wrapper
39	(if (and (integerp arg) (> arg 2))
40	(calc-enter-result arg "eq" (cons 'calcFunc-eq (calc-top-list-n arg)))
41	(calc-binary-op "eq" 'calcFunc-eq arg))))
42
43	(defun calc-remove-equal (arg)
44	(interactive "P")
45	(calc-wrapper
46	(calc-unary-op "rmeq" 'calcFunc-rmeq arg)))
47
48	(defun calc-not-equal-to (arg)
49	(interactive "P")
50	(calc-wrapper
51	(if (and (integerp arg) (> arg 2))
52	(calc-enter-result arg "neq" (cons 'calcFunc-neq (calc-top-list-n arg)))
53	(calc-binary-op "neq" 'calcFunc-neq arg))))
54
55	(defun calc-less-than (arg)
56	(interactive "P")
57	(calc-wrapper
58	(calc-binary-op "lt" 'calcFunc-lt arg)))
59
60	(defun calc-greater-than (arg)
61	(interactive "P")
62	(calc-wrapper
63	(calc-binary-op "gt" 'calcFunc-gt arg)))
64
65	(defun calc-less-equal (arg)
66	(interactive "P")
67	(calc-wrapper
68	(calc-binary-op "leq" 'calcFunc-leq arg)))
69
70	(defun calc-greater-equal (arg)
71	(interactive "P")
72	(calc-wrapper
73	(calc-binary-op "geq" 'calcFunc-geq arg)))
74
75	(defun calc-in-set (arg)
76	(interactive "P")
77	(calc-wrapper
78	(calc-binary-op "in" 'calcFunc-in arg)))
79
80	(defun calc-logical-and (arg)
81	(interactive "P")
82	(calc-wrapper
83	(calc-binary-op "land" 'calcFunc-land arg 1)))
84
85	(defun calc-logical-or (arg)
86	(interactive "P")
87	(calc-wrapper
88	(calc-binary-op "lor" 'calcFunc-lor arg 0)))
89
90	(defun calc-logical-not (arg)
91	(interactive "P")
92	(calc-wrapper
93	(calc-unary-op "lnot" 'calcFunc-lnot arg)))
94
95	(defun calc-logical-if ()
96	(interactive)
97	(calc-wrapper
98	(calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3)))))
99
100
101
102
103
104	(defun calc-timing (n)
105	(interactive "P")
106	(calc-wrapper
107	(calc-change-mode 'calc-timing n nil t)
108	(message (if calc-timing
109	"Reporting timing of slow commands in Trail"
110	"Not reporting timing of commands"))))
111
112	(defun calc-pass-errors ()
113	(interactive)
114	;; The following two cases are for the new, optimizing byte compiler
115	;; or the standard 18.57 byte compiler, respectively.
116	(condition-case err
117	(let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 15)))
118	(or (memq (car-safe (car-safe place)) '(error xxxerror))
119	(setq place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 27)))
120	(or (memq (car (car place)) '(error xxxerror))
121	(error "foo"))
122	(setcar (car place) 'xxxerror))
123	(error (error "The calc-do function has been modified; unable to patch"))))
124
125	(defun calc-user-define ()
126	(interactive)
127	(message "Define user key: z-")
128	(let ((key (read-char)))
129	(if (= (calc-user-function-classify key) 0)
130	(error "Can't redefine \"?\" key"))
131	(let ((func (intern (completing-read (concat "Set key z "
132	(char-to-string key)
133	" to command: ")
134	obarray
135	'commandp
136	t
137	"calc-"))))
138	(let* ((kmap (calc-user-key-map))
139	(old (assq key kmap)))
140	(if old
141	(setcdr old func)
142	(setcdr kmap (cons (cons key func) (cdr kmap))))))))
143
144	(defun calc-user-undefine ()
145	(interactive)
146	(message "Undefine user key: z-")
147	(let ((key (read-char)))
148	(if (= (calc-user-function-classify key) 0)
149	(error "Can't undefine \"?\" key"))
150	(let* ((kmap (calc-user-key-map)))
151	(delq (or (assq key kmap)
152	(assq (upcase key) kmap)
153	(assq (downcase key) kmap)
154	(error "No such user key is defined"))
155	kmap))))
156
157
158	;; math-integral-cache-state is originally declared in calcalg2.el,
159	;; it is used in calc-user-define-variable.
160	(defvar math-integral-cache-state)
161
162	;; calc-user-formula-alist is local to calc-user-define-formula,
163	;; calc-user-define-compostion and calc-finish-formula-edit,
164	;; but is used by calc-fix-user-formula.
165	(defvar calc-user-formula-alist)
166
167	(defun calc-user-define-formula ()
168	(interactive)
169	(calc-wrapper
170	(let* ((form (calc-top 1))
171	(arglist nil)
172	(is-lambda (and (eq (car-safe form) 'calcFunc-lambda)
173	(>= (length form) 2)))
174	odef key keyname cmd cmd-base cmd-base-default
175	func calc-user-formula-alist is-symb)
176	(if is-lambda
177	(setq arglist (mapcar (function (lambda (x) (nth 1 x)))
178	(nreverse (cdr (reverse (cdr form)))))
179	form (nth (1- (length form)) form))
180	(calc-default-formula-arglist form)
181	(setq arglist (sort arglist 'string-lessp)))
182	(message "Define user key: z-")
183	(setq key (read-char))
184	(if (= (calc-user-function-classify key) 0)
185	(error "Can't redefine \"?\" key"))
186	(setq key (and (not (memq key '(13 32))) key)
187	keyname (and key
188	(if (or (and (<= ?0 key) (<= key ?9))
189	(and (<= ?a key) (<= key ?z))
190	(and (<= ?A key) (<= key ?Z)))
191	(char-to-string key)
192	(format "%03d" key)))
193	odef (assq key (calc-user-key-map)))
194	(unless keyname
195	(setq keyname (format "%05d" (abs (% (random) 10000)))))
196	(while
197	(progn
198	(setq cmd-base-default (concat "User-" keyname))
199	(setq cmd (completing-read
200	(concat "Define M-x command name (default calc-"
201	cmd-base-default
202	"): ")
203	obarray 'commandp nil
204	(if (and odef (symbolp (cdr odef)))
205	(symbol-name (cdr odef))
206	"calc-")))
207	(if (or (string-equal cmd "")
208	(string-equal cmd "calc-"))
209	(setq cmd (concat "calc-User-" keyname)))
210	(setq cmd-base (and (string-match "\\`calc-\$.+\$\\'" cmd)
211	(math-match-substring cmd 1)))
212	(setq cmd (intern cmd))
213	(and cmd
214	(fboundp cmd)
215	odef
216	(not
217	(y-or-n-p
218	(if (get cmd 'calc-user-defn)
219	(concat "Replace previous definition for "
220	(symbol-name cmd) "? ")
221	"That name conflicts with a built-in Emacs function. Replace this function? "))))))
222	(while
223	(progn
224	(setq cmd-base-default
225	(if cmd-base
226	(if (string-match
227	"\\`User-.+" cmd-base)
228	(concat
229	"User"
230	(substring cmd-base 5))
231	cmd-base)
232	(concat "User" keyname)))
233	(setq func
234	(concat "calcFunc-"
235	(completing-read
236	(concat "Define algebraic function name (default "
237	cmd-base-default "): ")
238	(mapcar (lambda (x) (substring x 9))
239	(all-completions "calcFunc-"
240	obarray))
241	(lambda (x)
242	(fboundp
243	(intern (concat "calcFunc-" x))))
244	nil)))
245	(setq func
246	(if (string-equal func "calcFunc-")
247	(intern (concat "calcFunc-" cmd-base-default))
248	(intern func)))
249	(and func
250	(fboundp func)
251	(not (fboundp cmd))
252	odef
253	(not
254	(y-or-n-p
255	(if (get func 'calc-user-defn)
256	(concat "Replace previous definition for "
257	(symbol-name func) "? ")
258	"That name conflicts with a built-in Emacs function. Replace this function? "))))))
259
260	(if (not func)
261	(setq func (intern (concat "calcFunc-User"
262	(or keyname
263	(and cmd (symbol-name cmd))
264	(format "%05d" (% (random) 10000)))))))
265
266	(if is-lambda
267	(setq calc-user-formula-alist arglist)
268	(while
269	(progn
270	(setq calc-user-formula-alist
271	(read-from-minibuffer "Function argument list: "
272	(if arglist
273	(prin1-to-string arglist)
274	"()")
275	minibuffer-local-map
276	t))
277	(and (not (calc-subsetp calc-user-formula-alist arglist))
278	(not (y-or-n-p
279	"Okay for arguments that don't appear in formula to be ignored? "))))))
280	(setq is-symb (and calc-user-formula-alist
281	func
282	(y-or-n-p
283	"Leave it symbolic for non-constant arguments? ")))
284	(setq calc-user-formula-alist
285	(mapcar (function (lambda (x)
286	(or (cdr (assq x '((nil . arg-nil)
287	(t . arg-t))))
288	x))) calc-user-formula-alist))
289	(if cmd
290	(progn
291	(require 'calc-macs)
292	(fset cmd
293	(list 'lambda
294	'()
295	'(interactive)
296	(list 'calc-wrapper
297	(list 'calc-enter-result
298	(length calc-user-formula-alist)
299	(let ((name (symbol-name (or func cmd))))
300	(and (string-match
301	*"\$[^-][^-]?[^-]?[^-]?\$[^-]\\'"**
302	name)
303	(math-match-substring name 1)))
304	(list 'cons
305	(list 'quote func)
306	(list 'calc-top-list-n
307	(length calc-user-formula-alist)))))))
308	(put cmd 'calc-user-defn t)))
309	(let ((body (list 'math-normalize (calc-fix-user-formula form))))
310	(fset func
311	(append
312	(list 'lambda calc-user-formula-alist)
313	(and is-symb
314	(mapcar (function (lambda (v)
315	(list 'math-check-const v t)))
316	calc-user-formula-alist))
317	(list body))))
318	(put func 'calc-user-defn form)
319	(setq math-integral-cache-state nil)
320	(if key
321	(let* ((kmap (calc-user-key-map))
322	(old (assq key kmap)))
323	(if old
324	(setcdr old cmd)
325	(setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
326	(message "")))
327
328	(defun calc-default-formula-arglist (form)
329	(if (consp form)
330	(if (eq (car form) 'var)
331	(if (or (memq (nth 1 form) arglist)
332	(math-const-var form))
333	()
334	(setq arglist (cons (nth 1 form) arglist)))
335	(calc-default-formula-arglist-step (cdr form)))))
336
337	(defun calc-default-formula-arglist-step (l)
338	(and l
339	(progn
340	(calc-default-formula-arglist (car l))
341	(calc-default-formula-arglist-step (cdr l)))))
342
343	(defun calc-subsetp (a b)
344	(or (null a)
345	(and (memq (car a) b)
346	(calc-subsetp (cdr a) b))))
347
348	(defun calc-fix-user-formula (f)
349	(if (consp f)
350	(let (temp)
351	(cond ((and (eq (car f) 'var)
352	(memq (setq temp (or (cdr (assq (nth 1 f) '((nil . arg-nil)
353	(t . arg-t))))
354	(nth 1 f)))
355	calc-user-formula-alist))
356	temp)
357	((or (math-constp f) (eq (car f) 'var))
358	(list 'quote f))
359	((and (eq (car f) 'calcFunc-eval)
360	(= (length f) 2))
361	(list 'let '((calc-simplify-mode nil))
362	(list 'math-normalize (calc-fix-user-formula (nth 1 f)))))
363	((and (eq (car f) 'calcFunc-evalsimp)
364	(= (length f) 2))
365	(list 'math-simplify (calc-fix-user-formula (nth 1 f))))
366	((and (eq (car f) 'calcFunc-evalextsimp)
367	(= (length f) 2))
368	(list 'math-simplify-extended
369	(calc-fix-user-formula (nth 1 f))))
370	(t
371	(cons 'list
372	(cons (list 'quote (car f))
373	(mapcar 'calc-fix-user-formula (cdr f)))))))
374	f))
375
376	(defun calc-user-define-composition ()
377	(interactive)
378	(calc-wrapper
379	(if (eq calc-language 'unform)
380	(error "Can't define formats for unformatted mode"))
381	(let* ((comp (calc-top 1))
382	(func (intern
383	(concat "calcFunc-"
384	(completing-read "Define format for which function: "
385	(mapcar (lambda (x) (substring x 9))
386	(all-completions "calcFunc-"
387	obarray))
388	(lambda (x)
389	(fboundp
390	(intern (concat "calcFunc-" x))))))))
391	(comps (get func 'math-compose-forms))
392	entry entry2
393	(arglist nil)
394	(calc-user-formula-alist nil))
395	(if (math-zerop comp)
396	(if (setq entry (assq calc-language comps))
397	(put func 'math-compose-forms (delq entry comps)))
398	(calc-default-formula-arglist comp)
399	(setq arglist (sort arglist 'string-lessp))
400	(while
401	(progn
402	(setq calc-user-formula-alist
403	(read-from-minibuffer "Composition argument list: "
404	(if arglist
405	(prin1-to-string arglist)
406	"()")
407	minibuffer-local-map
408	t))
409	(and (not (calc-subsetp calc-user-formula-alist arglist))
410	(y-or-n-p
411	"Okay for arguments that don't appear in formula to be invisible? "))))
412	(or (setq entry (assq calc-language comps))
413	(put func 'math-compose-forms
414	(cons (setq entry (list calc-language)) comps)))
415	(or (setq entry2 (assq (length calc-user-formula-alist) (cdr entry)))
416	(setcdr entry
417	(cons (setq entry2
418	(list (length calc-user-formula-alist))) (cdr entry))))
419	(setcdr entry2
420	(list 'lambda calc-user-formula-alist (calc-fix-user-formula comp))))
421	(calc-pop-stack 1)
422	(calc-do-refresh))))
423
424
425	(defun calc-user-define-kbd-macro (arg)
426	(interactive "P")
427	(or last-kbd-macro
428	(error "No keyboard macro defined"))
429	(message "Define last kbd macro on user key: z-")
430	(let ((key (read-char)))
431	(if (= (calc-user-function-classify key) 0)
432	(error "Can't redefine \"?\" key"))
433	(let ((cmd (intern (completing-read "Full name for new command: "
434	obarray
435	'commandp
436	nil
437	(concat "calc-User-"
438	(if (or (and (>= key ?a)
439	(<= key ?z))
440	(and (>= key ?A)
441	(<= key ?Z))
442	(and (>= key ?0)
443	(<= key ?9)))
444	(char-to-string key)
445	(format "%03d" key)))))))
446	(and (fboundp cmd)
447	(not (let ((f (symbol-function cmd)))
448	(or (stringp f)
449	(and (consp f)
450	(eq (car-safe (nth 3 f))
451	'calc-execute-kbd-macro)))))
452	(error "Function %s is already defined and not a keyboard macro"
453	cmd))
454	(put cmd 'calc-user-defn t)
455	(fset cmd (if (< (prefix-numeric-value arg) 0)
456	last-kbd-macro
457	(list 'lambda
458	'(arg)
459	'(interactive "P")
460	(list 'calc-execute-kbd-macro
461	(vector (key-description last-kbd-macro)
462	last-kbd-macro)
463	'arg
464	(format "z%c" key)))))
465	(let* ((kmap (calc-user-key-map))
466	(old (assq key kmap)))
467	(if old
468	(setcdr old cmd)
469	(setcdr kmap (cons (cons key cmd) (cdr kmap))))))))
470
471
472	(defun calc-edit-user-syntax ()
473	(interactive)
474	(calc-wrapper
475	(let ((lang calc-language))
476	(calc-edit-mode (list 'calc-finish-user-syntax-edit (list 'quote lang))
477	t
478	(format "Editing %s-Mode Syntax Table. "
479	(cond ((null lang) "Normal")
480	((eq lang 'tex) "TeX")
481	((eq lang 'latex) "LaTeX")
482	(t (capitalize (symbol-name lang))))))
483	(calc-write-parse-table (cdr (assq lang calc-user-parse-tables))
484	lang)))
485	(calc-show-edit-buffer))
486
487	(defvar calc-original-buffer)
488
489	(defun calc-finish-user-syntax-edit (lang)
490	(let ((tab (calc-read-parse-table calc-original-buffer lang))
491	(entry (assq lang calc-user-parse-tables)))
492	(if tab
493	(setcdr (or entry
494	(car (setq calc-user-parse-tables
495	(cons (list lang) calc-user-parse-tables))))
496	tab)
497	(if entry
498	(setq calc-user-parse-tables
499	(delq entry calc-user-parse-tables)))))
500	(switch-to-buffer calc-original-buffer))
501
502	;; The variable calc-lang is local to calc-write-parse-table, but is
503	;; used by calc-write-parse-table-part which is called by
504	;; calc-write-parse-table. The variable is also local to
505	;; calc-read-parse-table, but is used by calc-fix-token-name which
506	;; is called (indirectly) by calc-read-parse-table.
507	(defvar calc-lang)
508
509	(defun calc-write-parse-table (tab calc-lang)
510	(let ((p tab))
511	(while p
512	(calc-write-parse-table-part (car (car p)))
513	(insert ":= "
514	(let ((math-format-hash-args t))
515	(math-format-flat-expr (cdr (car p)) 0))
516	"\n")
517	(setq p (cdr p)))))
518
519	(defun calc-write-parse-table-part (p)
520	(while p
521	(cond ((stringp (car p))
522	(let ((s (car p)))
523	(if (and (string-match "\\`\\\\dots\\>" s)
524	(not (memq calc-lang '(tex latex))))
525	(setq s (concat ".." (substring s 5))))
526	(if (or (and (string-match
527	"[a-zA-Z0-9\"{}]\\\|\\`:=\\'\\\|\\`#\\\|\\`%%" s)
528	(string-match "[^a-zA-Z0-9\\]" s))
529	(and (assoc s '((")") ("]") (">")))
530	(not (cdr p))))
531	(insert (prin1-to-string s) " ")
532	(insert s " "))))
533	((integerp (car p))
534	(insert "#")
535	(or (= (car p) 0)
536	(insert "/" (int-to-string (car p))))
537	(insert " "))
538	((and (eq (car (car p)) '\?) (equal (car (nth 2 (car p))) "$$"))
539	(insert (car (nth 1 (car p))) " "))
540	(t
541	(insert "{ ")
542	(calc-write-parse-table-part (nth 1 (car p)))
543	(insert "}" (symbol-name (car (car p))))
544	(if (nth 2 (car p))
545	(calc-write-parse-table-part (list (car (nth 2 (car p)))))
546	(insert " "))))
547	(setq p (cdr p))))
548
549	(defun calc-read-parse-table (calc-buf calc-lang)
550	(let ((tab nil))
551	(while (progn
552	(skip-chars-forward "\n\t ")
553	(not (eobp)))
554	(if (looking-at "%%")
555	(end-of-line)
556	(let ((pt (point))
557	(p (calc-read-parse-table-part ":=[\n\t ]+" ":=")))
558	(or (stringp (car p))
559	(and (integerp (car p))
560	(stringp (nth 1 p)))
561	(progn
562	(goto-char pt)
563	(error "Malformed syntax rule")))
564	(let ((pos (point)))
565	(end-of-line)
566	(let* ((str (buffer-substring pos (point)))
567	(exp (save-excursion
568	(set-buffer calc-buf)
569	(let ((calc-user-parse-tables nil)
570	(calc-language nil)
571	(math-expr-opers math-standard-opers)
572	(calc-hashes-used 0))
573	(math-read-expr
574	(if (string-match *",[ \t]\\'"** str)
575	(substring str 0 (match-beginning 0))
576	str))))))
577	(if (eq (car-safe exp) 'error)
578	(progn
579	(goto-char (+ pos (nth 1 exp)))
580	(error (nth 2 exp))))
581	(setq tab (nconc tab (list (cons p exp)))))))))
582	tab))
583
584	(defun calc-fix-token-name (name &optional unquoted)
585	(cond ((string-match "\\`\\.\\." name)
586	(concat "\\dots" (substring name 2)))
587	((and (equal name "{") (memq calc-lang '(tex latex eqn)))
588	"(")
589	((and (equal name "}") (memq calc-lang '(tex latex eqn)))
590	")")
591	((and (equal name "&") (memq calc-lang '(tex latex)))
592	",")
593	((equal name "#")
594	(search-backward "#")
595	(error "Token '#' is reserved"))
596	((and unquoted (string-match "#" name))
597	(error "Tokens containing '#' must be quoted"))
598	((not (string-match "[^ ]" name))
599	(search-backward "\"" nil t)
600	(error "Blank tokens are not allowed"))
601	(t name)))
602
603	(defun calc-read-parse-table-part (term eterm)
604	(let ((part nil)
605	(quoted nil))
606	(while (progn
607	(skip-chars-forward "\n\t ")
608	(if (eobp) (error "Expected '%s'" eterm))
609	(not (looking-at term)))
610	(cond ((looking-at "%%")
611	(end-of-line))
612	((looking-at "{[\n\t ]")
613	(forward-char 2)
614	(let ((p (calc-read-parse-table-part "}" "}")))
615	(or (looking-at *"[+?]"**)
616	(error *"Expected '+', '', or '?'"**))
617	(let ((sym (intern (buffer-substring (point) (1+ (point))))))
618	(forward-char 1)
619	(looking-at *"[^\n\t ]"**)
620	(let ((sep (buffer-substring (point) (match-end 0))))
621	(goto-char (match-end 0))
622	(and (eq sym '\?) (> (length sep) 0)
623	(not (equal sep "$")) (not (equal sep "."))
624	(error "Separator not allowed with { ... }?"))
625	(if (string-match "\\`\"" sep)
626	(setq sep (read-from-string sep)))
627	(setq sep (calc-fix-token-name sep))
628	(setq part (nconc part
629	(list (list sym p
630	(and (> (length sep) 0)
631	(cons sep p))))))))))
632	((looking-at "}")
633	(error "Too many }'s"))
634	((looking-at "\"")
635	(setq quoted (calc-fix-token-name (read (current-buffer)))
636	part (nconc part (list quoted))))
637	((looking-at "#\$\\(/[0-9]+\$?\\)[\n\t ]")
638	(setq part (nconc part (list (if (= (match-beginning 1)
639	(match-end 1))
640	0
641	(string-to-number
642	(buffer-substring
643	(1+ (match-beginning 1))
644	(match-end 1)))))))
645	(goto-char (match-end 0)))
646	((looking-at ":=[\n\t ]")
647	(error "Misplaced ':='"))
648	(t
649	(looking-at *"[^\n\t ]"**)
650	(let ((end (match-end 0)))
651	(setq part (nconc part (list (calc-fix-token-name
652	(buffer-substring
653	(point) end) t))))
654	(goto-char end)))))
655	(goto-char (match-end 0))
656	(let ((len (length part)))
657	(while (and (> len 1)
658	(let ((last (nthcdr (setq len (1- len)) part)))
659	(and (assoc (car last) '((")") ("]") (">")))
660	(not (eq (car last) quoted))
661	(setcar last
662	(list '\? (list (car last)) '("$$"))))))))
663	part))
664
665	(defun calc-user-define-invocation ()
666	(interactive)
667	(or last-kbd-macro
668	(error "No keyboard macro defined"))
669	(setq calc-invocation-macro last-kbd-macro)
670	(message *"Use `C-x Z' to invoke this macro"**))
671
672	(defun calc-user-define-edit ()
673	(interactive) ; but no calc-wrapper!
674	(message "Edit definition of command: z-")
675	(let* (cmdname
676	(key (read-char))
677	(def (or (assq key (calc-user-key-map))
678	(assq (upcase key) (calc-user-key-map))
679	(assq (downcase key) (calc-user-key-map))
680	(error "No command defined for that key")))
681	(cmd (cdr def)))
682	(when (symbolp cmd)
683	(setq cmdname (symbol-name cmd))
684	(setq cmd (symbol-function cmd)))
685	(cond ((or (stringp cmd)
686	(and (consp cmd)
687	(eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro)))
688	(let* ((mac (elt (nth 1 (nth 3 cmd)) 1))
689	(str (edmacro-format-keys mac t))
690	(kys (nth 3 (nth 3 cmd))))
691	(calc-edit-mode
692	(list 'calc-edit-macro-finish-edit cmdname kys)
693	t (format (concat
694	"Editing keyboard macro (%s, bound to %s).\n"
695	"Original keys: %s \n")
696	cmdname kys (elt (nth 1 (nth 3 cmd)) 0)))
697	(insert str "\n")
698	(calc-edit-format-macro-buffer)
699	(calc-show-edit-buffer)))
700	(t (let* ((func (calc-stack-command-p cmd))
701	(defn (and func
702	(symbolp func)
703	(get func 'calc-user-defn)))
704	(kys (concat "z" (char-to-string (car def))))
705	(intcmd (symbol-name (cdr def)))
706	(algcmd (if func (substring (symbol-name func) 9) "")))
707	(if (and defn (calc-valid-formula-func func))
708	(let ((niceexpr (math-format-nice-expr defn (frame-width))))
709	(calc-wrapper
710	(calc-edit-mode
711	(list 'calc-finish-formula-edit (list 'quote func))
712	nil
713	(format (concat
714	"Editing formula (%s, %s, bound to %s).\n"
715	"Original formula: %s\n")
716	intcmd algcmd kys niceexpr))
717	(insert (math-showing-full-precision
718	niceexpr)
719	"\n"))
720	(calc-show-edit-buffer))
721	(error "That command's definition cannot be edited")))))))
722
723	;; Formatting the macro buffer
724
725	(defvar calc-edit-top)
726
727	(defun calc-edit-macro-repeats ()
728	(goto-char calc-edit-top)
729	(while
730	(re-search-forward *"^\$[0-9]+\$\\"** nil t)
731	(let ((num (string-to-number (match-string 1)))
732	(line (buffer-substring (point) (line-end-position))))
733	(goto-char (line-beginning-position))
734	(kill-line 1)
735	(while (> num 0)
736	(insert line "\n")
737	(setq num (1- num))))))
738
739	(defun calc-edit-macro-adjust-buffer ()
740	(calc-edit-macro-repeats)
741	(goto-char calc-edit-top)
742	(while (re-search-forward "^RET$" nil t)
743	(delete-char 1))
744	(goto-char calc-edit-top)
745	(while (and (re-search-forward "^$" nil t)
746	(not (= (point) (point-max))))
747	(delete-char 1)))
748
749	(defun calc-edit-macro-command ()
750	"Return the command on the current line in a Calc macro editing buffer."
751	(let ((beg (line-beginning-position))
752	(