root/trunk/lisp/calc/calc-aent.el

Revision 4220, 43.1 kB (checked in by miyoshi, 9 months ago)

Sync up with Emacs22.2.

Line 
1 ;;; calc-aent.el --- algebraic entry 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: Dave 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.el.
31
32 (require 'calc)
33 (require 'calc-macs)
34
35 (defvar calc-quick-calc-history nil
36   "The history list for quick-calc.")
37
38 (defun calc-do-quick-calc ()
39   (require 'calc-ext)
40   (calc-check-defines)
41   (if (eq major-mode 'calc-mode)
42       (calc-algebraic-entry t)
43     (let (buf shortbuf)
44       (save-excursion
45         (calc-create-buffer)
46         (let* ((calc-command-flags nil)
47                (calc-dollar-values calc-quick-prev-results)
48                (calc-dollar-used 0)
49                (enable-recursive-minibuffers t)
50                (calc-language (if (memq calc-language '(nil big))
51                                   'flat calc-language))
52                (entry (calc-do-alg-entry "" "Quick calc: " t 'calc-quick-calc-history))
53                (alg-exp (mapcar 'math-evaluate-expr entry)))
54           (when (and (= (length alg-exp) 1)
55                      (eq (car-safe (car alg-exp)) 'calcFunc-assign)
56                      (= (length (car alg-exp)) 3)
57                      (eq (car-safe (nth 1 (car alg-exp))) 'var))
58             (set (nth 2 (nth 1 (car alg-exp))) (nth 2 (car alg-exp)))
59             (calc-refresh-evaltos (nth 2 (nth 1 (car alg-exp))))
60             (setq alg-exp (list (nth 2 (car alg-exp)))))
61           (setq calc-quick-prev-results alg-exp
62                 buf (mapconcat (function (lambda (x)
63                                            (math-format-value x 1000)))
64                                alg-exp
65                                " ")
66                 shortbuf buf)
67           (if (and (= (length alg-exp) 1)
68                    (memq (car-safe (car alg-exp)) '(nil bigpos bigneg))
69                    (< (length buf) 20)
70                    (= calc-number-radix 10))
71               (setq buf (concat buf "  ("
72                                 (let ((calc-number-radix 16))
73                                   (math-format-value (car alg-exp) 1000))
74                                 ", "
75                                 (let ((calc-number-radix 8))
76                                   (math-format-value (car alg-exp) 1000))
77                                 (if (and (integerp (car alg-exp))
78                                          (> (car alg-exp) 0)
79                                          (< (car alg-exp) 127))
80                                     (format ", \"%c\"" (car alg-exp))
81                                   "")
82                                 ")")))
83           (if (and (< (length buf) (frame-width)) (= (length entry) 1)
84                    (featurep 'calc-ext))
85               (let ((long (concat (math-format-value (car entry) 1000)
86                                   " =>  " buf)))
87                 (if (<= (length long) (- (frame-width) 8))
88                     (setq buf long))))
89           (calc-handle-whys)
90           (message "Result: %s" buf)))
91       (if (eq last-command-char 10)
92           (insert shortbuf)
93         (kill-new shortbuf)))))
94
95 (defun calc-do-calc-eval (str separator args)
96   (calc-check-defines)
97   (catch 'calc-error
98     (save-excursion
99       (calc-create-buffer)
100       (cond
101        ((and (consp str) (not (symbolp (car str))))
102         (let ((calc-language nil)
103               (math-expr-opers math-standard-opers)
104               (calc-internal-prec 12)
105               (calc-word-size 32)
106               (calc-symbolic-mode nil)
107               (calc-matrix-mode nil)
108               (calc-angle-mode 'deg)
109               (calc-number-radix 10)
110               (calc-leading-zeros nil)
111               (calc-group-digits nil)
112               (calc-point-char ".")
113               (calc-frac-format '(":" nil))
114               (calc-prefer-frac nil)
115               (calc-hms-format "%s@ %s' %s\"")
116               (calc-date-format '((H ":" mm C SS pp " ")
117                                   Www " " Mmm " " D ", " YYYY))
118               (calc-float-format '(float 0))
119               (calc-full-float-format '(float 0))
120               (calc-complex-format nil)
121               (calc-matrix-just nil)
122               (calc-full-vectors t)
123               (calc-break-vectors nil)
124               (calc-vector-commas ",")
125               (calc-vector-brackets "[]")
126               (calc-matrix-brackets '(R O))
127               (calc-complex-mode 'cplx)
128               (calc-infinite-mode nil)
129               (calc-display-strings nil)
130               (calc-simplify-mode nil)
131               (calc-display-working-message 'lots)
132               (strp (cdr str)))
133           (while strp
134             (set (car strp) (nth 1 strp))
135             (setq strp (cdr (cdr strp))))
136           (calc-do-calc-eval (car str) separator args)))
137        ((eq separator 'eval)
138         (eval str))
139        ((eq separator 'macro)
140         (require 'calc-ext)
141         (let* ((calc-buffer (current-buffer))
142                (calc-window (get-buffer-window calc-buffer))
143                (save-window (selected-window)))
144           (if calc-window
145               (unwind-protect
146                   (progn
147                     (select-window calc-window)
148                     (calc-execute-kbd-macro str nil (car args)))
149                 (and (window-point save-window)
150                      (select-window save-window)))
151             (save-window-excursion
152               (select-window (get-largest-window))
153               (switch-to-buffer calc-buffer)
154               (calc-execute-kbd-macro str nil (car args)))))
155         nil)
156        ((eq separator 'pop)
157         (or (not (integerp str))
158             (= str 0)
159             (calc-pop (min str (calc-stack-size))))
160         (calc-stack-size))
161        ((eq separator 'top)
162         (and (integerp str)
163              (> str 0)
164              (<= str (calc-stack-size))
165              (math-format-value (calc-top-n str (car args)) 1000)))
166        ((eq separator 'rawtop)
167         (and (integerp str)
168              (> str 0)
169              (<= str (calc-stack-size))
170              (calc-top-n str (car args))))
171        (t
172         (let* ((calc-command-flags nil)
173                (calc-next-why nil)
174                (calc-language (if (memq calc-language '(nil big))
175                                   'flat calc-language))
176                (calc-dollar-values (mapcar
177                                     (function
178                                      (lambda (x)
179                                        (if (stringp x)
180                                            (progn
181                                              (setq x (math-read-exprs x))
182                                              (if (eq (car-safe x)
183                                                      'error)
184                                                  (throw 'calc-error
185                                                         (calc-eval-error
186                                                          (cdr x)))
187                                                (car x)))
188                                          x)))
189                                     args))
190                (calc-dollar-used 0)
191                (res (if (stringp str)
192                         (math-read-exprs str)
193                       (list str)))
194                buf)
195           (if (eq (car res) 'error)
196               (calc-eval-error (cdr res))
197             (setq res (mapcar 'calc-normalize res))
198             (and (memq 'clear-message calc-command-flags)
199                  (message ""))
200             (cond ((eq separator 'pred)
201                    (require 'calc-ext)
202                    (if (= (length res) 1)
203                        (math-is-true (car res))
204                      (calc-eval-error '(0 "Single value expected"))))
205                   ((eq separator 'raw)
206                    (if (= (length res) 1)
207                        (car res)
208                      (calc-eval-error '(0 "Single value expected"))))
209                   ((eq separator 'list)
210                    res)
211                   ((memq separator '(num rawnum))
212                    (if (= (length res) 1)
213                        (if (math-constp (car res))
214                            (if (eq separator 'num)
215                                (math-format-value (car res) 1000)
216                              (car res))
217                          (calc-eval-error
218                           (list 0
219                                 (if calc-next-why
220                                     (calc-explain-why (car calc-next-why))
221                                   "Number expected"))))
222                      (calc-eval-error '(0 "Single value expected"))))
223                   ((eq separator 'push)
224                    (calc-push-list res)
225                    nil)
226                   (t (while res
227                        (setq buf (concat buf
228                                          (and buf (or separator ", "))
229                                          (math-format-value (car res) 1000))
230                              res (cdr res)))
231                      buf)))))))))
232
233 (defvar calc-eval-error nil
234   "Determines how calc handles errors.
235 If nil, return a list containing the character position of error.
236 STRING means return error message as string rather than list.
237 The value t means abort and give an error message.")
238
239 (defun calc-eval-error (msg)
240   (if calc-eval-error
241       (if (eq calc-eval-error 'string)
242           (nth 1 msg)
243         (error "%s" (nth 1 msg)))
244     msg))
245
246
247 ;;;; Reading an expression in algebraic form.
248
249 (defun calc-auto-algebraic-entry (&optional prefix)
250   (interactive "P")
251   (calc-algebraic-entry prefix t))
252
253 (defun calc-algebraic-entry (&optional prefix auto)
254   (interactive "P")
255   (calc-wrapper
256    (let ((calc-language (if prefix nil calc-language))
257          (math-expr-opers (if prefix math-standard-opers math-expr-opers)))
258      (calc-alg-entry (and auto (char-to-string last-command-char))))))
259
260 (defvar calc-alg-entry-history nil
261   "History for algebraic entry.")
262
263 (defun calc-alg-entry (&optional initial prompt)
264   (let* ((sel-mode nil)
265          (calc-dollar-values (mapcar 'calc-get-stack-element
266                                      (nthcdr calc-stack-top calc-stack)))
267          (calc-dollar-used 0)
268          (calc-plain-entry t)
269          (alg-exp (calc-do-alg-entry initial prompt t 'calc-alg-entry-history)))
270     (if (stringp alg-exp)
271         (progn
272           (require 'calc-ext)
273           (calc-alg-edit alg-exp))
274       (let* ((calc-simplify-mode (if (eq last-command-char ?\C-j)
275                                      'none
276                                    calc-simplify-mode))
277              (nvals (mapcar 'calc-normalize alg-exp)))
278         (while alg-exp
279           (calc-record (if (featurep 'calc-ext) (car alg-exp) (car nvals))
280                        "alg'")
281           (calc-pop-push-record-list calc-dollar-used
282                                      (and (not (equal (car alg-exp)
283                                                       (car nvals)))
284                                           (featurep 'calc-ext)
285                                           "")
286                                      (list (car nvals)))
287           (setq alg-exp (cdr alg-exp)
288                 nvals (cdr nvals)
289                 calc-dollar-used 0)))
290       (calc-handle-whys))))
291
292 (defvar calc-alg-ent-map nil
293   "The keymap used for algebraic entry.")
294
295 (defvar calc-alg-ent-esc-map nil
296   "The keymap used for escapes in algebraic entry.")
297
298 (defvar calc-alg-exp)
299
300 (defun calc-do-alg-entry (&optional initial prompt no-normalize history)
301   (let* ((calc-buffer (current-buffer))
302          (blink-paren-function 'calcAlg-blink-matching-open)
303          (calc-alg-exp 'error))
304     (unless calc-alg-ent-map
305       (setq calc-alg-ent-map (copy-keymap minibuffer-local-map))
306       (define-key calc-alg-ent-map "'" 'calcAlg-previous)
307       (define-key calc-alg-ent-map "`" 'calcAlg-edit)
308       (define-key calc-alg-ent-map "\C-m" 'calcAlg-enter)
309       (define-key calc-alg-ent-map "\C-j" 'calcAlg-enter)
310       (let ((i 33))
311         (setq calc-alg-ent-esc-map (copy-keymap esc-map))
312         (while (< i 127)
313           (aset (nth 1 calc-alg-ent-esc-map) i 'calcAlg-escape)
314           (setq i (1+ i)))))
315     (define-key calc-alg-ent-map "\e" nil)
316     (if (eq calc-algebraic-mode 'total)
317         (define-key calc-alg-ent-map "\e" calc-alg-ent-esc-map)
318       (define-key calc-alg-ent-map "\e+" 'calcAlg-plus-minus)
319       (define-key calc-alg-ent-map "\em" 'calcAlg-mod)
320       (define-key calc-alg-ent-map "\e=" 'calcAlg-equals)
321       (define-key calc-alg-ent-map "\e\r" 'calcAlg-equals)
322       (define-key calc-alg-ent-map "\ep" 'previous-history-element)
323       (define-key calc-alg-ent-map "\en" 'next-history-element)
324       (define-key calc-alg-ent-map "\e%" 'self-insert-command))
325     (setq calc-aborted-prefix nil)
326     (let ((buf (read-from-minibuffer (or prompt "Algebraic: ")
327                                      (or initial "")
328                                      calc-alg-ent-map nil history)))
329       (when (eq calc-alg-exp 'error)
330         (when (eq (car-safe (setq calc-alg-exp (math-read-exprs buf))) 'error)
331           (setq calc-alg-exp nil)))
332       (setq calc-aborted-prefix "alg'")
333       (or no-normalize
334           (and calc-alg-exp (setq calc-alg-exp (mapcar 'calc-normalize calc-alg-exp))))
335       calc-alg-exp)))
336
337 (defun calcAlg-plus-minus ()
338   (interactive)
339   (if (calc-minibuffer-contains ".* \\'")
340       (insert "+/- ")
341     (insert " +/- ")))
342
343 (defun calcAlg-mod ()
344   (interactive)
345   (if (not (calc-minibuffer-contains ".* \\'"))
346       (insert " "))
347   (if (calc-minibuffer-contains ".* mod +\\'")
348       (if calc-previous-modulo
349           (insert (math-format-flat-expr calc-previous-modulo 0))
350         (beep))
351     (insert "mod ")))
352
353 (defun calcAlg-previous ()
354   (interactive)
355   (if (calc-minibuffer-contains "\\'")
356       (previous-history-element 1)
357     (insert "'")))
358
359 (defun calcAlg-equals ()
360   (interactive)
361   (unwind-protect
362       (calcAlg-enter)
363     (if (consp calc-alg-exp)
364         (progn (setq prefix-arg (length calc-alg-exp))
365                (calc-unread-command ?=)))))
366
367 (defun calcAlg-escape ()
368   (interactive)
369   (calc-unread-command)
370   (save-excursion
371     (calc-select-buffer)
372     (use-local-map calc-mode-map))
373   (calcAlg-enter))
374
375 (defvar calc-plain-entry nil)
376 (defun calcAlg-edit ()
377   (interactive)
378   (if (or (not calc-plain-entry)
379           (calc-minibuffer-contains
380            "\\`\\([^\"]*\"[^\"]*\"\\)*[^\"]*\"[^\"]*\\'"))
381       (insert "`")
382     (setq calc-alg-exp (minibuffer-contents))
383     (exit-minibuffer)))
384
385 (defvar calc-buffer)
386
387 (defun calcAlg-enter ()
388   (interactive)
389   (let* ((str (minibuffer-contents))
390          (exp (and (> (length str) 0)
391                    (save-excursion
392                      (set-buffer calc-buffer)
393                      (math-read-exprs str)))))
394     (if (eq (car-safe exp) 'error)
395         (progn
396           (goto-char (minibuffer-prompt-end))
397           (forward-char (nth 1 exp))
398           (beep)
399           (calc-temp-minibuffer-message
400            (concat " [" (or (nth 2 exp) "Error") "]"))
401           (calc-clear-unread-commands))
402       (setq calc-alg-exp (if (calc-minibuffer-contains "\\` *\\[ *\\'")
403                         '((incomplete vec))
404                       exp))
405       (exit-minibuffer))))
406
407 (defun calcAlg-blink-matching-open ()
408   (let ((rightpt (point))
409         (leftpt nil)
410         (rightchar (preceding-char))
411         leftchar
412         rightsyntax
413         leftsyntax)
414     (save-excursion
415       (condition-case ()
416           (setq leftpt (scan-sexps rightpt -1)
417                 leftchar (char-after leftpt))
418         (error nil)))
419     (if (and leftpt
420              (or (and (= rightchar ?\))
421                       (= leftchar ?\[))
422                  (and (= rightchar ?\])
423                       (= leftchar ?\()))
424              (save-excursion
425                (goto-char leftpt)
426                (looking-at ".+\\(\\.\\.\\|\\\\dots\\|\\\\ldots\\)")))
427         (let ((leftsaved (aref (syntax-table) leftchar))
428               (rightsaved (aref (syntax-table) rightchar)))
429           (unwind-protect
430               (progn
431                 (cond ((= leftchar ?\[)
432                        (aset (syntax-table) leftchar (cons 4 ?\)))
433                        (aset (syntax-table) rightchar (cons 5 ?\[)))
434                       (t
435                        (aset (syntax-table) leftchar (cons 4 ?\]))
436                        (aset (syntax-table) rightchar (cons 5 ?\())))
437                 (blink-matching-open))
438             (aset (syntax-table) leftchar leftsaved)
439             (aset (syntax-table) rightchar rightsaved)))
440       (blink-matching-open))))
441
442 (defun calc-alg-digit-entry ()
443   (calc-alg-entry
444    (cond ((eq last-command-char ?e)
445           (if (> calc-number-radix 14) (format "%d.^" calc-number-radix) "1e"))
446          ((eq last-command-char ?#) (format "%d#" calc-number-radix))
447          ((eq last-command-char ?_) "-")
448          ((eq last-command-char ?@) "0@ ")
449          (t (char-to-string last-command-char)))))
450
451 ;; The variable calc-digit-value is initially declared in calc.el,
452 ;; but can be set by calcDigit-algebraic and calcDigit-edit.
453 (defvar calc-digit-value)
454
455 (defun calcDigit-algebraic ()
456   (interactive)
457   (if (calc-minibuffer-contains ".*[@oh] *[^'m ]+[^'m]*\\'")
458       (calcDigit-key)
459     (setq calc-digit-value (minibuffer-contents))
460     (exit-minibuffer)))
461
462 (defun calcDigit-edit ()
463   (interactive)
464   (calc-unread-command)
465   (setq calc-digit-value (minibuffer-contents))
466   (exit-minibuffer))
467
468
469 ;;; Algebraic expression parsing.   [Public]
470
471 (defvar math-read-replacement-list
472   '(;; Misc symbols
473     ("±" "+/-")  ; plus or minus
474     ("×" "*")    ; multiplication sign
475     ("÷" ":")    ; division sign
476     ("−" "-")    ; subtraction sign
477     ("∕" "/")    ; division sign
478     ("∗" "*")    ; asterisk multiplication
479     ("∞" "inf")  ; infinity symbol
480     ("≀" "<=")
481     ("≥" ">=")
482     ("≩" "<=")
483     ("≧" ">=")
484     ;; fractions
485     ("ÂŒ" "(1:4)") ; 1/4
486     ("Âœ" "(1:2)") ; 1/2
487     ("Ÿ" "(3:4)") ; 3/4
488     ("â
489 “" "(1:3)") ; 1/3
490     ("â
491 ”" "(2:3)") ; 2/3
492     ("â
493 •" "(1:5)") ; 1/5
494     ("â
495 –" "(2:5)") ; 2/5
496     ("â
497 —" "(3:5)") ; 3/5
498     ("â
499 ˜" "(4:5)") ; 4/5
500     ("â
501 ™" "(1:6)") ; 1/6
502     ("â
503 š" "(5:6)") ; 5/6
504     ("â
505 ›" "(1:8)") ; 1/8
506     ("â
507 œ" "(3:8)") ; 3/8
508     ("â
509 " "(5:8)") ; 5/8
510     ("â
511 ž" "(7:8)") ; 7/8
512     ("â
513 Ÿ" "1:")    ; 1/...
514     ;; superscripts
515     ("⁰" "0")  ; 0
516     ("¹" "1")  ; 1
517     ("²" "2")  ; 2
518     ("³" "3")  ; 3
519     ("⁎" "4")  ; 4
520     ("⁵" "5")  ; 5
521     ("⁶" "6")  ; 6
522     ("⁷" "7")  ; 7
523     ("⁞" "8")  ; 8
524     ("⁹" "9")  ; 9
525     ("⁺" "+")  ; +
526     ("⁻" "-")  ; -
527     ("⁜" "(")  ; (
528     (" " ")")  ; )
529     ("ⁿ" "n")  ; n
530     ("ⁱ" "i")  ; i
531     ;; subscripts
532     ("₀"  "0")  ; 0
533     ("₁"  "1")  ; 1
534     ("₂"  "2")  ; 2
535     ("₃"  "3")  ; 3
536     ("₄"  "4")  ; 4
537     ("â‚
538 "  "5")  ; 5
539     ("₆"  "6")  ; 6
540     ("₇"  "7")  ; 7
541     ("₈"  "8")  ; 8
542     ("₉"  "9")  ; 9
543     ("₊"  "+")  ; +
544     ("₋"  "-")  ; -
545     ("₍"  "(")  ; (
546     ("₎"  ")"))  ; )
547   "A list whose elements (old new) indicate replacements to make
548 in Calc algebraic input.")
549
550 (defvar math-read-superscripts
551   "⁰¹²³⁎⁵⁶⁷⁞⁹⁺⁻⁜ ⁿⁱ" ; 0123456789+-()ni
552   "A string consisting of the superscripts allowed by Calc.")
553
554 (defvar math-read-subscripts
555   "₀₁₂₃₄â‚
556 ₆₇₈₉₊₋₍₎" ; 0123456789+-()
557   "A string consisting of the subscripts allowed by Calc.")
558
559 (defun math-read-preprocess-string (str)
560   "Replace some substrings of STR by Calc equivalents."
561   (setq str
562         (replace-regexp-in-string (concat "[" math-read-superscripts "]+")
563                                   "^(\\&)" str))
564   (setq str
565         (replace-regexp-in-string (concat "[" math-read-subscripts "]+")
566                                   "_(\\&)" str))
567   (let ((rep-list math-read-replacement-list))
568     (while rep-list
569       (setq str
570             (replace-regexp-in-string (nth 0 (car rep-list))
571                                       (nth 1 (car rep-list)) str))
572       (setq rep-list (cdr rep-list))))
573   str)
574
575 ;; The next few variables are local to math-read-exprs (and math-read-expr
576 ;; in calc-ext.el), but are set in functions they call.
577
578 (defvar math-exp-pos)
579 (defvar math-exp-str)
580 (defvar math-exp-old-pos)
581 (defvar math-exp-token)
582 (defvar math-exp-keep-spaces)
583 (defvar math-expr-data)
584
585 (defun math-read-exprs (math-exp-str)
586   (let ((math-exp-pos 0)
587         (math-exp-old-pos 0)
588         (math-exp-keep-spaces nil)
589         math-exp-token math-expr-data)
590     (setq math-exp-str (math-read-preprocess-string math-exp-str))
591     (if calc-language-input-filter
592         (setq math-exp-str (funcall calc-language-input-filter math-exp-str)))
593     (while (setq math-exp-token (string-match "\\.\\.\\([^.]\\|.[^.]\\)" math-exp-str))
594       (setq math-exp-str (concat (substring math-exp-str 0 math-exp-token) "\\dots"
595                             (substring math-exp-str (+ math-exp-token 2)))))
596     (math-build-parse-table)
597     (math-read-token)
598     (let ((val (catch 'syntax (math-read-expr-list))))
599       (if (stringp val)
600           (list 'error math-exp-old-pos val)
601         (if (equal math-exp-token 'end)
602             val
603           (list 'error math-exp-old-pos "Syntax error"))))))
604
605 (defun math-read-expr-list ()
606   (let* ((math-exp-keep-spaces nil)
607          (val (list (math-read-expr-level 0)))
608          (last val))
609     (while (equal math-expr-data ",")
610       (math-read-token)
611       (let ((rest (list (math-read-expr-level 0))))
612         (setcdr last rest)
613         (setq last rest)))
614     val))
615
616 (defvar calc-user-parse-table nil)
617 (defvar calc-last-main-parse-table nil)
618 (defvar calc-last-lang-parse-table nil)
619 (defvar calc-user-tokens nil)
620 (defvar calc-user-token-chars nil)
621
622 (defvar math-toks nil
623   "Tokens to pass between math-build-parse-table and math-find-user-tokens.")
624
625 (defun math-build-parse-table ()
626   (let ((mtab (cdr (assq nil calc-user-parse-tables)))
627         (ltab (cdr (assq calc-language calc-user-parse-tables))))
628     (or (and (eq mtab calc-last-main-parse-table)
629              (eq ltab calc-last-lang-parse-table))
630         (let ((p (append mtab ltab))
631               (math-toks nil))
632           (setq calc-user-parse-table p)
633           (setq calc-user-token-chars nil)
634           (while p
635             (math-find-user-tokens (car (car p)))
636             (setq p (cdr p)))
637           (setq calc-user-tokens (mapconcat 'identity
638                                             (sort (mapcar 'car math-toks)
639                                                   (function (lambda (x y)
640                                                               (> (length x)
641                                                                  (length y)))))
642                                             "\\|")
643                 calc-last-main-parse-table mtab
644                 calc-last-lang-parse-table ltab)))))
645
646 (defun math-find-user-tokens (p)
647   (while p
648     (cond ((and (stringp (car p))
649                 (or (> (length (car p)) 1) (equal (car p) "$")
650                     (equal (car p) "\""))
651                 (string-match "[^a-zA-Z0-9]" (car p)))
652            (let ((s (regexp-quote (car p))))
653              (if (string-match "\\`[a-zA-Z0-9]" s)
654                  (setq s (concat "\\<" s)))
655              (if (string-match "[a-zA-Z0-9]\\'" s)
656                  (setq s (concat s "\\>")))
657              (or (assoc s math-toks)
658                  (progn
659                    (setq math-toks (cons (list s) math-toks))
660                    (or (memq (aref (car p) 0) calc-user-token-chars)
661                        (setq calc-user-token-chars
662                              (cons (aref (car p) 0)
663                                    calc-user-token-chars)))))))
664           ((consp (car p))
665            (math-find-user-tokens (nth 1 (car p)))
666            (or (eq (car (car p)) '\?)
667                (math-find-user-tokens (nth 2 (car p))))))
668     (setq p (cdr p))))
669
670 (defun math-read-token ()
671   (if (>= math-exp-pos (length math-exp-str))
672       (setq math-exp-old-pos math-exp-pos
673             math-exp-token 'end
674             math-expr-data "\000")
675     (let ((ch (aref math-exp-str math-exp-pos)))
676       (setq math-exp-old-pos math-exp-pos)
677       (cond ((memq ch '(32 10 9))
678              (setq math-exp-pos (1+ math-exp-pos))
679              (if math-exp-keep-spaces
680                  (setq math-exp-token 'space
681                        math-expr-data " ")
682                (math-read-token)))
683             ((and (memq ch calc-user-token-chars)
684                   (let ((case-fold-search nil))
685                     (eq (string-match calc-user-tokens math-exp-str math-exp-pos)
686                         math-exp-pos)))
687              (setq math-exp-token 'punc
688                    math-expr-data (math-match-substring math-exp-str 0)
689                    math-exp-pos (match-end 0)))
690             ((or (and (>= ch ?a) (<= ch ?z))
691                  (and (>= ch ?A) (<= ch ?Z)))
692              (string-match (if (memq calc-language '(c fortran pascal maple))
693                                "[a-zA-Z0-9_#]*"
694                              "[a-zA-Z0-9'#]*")
695                            math-exp-str math-exp-pos)
696              (setq math-exp-token 'symbol
697                    math-exp-pos (match-end 0)
698                    math-expr-data (math-restore-dashes
699                              (math-match-substring math-exp-str 0)))
700              (if (eq calc-language 'eqn)
701                  (let ((code (assoc math-expr-data math-eqn-ignore-words)))
702                    (cond ((null code))
703                          ((null (cdr code))
704                           (math-read-token))
705                          ((consp (nth 1 code))
706                           (math-read-token)
707                           (if (assoc math-expr-data (cdr code))
708                               (setq math-expr-data (format "%s %s"
709                                                      (car code) math-expr-data))))
710                          ((eq (nth 1 code) 'punc)
711                           (setq math-exp-token 'punc
712                                 math-expr-data (nth 2 code)))
713                          (t
714                           (math-read-token)
715                           (math-read-token))))))
716             ((or (and (>= ch ?0) (<= ch ?9))
717                  (and (eq ch '?\.)
718                       (eq (string-match "\\.[0-9]" math-exp-str math-exp-pos)
719                           math-exp-pos))
720                  (and (eq ch '?_)
721                       (eq (string-match "_\\.?[0-9]" math-exp-str math-exp-pos)
722                           math-exp-pos)
723                       (or (eq math-exp-pos 0)
724                           (and (memq calc-language '(nil flat big unform
725                                                          tex latex eqn))
726                                (eq (string-match "[^])}\"a-zA-Z0-9'$]_"
727                                                  math-exp-str (1- math-exp-pos))
728                                    (1- math-exp-pos))))))
729              (or (and (eq calc-language 'c)
730                       (string-match "0[xX][0-9a-fA-F]+" math-exp-str math-exp-pos))
731                  (string-match "_?\\([0-9]+.?0*@ *\\)?\\([0-9]+.?0*' *\\)?\\(0*\\([2-9]\\|1[0-4]\\)\\(#\\|\\^\\^\\)[0-9a-dA-D.]+[eE][-+_]?[0-9]+\\|0*\\([2-9]\\|[0-2][0-9]\\|3[0-6]\\)\\(#\\|\\^\\^\\)[0-9a-zA-Z:.]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\\([eE][-+_]?[0-9]+\\)?\"?\\)?"
732                                math-exp-str math-exp-pos))
733              (setq math-exp-token 'number
734                    math-expr-data (math-match-substring math-exp-str 0)
735                    math-exp-pos (match-end 0)))
736             ((eq ch ?\$)
737              (if (and (eq calc-language 'pascal)
738                       (eq (string-match
739                            "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Z]\\)"
740                            math-exp-str math-exp-pos)
741                           math-exp-pos))
742                  (setq math-exp-token 'number
743                        math-expr-data (math-match-substring math-exp-str 1)
744                        math-exp-pos (match-end 1))
745                (if (eq (string-match "\\$\\([1-9][0-9]*\\)" math-exp-str math-exp-pos)
746                        math-exp-pos)
747                    (setq math-expr-data (- (string-to-number (math-match-substring
748                                                      math-exp-str 1))))
749                  (string-match "\\$+" math-exp-str math-exp-pos)
750                  (setq math-expr-data (- (match-end 0) (matc