Initial Commit
[packages] / xemacs-packages / calc / calc-aent.el
1 ;; Calculator for GNU Emacs, part I [calc-aent.el]
2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
3 ;; Written by Dave Gillespie, daveg@synaptics.com.
4
5 ;; This file is part of GNU Emacs.
6
7 ;; GNU Emacs is distributed in the hope that it will be useful,
8 ;; but WITHOUT ANY WARRANTY.  No author or distributor
9 ;; accepts responsibility to anyone for the consequences of using it
10 ;; or for whether it serves any particular purpose or works at all,
11 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
12 ;; License for full details.
13
14 ;; Everyone is granted permission to copy, modify and redistribute
15 ;; GNU Emacs, but only under the conditions described in the
16 ;; GNU Emacs General Public License.   A copy of this license is
17 ;; supposed to have been given to you along with GNU Emacs so you
18 ;; can know your rights and responsibilities.  It should be in a
19 ;; file named COPYING.  Among other things, the copyright notice
20 ;; and this notice must be preserved on all copies.
21
22
23
24 ;; This file is autoloaded from calc.el.
25 (require 'calc)
26
27 (require 'calc-macs)
28
29 (defun calc-Need-calc-aent () nil)
30
31
32 (defun calc-do-quick-calc ()
33   (calc-check-defines)
34   (if (eq major-mode 'calc-mode)
35       (calc-algebraic-entry t)
36     (let (buf shortbuf)
37       (save-excursion
38         (calc-create-buffer)
39         (let* ((calc-command-flags nil)
40                (calc-dollar-values calc-quick-prev-results)
41                (calc-dollar-used 0)
42                (enable-recursive-minibuffers t)
43                (calc-language (if (memq calc-language '(nil big))
44                                   'flat calc-language))
45                (entry (calc-do-alg-entry "" "Quick calc: " t))
46                (alg-exp (mapcar (function
47                                  (lambda (x)
48                                    (if (and (not calc-extensions-loaded)
49                                             calc-previous-alg-entry
50                                             (string-match
51                                              "\\`[-0-9._+*/^() ]+\\'"
52                                              calc-previous-alg-entry))
53                                        (calc-normalize x)
54                                      (calc-extensions)
55                                      (math-evaluate-expr x))))
56                                 entry)))
57           (if (and (= (length alg-exp) 1)
58                    (eq (car-safe (car alg-exp)) 'calcFunc-assign)
59                    (= (length (car alg-exp)) 3)
60                    (eq (car-safe (nth 1 (car alg-exp))) 'var))
61               (progn
62                 (calc-extensions)
63                 (set (nth 2 (nth 1 (car alg-exp))) (nth 2 (car alg-exp)))
64                 (calc-refresh-evaltos (nth 2 (nth 1 (car alg-exp))))
65                 (setq alg-exp (list (nth 2 (car alg-exp))))))
66           (setq calc-quick-prev-results alg-exp
67                 buf (mapconcat (function (lambda (x)
68                                            (math-format-value x 1000)))
69                                alg-exp
70                                " ")
71                 shortbuf buf)
72           (if (and (= (length alg-exp) 1)
73                    (memq (car-safe (car alg-exp)) '(nil bigpos bigneg))
74                    (< (length buf) 20)
75                    (= calc-number-radix 10))
76               (setq buf (concat buf "  ("
77                                 (let ((calc-number-radix 16))
78                                   (math-format-value (car alg-exp) 1000))
79                                 ", "
80                                 (let ((calc-number-radix 8))
81                                   (math-format-value (car alg-exp) 1000))
82                                 (if (and (integerp (car alg-exp))
83                                          (> (car alg-exp) 0)
84                                          (< (car alg-exp) 127))
85                                     (format ", \"%c\"" (car alg-exp))
86                                   "")
87                                 ")")))
88           (if (and (< (length buf) (frame-width)) (= (length entry) 1)
89                    calc-extensions-loaded)
90               (let ((long (concat (math-format-value (car entry) 1000)
91                                   " =>  " buf)))
92                 (if (<= (length long) (- (frame-width) 8))
93                     (setq buf long))))
94           (calc-handle-whys)
95           (message "Result: %s" buf)))
96       (if (eq last-command-char ?\n)
97           (insert shortbuf)
98         (setq kill-ring (cons shortbuf kill-ring))
99         (if (> (length kill-ring) kill-ring-max)
100             (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil))
101         (setq kill-ring-yank-pointer kill-ring))))
102 )
103
104 (defun calc-do-calc-eval (str separator args)
105   (calc-check-defines)
106   (catch 'calc-error
107     (save-excursion
108       (calc-create-buffer)
109       (cond
110        ((and (consp str) (not (symbolp (car str))))
111         (let ((calc-language nil)
112               (math-expr-opers math-standard-opers)
113               (calc-internal-prec 12)
114               (calc-word-size 32)
115               (calc-symbolic-mode nil)
116               (calc-matrix-mode nil)
117               (calc-angle-mode 'deg)
118               (calc-number-radix 10)
119               (calc-leading-zeros nil)
120               (calc-group-digits nil)
121               (calc-point-char ".")
122               (calc-frac-format '(":" nil))
123               (calc-prefer-frac nil)
124               (calc-hms-format "%s@ %s' %s\"")
125               (calc-date-format '((H ":" mm C SS pp " ")
126                                   Www " " Mmm " " D ", " YYYY))
127               (calc-float-format '(float 0))
128               (calc-full-float-format '(float 0))
129               (calc-complex-format nil)
130               (calc-matrix-just nil)
131               (calc-full-vectors t)
132               (calc-break-vectors nil)
133               (calc-vector-commas ",")
134               (calc-vector-brackets "[]")
135               (calc-matrix-brackets '(R O))
136               (calc-complex-mode 'cplx)
137               (calc-infinite-mode nil)
138               (calc-display-strings nil)
139               (calc-simplify-mode nil)
140               (calc-display-working-message 'lots)
141               (strp (cdr str)))
142           (while strp
143             (set (car strp) (nth 1 strp))
144             (setq strp (cdr (cdr strp))))
145           (calc-do-calc-eval (car str) separator args)))
146        ((eq separator 'eval)
147         (eval str))
148        ((eq separator 'macro)
149         (calc-extensions)
150         (let* ((calc-buffer (current-buffer))
151                (calc-window (get-buffer-window calc-buffer))
152                (save-window (selected-window)))
153           (if calc-window
154               (unwind-protect
155                   (progn
156                     (select-window calc-window)
157                     (calc-execute-kbd-macro str nil (car args)))
158                 (and (window-point save-window)
159                      (select-window save-window)))
160             (save-window-excursion
161               (select-window (get-largest-window))
162               (switch-to-buffer calc-buffer)
163               (calc-execute-kbd-macro str nil (car args)))))
164         nil)
165        ((eq separator 'pop)
166         (or (not (integerp str))
167             (= str 0)
168             (calc-pop (min str (calc-stack-size))))
169         (calc-stack-size))
170        ((eq separator 'top)
171         (and (integerp str)
172              (> str 0)
173              (<= str (calc-stack-size))
174              (math-format-value (calc-top-n str (car args)) 1000)))
175        ((eq separator 'rawtop)
176         (and (integerp str)
177              (> str 0)
178              (<= str (calc-stack-size))
179              (calc-top-n str (car args))))
180        (t
181         (let* ((calc-command-flags nil)
182                (calc-next-why nil)
183                (calc-language (if (memq calc-language '(nil big))
184                                   'flat calc-language))
185                (calc-dollar-values (mapcar
186                                     (function
187                                      (lambda (x)
188                                        (if (stringp x)
189                                            (progn
190                                              (setq x (math-read-exprs x))
191                                              (if (eq (car-safe x)
192                                                      'error)
193                                                  (throw 'calc-error
194                                                         (calc-eval-error
195                                                          (cdr x)))
196                                                (car x)))
197                                          x)))
198                                     args))
199                (calc-dollar-used 0)
200                (res (if (stringp str)
201                         (math-read-exprs str)
202                       (list str)))
203                buf)
204           (if (eq (car res) 'error)
205               (calc-eval-error (cdr res))
206             (setq res (mapcar 'calc-normalize res))
207             (and (memq 'clear-message calc-command-flags)
208                  (message ""))
209             (cond ((eq separator 'pred)
210                    (calc-extensions)
211                    (if (= (length res) 1)
212                        (math-is-true (car res))
213                      (calc-eval-error '(0 "Single value expected"))))
214                   ((eq separator 'raw)
215                    (if (= (length res) 1)
216                        (car res)
217                      (calc-eval-error '(0 "Single value expected"))))
218                   ((eq separator 'list)
219                    res)
220                   ((memq separator '(num rawnum))
221                    (if (= (length res) 1)
222                        (if (math-constp (car res))
223                            (if (eq separator 'num)
224                                (math-format-value (car res) 1000)
225                              (car res))
226                          (calc-eval-error
227                           (list 0
228                                 (if calc-next-why
229                                     (calc-explain-why (car calc-next-why))
230                                   "Number expected"))))
231                      (calc-eval-error '(0 "Single value expected"))))
232                   ((eq separator 'push)
233                    (calc-push-list res)
234                    nil)
235                   (t (while res
236                        (setq buf (concat buf
237                                          (and buf (or separator ", "))
238                                          (math-format-value (car res) 1000))
239                              res (cdr res)))
240                      buf))))))))
241 )
242
243 (defun calc-eval-error (msg)
244   (if (and (boundp 'calc-eval-error)
245            calc-eval-error)
246       (if (eq calc-eval-error 'string)
247           (nth 1 msg)
248         (error "%s" (nth 1 msg)))
249     msg)
250 )
251
252
253 ;;;; Reading an expression in algebraic form.
254
255 (defun calc-auto-algebraic-entry (&optional prefix)
256   (interactive "P")
257   (calc-algebraic-entry prefix t)
258 )
259
260 (defun calc-algebraic-entry (&optional prefix auto)
261   (interactive "P")
262   (calc-wrapper
263    (let ((calc-language (if prefix nil calc-language))
264          (math-expr-opers (if prefix math-standard-opers math-expr-opers)))
265      (calc-alg-entry (and auto (char-to-string last-command-char)))))
266 )
267
268 (defun calc-alg-entry (&optional initial prompt)
269   (let* ((sel-mode nil)
270          (calc-dollar-values (mapcar 'calc-get-stack-element
271                                      (nthcdr calc-stack-top calc-stack)))
272          (calc-dollar-used 0)
273          (calc-plain-entry t)
274          (alg-exp (calc-do-alg-entry initial prompt t)))
275     (if (stringp alg-exp)
276         (progn
277           (calc-extensions)
278           (calc-alg-edit alg-exp))
279       (let* ((calc-simplify-mode (if (eq last-command-char ?\C-j)
280                                      'none
281                                    calc-simplify-mode))
282              (nvals (mapcar 'calc-normalize alg-exp)))
283         (while alg-exp
284           (calc-record (if calc-extensions-loaded (car alg-exp) (car nvals))
285                        "alg'")
286           (calc-pop-push-record-list calc-dollar-used
287                                      (and (not (equal (car alg-exp)
288                                                       (car nvals)))
289                                           calc-extensions-loaded
290                                           "")
291                                      (list (car nvals)))
292           (setq alg-exp (cdr alg-exp)
293                 nvals (cdr nvals)
294                 calc-dollar-used 0)))
295       (calc-handle-whys)))
296 )
297
298 (defun calc-do-alg-entry (&optional initial prompt no-normalize)
299   (let* ((calc-buffer (current-buffer))
300          (blink-paren-function 'calcAlg-blink-matching-open)
301          (alg-exp 'error))
302     (if (boundp 'calc-alg-ent-map)
303         ()
304       (setq calc-alg-ent-map (copy-keymap minibuffer-local-map))
305       (define-key calc-alg-ent-map "'" 'calcAlg-previous)
306       (define-key calc-alg-ent-map "`" 'calcAlg-edit)
307       (define-key calc-alg-ent-map "\C-m" 'calcAlg-enter)
308       (define-key calc-alg-ent-map "\C-j" 'calcAlg-enter)
309       (or calc-emacs-type-19
310           (let ((i 33))
311             (setq calc-alg-ent-esc-map (copy-sequence esc-map))
312             (while (< i 127)
313               (aset calc-alg-ent-esc-map i 'calcAlg-escape)
314               (setq i (1+ i))))))
315     (or calc-emacs-type-19
316         (define-key calc-alg-ent-map "\e" nil))
317     (if (eq calc-algebraic-mode 'total)
318         (define-key calc-alg-ent-map "\e" calc-alg-ent-esc-map)
319       (define-key calc-alg-ent-map "\ep" 'calcAlg-plus-minus)
320       (define-key calc-alg-ent-map "\em" 'calcAlg-mod)
321       (define-key calc-alg-ent-map "\e=" 'calcAlg-equals)
322       (define-key calc-alg-ent-map "\e\r" 'calcAlg-equals)
323       (define-key calc-alg-ent-map "\e%" 'self-insert-command))
324     (setq calc-aborted-prefix nil)
325     (let ((buf (read-from-minibuffer (or prompt "Algebraic: ")
326                                      (or initial "")
327                                      calc-alg-ent-map nil)))
328       (if (eq alg-exp 'error)
329           (if (eq (car-safe (setq alg-exp (math-read-exprs buf))) 'error)
330               (setq alg-exp nil)))
331       (setq calc-aborted-prefix "alg'")
332       (or no-normalize
333           (and alg-exp (setq alg-exp (mapcar 'calc-normalize alg-exp))))
334       alg-exp))
335 )
336
337 (defun calcAlg-plus-minus ()
338   (interactive)
339   (if (calc-minibuffer-contains ".* \\'")
340       (insert "+/- ")
341     (insert " +/- "))
342 )
343
344 (defun calcAlg-mod ()
345   (interactive)
346   (if (not (calc-minibuffer-contains ".* \\'"))
347       (insert " "))
348   (if (calc-minibuffer-contains ".* mod +\\'")
349       (if calc-previous-modulo
350           (insert (math-format-flat-expr calc-previous-modulo 0))
351         (beep))
352     (insert "mod "))
353 )
354
355 (defun calcAlg-previous ()
356   (interactive)
357   (if (calc-minibuffer-contains "\\`\\'")
358       (if calc-previous-alg-entry
359           (insert calc-previous-alg-entry)
360         (beep))
361     (insert "'"))
362 )
363
364 (defun calcAlg-equals ()
365   (interactive)
366   (unwind-protect
367       (calcAlg-enter)
368     (if (consp alg-exp)
369         (progn (setq prefix-arg (length alg-exp))
370                (calc-unread-command ?=))))
371 )
372
373 (defun calcAlg-escape ()
374   (interactive)
375   (calc-unread-command)
376   (save-excursion
377     (calc-select-buffer)
378     (use-local-map calc-mode-map))
379   (calcAlg-enter)
380 )
381
382 (defun calcAlg-edit ()
383   (interactive)
384   (if (or (not calc-plain-entry)
385           (calc-minibuffer-contains
386            "\\`\\([^\"]*\"[^\"]*\"\\)*[^\"]*\"[^\"]*\\'"))
387       (insert "`")
388     (setq alg-exp (buffer-string))
389     (and (> (length alg-exp) 0) (setq calc-previous-alg-entry alg-exp))
390     (exit-minibuffer))
391 )
392 (setq calc-plain-entry nil)
393
394 (defun calcAlg-enter ()
395   (interactive)
396   (let* ((str (buffer-string))
397          (exp (and (> (length str) 0)
398                    (save-excursion
399                      (set-buffer calc-buffer)
400                      (math-read-exprs str)))))
401     (if (eq (car-safe exp) 'error)
402         (progn
403           (goto-char (point-min))
404           (forward-char (nth 1 exp))
405           (beep)
406           (calc-temp-minibuffer-message
407            (concat " [" (or (nth 2 exp) "Error") "]"))
408           (calc-clear-unread-commands))
409       (setq alg-exp (if (calc-minibuffer-contains "\\` *\\[ *\\'")
410                         '((incomplete vec))
411                       exp))
412       (and (> (length str) 0) (setq calc-previous-alg-entry str))
413       (exit-minibuffer)))
414 )
415
416 (defun calcAlg-blink-matching-open ()
417   (let ((oldpos (point))
418         (blinkpos nil))
419     (save-excursion
420       (condition-case ()
421           (setq blinkpos (scan-sexps oldpos -1))
422         (error nil)))
423     (if (and blinkpos
424              (> oldpos (1+ (point-min)))
425              (or (and (= (char-after (1- oldpos)) ?\))
426                       (= (char-after blinkpos) ?\[))
427                  (and (= (char-after (1- oldpos)) ?\])
428                       (= (char-after blinkpos) ?\()))
429              (save-excursion
430                (goto-char blinkpos)
431                (looking-at ".+\\(\\.\\.\\|\\\\dots\\|\\\\ldots\\)")))
432         (let*
433             ((char-num (char-int (char-after blinkpos)))
434               (saved (aref (syntax-table) char-num)))
435           (unwind-protect
436               (progn
437                 (aset (syntax-table) char-num
438                       (+ (logand saved 255)
439                          (lsh (char-int (char-after (1- oldpos))) 8)))
440                 (blink-matching-open))
441             (aset (syntax-table) char-num saved)))
442       (blink-matching-open))))
443
444 (defun calc-alg-digit-entry ()
445   (calc-alg-entry 
446    (cond ((eq last-command-char ?e)
447           (if (> calc-number-radix 14) (format "%d.^" calc-number-radix) "1e"))
448          ((eq last-command-char ?#) (format "%d#" calc-number-radix))
449          ((eq last-command-char ?_) "-")
450          ((eq last-command-char ?@) "0@ ")
451          (t (char-to-string last-command-char))))
452 )
453
454 (defun calcDigit-algebraic ()
455   (interactive)
456   (if (calc-minibuffer-contains ".*[@oh] *[^'m ]+[^'m]*\\'")
457       (calcDigit-key)
458     (setq calc-digit-value (buffer-string))
459     (exit-minibuffer))
460 )
461
462 (defun calcDigit-edit ()
463   (interactive)
464   (calc-unread-command)
465   (setq calc-digit-value (buffer-string))
466   (exit-minibuffer)
467 )
468
469
470 ;;; Algebraic expression parsing.   [Public]
471
472 (defun math-read-exprs (exp-str)
473   (let ((exp-pos 0)
474         (exp-old-pos 0)
475         (exp-keep-spaces nil)
476         exp-token exp-data)
477     (if calc-language-input-filter
478         (setq exp-str (funcall calc-language-input-filter exp-str)))
479     (while (setq exp-token (string-match "\\.\\.\\([^.]\\|.[^.]\\)" exp-str))
480       (setq exp-str (concat (substring exp-str 0 exp-token) "\\dots"
481                             (substring exp-str (+ exp-token 2)))))
482     (math-build-parse-table)
483     (math-read-token)
484     (let ((val (catch 'syntax (math-read-expr-list))))
485       (if (stringp val)
486           (list 'error exp-old-pos val)
487         (if (equal exp-token 'end)
488             val
489           (list 'error exp-old-pos "Syntax error")))))
490 )
491
492 (defun math-read-expr-list ()
493   (let* ((exp-keep-spaces nil)
494          (val (list (math-read-expr-level 0)))
495          (last val))
496     (while (equal exp-data ",")
497       (math-read-token)
498       (let ((rest (list (math-read-expr-level 0))))
499         (setcdr last rest)
500         (setq last rest)))
501     val)
502 )
503
504 (setq calc-user-parse-table nil)
505 (setq calc-last-main-parse-table nil)
506 (setq calc-last-lang-parse-table nil)
507 (setq calc-user-tokens nil)
508 (setq calc-user-token-chars nil)
509
510 (defun math-build-parse-table ()
511   (let ((mtab (cdr (assq nil calc-user-parse-tables)))
512         (ltab (cdr (assq calc-language calc-user-parse-tables))))
513     (or (and (eq mtab calc-last-main-parse-table)
514              (eq ltab calc-last-lang-parse-table))
515         (let ((p (append mtab ltab))
516               (toks nil))
517           (setq calc-user-parse-table p)
518           (setq calc-user-token-chars nil)
519           (while p
520             (math-find-user-tokens (car (car p)))
521             (setq p (cdr p)))
522           (setq calc-user-tokens (mapconcat 'identity
523                                             (sort (mapcar 'car toks)
524                                                   (function (lambda (x y)
525                                                               (> (length x)
526                                                                  (length y)))))
527                                             "\\|")
528                 calc-last-main-parse-table mtab
529                 calc-last-lang-parse-table ltab))))
530 )
531
532 (defun math-find-user-tokens (p)   ; uses "toks"
533   (while p
534     (cond ((and (stringp (car p))
535                 (or (> (length (car p)) 1) (equal (car p) "$")
536                     (equal (car p) "\""))
537                 (string-match "[^a-zA-Z0-9]" (car p)))
538            (let ((s (regexp-quote (car p))))
539              (if (string-match "\\`[a-zA-Z0-9]" s)
540                  (setq s (concat "\\<" s)))
541              (if (string-match "[a-zA-Z0-9]\\'" s)
542                  (setq s (concat s "\\>")))
543              (or (assoc s toks)
544                  (progn
545                    (setq toks (cons (list s) toks))
546                    (or (memq (aref (car p) 0) calc-user-token-chars)
547                        (setq calc-user-token-chars
548                              (cons (aref (car p) 0)
549                                    calc-user-token-chars)))))))
550           ((consp (car p))
551            (math-find-user-tokens (nth 1 (car p)))
552            (or (eq (car (car p)) '\?)
553                (math-find-user-tokens (nth 2 (car p))))))
554     (setq p (cdr p)))
555 )
556
557 (defun math-read-token ()
558   (if (>= exp-pos (length exp-str))
559       (setq exp-old-pos exp-pos
560             exp-token 'end
561             exp-data "\000")
562     (let ((ch (aref exp-str exp-pos)))
563       (setq exp-old-pos exp-pos)
564       (cond ((memq ch '(?  ?\n ?\t))
565              (setq exp-pos (1+ exp-pos))
566              (if exp-keep-spaces
567                  (setq exp-token 'space
568                        exp-data " ")
569                (math-read-token)))
570             ((and (memq ch calc-user-token-chars)
571                   (let ((case-fold-search nil))
572                     (eq (string-match calc-user-tokens exp-str exp-pos)
573                         exp-pos)))
574              (setq exp-token 'punc
575                    exp-data (math-match-substring exp-str 0)
576                    exp-pos (match-end 0)))
577             ((or (and (>= ch ?a) (<= ch ?z))
578                  (and (>= ch ?A) (<= ch ?Z)))
579              (string-match (if (memq calc-language '(c fortran pascal maple))
580                                "[a-zA-Z0-9_#]*"
581                              "[a-zA-Z0-9'#]*")
582                            exp-str exp-pos)
583              (setq exp-token 'symbol
584                    exp-pos (match-end 0)
585                    exp-data (math-restore-dashes
586                              (math-match-substring exp-str 0)))
587              (if (eq calc-language 'eqn)
588                  (let ((code (assoc exp-data math-eqn-ignore-words)))
589                    (cond ((null code))
590                          ((null (cdr code))
591                           (math-read-token))
592                          ((consp (nth 1 code))
593                           (math-read-token)
594                           (if (assoc exp-data (cdr code))
595                               (setq exp-data (format "%s %s"
596                                                      (car code) exp-data))))
597                          ((eq (nth 1 code) 'punc)
598                           (setq exp-token 'punc
599                                 exp-data (nth 2 code)))
600                          (t
601                           (math-read-token)
602                           (math-read-token))))))
603             ((or (and (>= ch ?0) (<= ch ?9))
604                  (and (eq ch '?\.)
605                       (eq (string-match "\\.[0-9]" exp-str exp-pos) exp-pos))
606                  (and (eq ch '?_)
607                       (eq (string-match "_\\.?[0-9]" exp-str exp-pos) exp-pos)
608                       (or (eq exp-pos 0)
609                           (and (memq calc-language '(nil flat big unform
610                                                          tex eqn))
611                                (eq (string-match "[^])}\"a-zA-Z0-9'$]_"
612                                                  exp-str (1- exp-pos))
613                                    (1- exp-pos))))))
614              (or (and (eq calc-language 'c)
615                       (string-match "0[xX][0-9a-fA-F]+" exp-str exp-pos))
616                  (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]+\\)?\"?\\)?" exp-str exp-pos))
617              (setq exp-token 'number
618                    exp-data (math-match-substring exp-str 0)
619                    exp-pos (match-end 0)))
620             ((eq ch ?\$)
621              (if (and (eq calc-language 'pascal)
622                       (eq (string-match
623                            "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Z]\\)"
624                            exp-str exp-pos)
625                           exp-pos))
626                  (setq exp-token 'number
627                        exp-data (math-match-substring exp-str 1)
628                        exp-pos (match-end 1))
629                (if (eq (string-match "\\$\\([1-9][0-9]*\\)" exp-str exp-pos)
630                        exp-pos)
631                    (setq exp-data (- (string-to-int (math-match-substring
632                                                      exp-str 1))))
633                  (string-match "\\$+" exp-str exp-pos)
634                  (setq exp-data (- (match-end 0) (match-beginning 0))))
635                (setq exp-token 'dollar
636                      exp-pos (match-end 0))))
637             ((eq ch ?\#)
638              (if (eq (string-match "#\\([1-9][0-9]*\\)" exp-str exp-pos)
639                      exp-pos)
640                  (setq exp-data (string-to-int
641                                  (math-match-substring exp-str 1))
642                        exp-pos (match-end 0))
643                (setq exp-data 1
644                      exp-pos (1+ exp-pos)))
645              (setq exp-token 'hash))
646             ((eq (string-match "~=\\|<=\\|>=\\|<>\\|/=\\|\\+/-\\|\\\\dots\\|\\\\ldots\\|\\*\\*\\|<<\\|>>\\|==\\|!=\\|&&&\\||||\\|!!!\\|&&\\|||\\|!!\\|:=\\|::\\|=>"
647                                exp-str exp-pos)
648                  exp-pos)
649              (setq exp-token 'punc
650                    exp-data (math-match-substring exp-str 0)
651                    exp-pos (match-end 0)))
652             ((and (eq ch ?\")
653                   (string-match "\\(\"\\([^\"\\]\\|\\\\.\\)*\\)\\(\"\\|\\'\\)" exp-str exp-pos))
654              (if (eq calc-language 'eqn)
655                  (progn
656                    (setq exp-str (copy-sequence exp-str))
657                    (aset exp-str (match-beginning 1) ?\{)
658                    (if (< (match-end 1) (length exp-str))
659                        (aset exp-str (match-end 1) ?\}))
660                    (math-read-token))
661                (setq exp-token 'string
662                      exp-data (math-match-substring exp-str 1)
663                      exp-pos (match-end 0))))
664             ((and (= ch ?\\) (eq calc-language 'tex)
665                   (< exp-pos (1- (length exp-str))))
666              (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" exp-str exp-pos)
667                  (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" exp-str exp-pos))
668              (setq exp-token 'symbol
669                    exp-pos (match-end 0)
670                    exp-data (math-restore-dashes
671                              (math-match-substring exp-str 1)))
672              (let ((code (assoc exp-data math-tex-ignore-words)))
673                (cond ((null code))
674                      ((null (cdr code))
675                       (math-read-token))
676                      ((eq (nth 1 code) 'punc)
677                       (setq exp-token 'punc
678                             exp-data (nth 2 code)))
679                      ((and (eq (nth 1 code) 'mat)
680                            (string-match " *{" exp-str exp-pos))
681                       (setq exp-pos (match-end 0)
682                             exp-token 'punc
683                             exp-data "[")
684                       (let ((right (string-match "}" exp-str exp-pos)))
685                         (and right
686                              (setq exp-str (copy-sequence exp-str))
687                              (aset exp-str right ?\])))))))
688             ((and (= ch ?\.) (eq calc-language 'fortran)
689                   (eq (string-match "\\.[a-zA-Z][a-zA-Z][a-zA-Z]?\\."
690                                     exp-str exp-pos) exp-pos))
691              (setq exp-token 'punc
692                    exp-data (upcase (math-match-substring exp-str 0))
693                    exp-pos (match-end 0)))
694             ((and (eq calc-language 'math)
695                   (eq (string-match "\\[\\[\\|->\\|:>" exp-str exp-pos)
696                       exp-pos))
697              (setq exp-token 'punc
698                    exp-data (math-match-substring exp-str 0)
699                    exp-pos (match-end 0)))
700             ((and (eq calc-language 'eqn)
701                   (eq (string-match "->\\|<-\\|+-\\|\\\\dots\\|~\\|\\^"
702                                     exp-str exp-pos)
703                       exp-pos))
704              (setq exp-token 'punc
705                    exp-data (math-match-substring exp-str 0)
706                    exp-pos (match-end 0))
707              (and (eq (string-match "\\\\dots\\." exp-str exp-pos) exp-pos)
708                   (setq exp-pos (match-end 0)))
709              (if (memq (aref exp-data 0) '(?~ ?^))
710                  (math-read-token)))
711             ((eq (string-match "%%.*$" exp-str exp-pos) exp-pos)
712              (setq exp-pos (match-end 0))
713              (math-read-token))
714             (t
715              (if (and (eq ch ?\{) (memq calc-language '(tex eqn)))
716                  (setq ch ?\())
717              (if (and (eq ch ?\}) (memq calc-language '(tex eqn)))
718                  (setq ch ?\)))
719              (if (and (eq ch ?\&) (eq calc-language 'tex))
720                  (setq ch ?\,))
721              (setq exp-token 'punc
722                    exp-data (char-to-string ch)
723                    exp-pos (1+ exp-pos))))))
724 )
725
726
727 (defun math-read-expr-level (exp-prec &optional exp-term)
728   (let* ((x (math-read-factor)) (first t) op op2)
729     (while (and (or (and calc-user-parse-table
730                          (setq op (calc-check-user-syntax x exp-prec))
731                          (setq x op
732                                op '("2x" ident 999999 -1)))
733                     (and (setq op (assoc exp-data math-expr-opers))
734                          (/= (nth 2 op) -1)
735                          (or (and (setq op2 (assoc
736                                              exp-data
737                                              (cdr (memq op math-expr-opers))))
738                                   (eq (= (nth 3 op) -1)
739                                       (/= (nth 3 op2) -1))
740                                   (eq (= (nth 3 op2) -1)
741                                       (not (math-factor-after)))
742                                   (setq op op2))
743                              t))
744                     (and (or (eq (nth 2 op) -1)
745                              (memq exp-token '(symbol number dollar hash))
746                              (equal exp-data "(")
747                              (and (equal exp-data "[")
748                                   (not (eq calc-language 'math))
749                                   (not (and exp-keep-spaces
750                                             (eq (car-safe x) 'vec)))))
751                          (or (not (setq op (assoc exp-data math-expr-opers)))
752                              (/= (nth 2 op) -1))
753                          (or (not calc-user-parse-table)
754                              (not (eq exp-token 'symbol))
755                              (let ((p calc-user-parse-table))
756                                (while (and p
757                                            (or (not (integerp
758                                                      (car (car (car p)))))
759                                                (not (equal
760                                                      (nth 1 (car (car p)))
761                                                      exp-data))))
762                                  (setq p (cdr p)))
763                                (not p)))
764                          (setq op (assoc "2x" math-expr-opers))))
765                 (not (and exp-term (equal exp-data exp-term)))
766                 (>= (nth 2 op) exp-prec))
767       (if (not (equal (car op) "2x"))
768           (math-read-token))
769       (and (memq (nth 1 op) '(sdev mod))
770            (calc-extensions))
771       (setq x (cond ((consp (nth 1 op))
772                      (funcall (car (nth 1 op)) x op))
773                     ((eq (nth 3 op) -1)
774                      (if (eq (nth 1 op) 'ident)
775                          x
776                        (if (eq (nth 1 op) 'closing)
777                            (if (eq (nth 2 op) exp-prec)
778                                (progn
779                                  (setq exp-prec 1000)
780                                  x)
781                              (throw 'syntax "Mismatched delimiters"))
782                          (list (nth 1 op) x))))
783                     ((and (not first)
784                           (memq (nth 1 op) math-alg-inequalities)
785                           (memq (car-safe x) math-alg-inequalities))
786                      (calc-extensions)
787                      (math-composite-inequalities x op))
788                     (t (list (nth 1 op)
789                              x
790                              (math-read-expr-level (nth 3 op) exp-term))))
791             first nil))
792     x)
793 )
794
795 (defun calc-check-user-syntax (&optional x prec)
796   (let ((p calc-user-parse-table)
797         (matches nil)
798         match rule)
799     (while (and p
800                 (or (not (progn
801                            (setq rule (car (car p)))
802                            (if x
803                                (and (integerp (car rule))
804                                     (>= (car rule) prec)
805                                     (equal exp-data
806                                            (car (setq rule (cdr rule)))))
807                              (equal exp-data (car rule)))))
808                     (let ((save-exp-pos exp-pos)
809                           (save-exp-old-pos exp-old-pos)
810                           (save-exp-token exp-token)
811                           (save-exp-data exp-data))
812                       (or (not (listp
813                                 (setq matches (calc-match-user-syntax rule))))
814                           (let ((args (progn
815                                         (calc-extensions)
816                                         calc-arg-values))
817                                 (conds nil)
818                                 temp)
819                             (if x
820                                 (setq matches (cons x matches)))
821                             (setq match (cdr (car p)))
822                             (while (and (eq (car-safe match)
823                                             'calcFunc-condition)
824                                         (= (length match) 3))
825                               (setq conds (append (math-flatten-lands
826                                                    (nth 2 match))
827                                                   conds)
828                                     match (nth 1 match)))
829                             (while (and conds match)
830                               (calc-extensions)
831                               (cond ((eq (car-safe (car conds))
832                                          'calcFunc-let)
833                                      (setq temp (car conds))
834                                      (or (= (length temp) 3)
835                                          (and (= (length temp) 2)
836                                               (eq (car-safe (nth 1 temp))
837                                                   'calcFunc-assign)
838                                               (= (length (nth 1 temp)) 3)
839                                               (setq temp (nth 1 temp)))
840                                          (setq match nil))
841                                      (setq matches (cons
842                                                     (math-normalize
843                                                      (math-multi-subst
844                                                       (nth 2 temp)
845                                                       args matches))
846                                                     matches)
847                                            args (cons (nth 1 temp)
848                                                       args)))
849                                     ((and (eq (car-safe (car conds))
850                                               'calcFunc-matches)
851                                           (= (length (car conds)) 3))
852                                      (setq temp (calcFunc-vmatches
853                                                  (math-multi-subst
854                                                   (nth 1 (car conds))
855                                                   args matches)
856                                                  (nth 2 (car conds))))
857                                      (if (eq temp 0)
858                                          (setq match nil)
859                                        (while (setq temp (cdr temp))
860                                          (setq matches (cons (nth 2 (car temp))
861                                                              matches)
862                                                args (cons (nth 1 (car temp))
863                                                           args)))))
864                                     (t
865                                      (or (math-is-true (math-simplify
866                                                         (math-multi-subst
867                                                          (car conds)
868                                                          args matches)))
869                                          (setq match nil))))
870                               (setq conds (cdr conds)))
871                             (if match
872                                 (not (setq match (math-multi-subst
873                                                   match args matches)))
874                               (setq exp-old-pos save-exp-old-pos
875                                     exp-token save-exp-token
876                                     exp-data save-exp-data
877                                     exp-pos save-exp-pos)))))))
878       (setq p (cdr p)))
879     (and p match))
880 )
881
882 (defun calc-match-user-syntax (p &optional term)
883   (let ((matches nil)
884         (save-exp-pos exp-pos)
885         (save-exp-old-pos exp-old-pos)
886         (save-exp-token exp-token)
887         (save-exp-data exp-data))
888     (while (and p
889                 (cond ((stringp (car p))
890                        (and (equal exp-data (car p))
891                             (progn
892                               (math-read-token)
893                               t)))
894                       ((integerp (car p))
895                        (and (setq m (catch 'syntax
896                                       (math-read-expr-level
897                                        (car p)
898                                        (if (cdr p)
899                                            (if (consp (nth 1 p))
900                                                (car (nth 1 (nth 1 p)))
901                                              (nth 1 p))
902                                          term))))
903                             (not (stringp m))
904                             (setq matches (nconc matches (list m)))))
905                       ((eq (car (car p)) '\?)
906                        (setq m (calc-match-user-syntax (nth 1 (car p))))
907                        (or (nth 2 (car p))
908                            (setq matches
909                                  (nconc matches
910                                         (list
911                                          (cons 'vec (and (listp m) m))))))
912                        (or (listp m) (not (nth 2 (car p)))
913                            (not (eq (aref (car (nth 2 (car p))) 0) ?\$))
914                            (eq exp-token 'end)))
915                       (t
916                        (setq m (calc-match-user-syntax (nth 1 (car p))
917                                                        (car (nth 2 (car p)))))
918                        (if (listp m)
919                            (let ((vec (cons 'vec m))
920                                  opos mm)
921                              (while (and (listp
922                                           (setq opos exp-pos
923                                                 mm (calc-match-user-syntax
924                                                     (or (nth 2 (car p))
925                                                         (nth 1 (car p)))
926                                                     (car (nth 2 (car p))))))
927                                          (> exp-pos opos))
928                                (setq vec (nconc vec mm)))
929                              (setq matches (nconc matches (list vec))))
930                          (and (eq (car (car p)) '*)
931                               (setq matches (nconc matches (list '(vec)))))))))
932       (setq p (cdr p)))
933     (if p
934         (setq exp-pos save-exp-pos
935               exp-old-pos save-exp-old-pos
936               exp-token save-exp-token
937               exp-data save-exp-data
938               matches "Failed"))
939     matches)
940 )
941
942 (defconst math-alg-inequalities
943   '(calcFunc-lt calcFunc-gt calcFunc-leq calcFunc-geq
944                 calcFunc-eq calcFunc-neq))
945
946 (defun math-remove-dashes (x)
947   (if (string-match "\\`\\(.*\\)-\\(.*\\)\\'" x)
948       (math-remove-dashes
949        (concat (math-match-substring x 1) "#" (math-match-substring x 2)))
950     x)
951 )
952
953 (defun math-restore-dashes (x)
954   (if (string-match "\\`\\(.*\\)[#_]\\(.*\\)\\'" x)
955       (math-restore-dashes
956        (concat (math-match-substring x 1) "-" (math-match-substring x 2)))
957     x)
958 )
959
960 (defun math-read-if (cond op)
961   (let ((then (math-read-expr-level 0)))
962     (or (equal exp-data ":")
963         (throw 'syntax "Expected ':'"))
964     (math-read-token)
965     (list 'calcFunc-if cond then (math-read-expr-level (nth 3 op))))
966 )
967
968 (defun math-factor-after ()
969   (let ((exp-pos exp-pos)
970         exp-old-pos exp-token exp-data)
971     (math-read-token)
972     (or (memq exp-token '(number symbol dollar hash string))
973         (and (assoc exp-data '(("-") ("+") ("!") ("|") ("/")))
974              (assoc (concat "u" exp-data) math-expr-opers))
975         (eq (nth 2 (assoc exp-data math-expr-opers)) -1)
976         (assoc exp-data '(("(") ("[") ("{")))))
977 )
978
979 (defun math-read-factor ()
980   (let (op)
981     (cond ((eq exp-token 'number)
982            (let ((num (math-read-number exp-data)))
983              (if (not num)
984                  (progn
985                    (setq exp-old-pos exp-pos)
986                    (throw 'syntax "Bad format")))
987              (math-read-token)
988              (if (and math-read-expr-quotes
989                       (consp num))
990                  (list 'quote num)
991                num)))
992           ((and calc-user-parse-table
993                 (setq op (calc-check-user-syntax)))
994            op)
995           ((or (equal exp-data "-")
996                (equal exp-data "+")
997                (equal exp-data "!")
998                (equal exp-data "|")
999                (equal exp-data "/"))
1000            (setq exp-data (concat "u" exp-data))
1001            (math-read-factor))
1002           ((and (setq op (assoc exp-data math-expr-opers))
1003                 (eq (nth 2 op) -1))
1004            (if (consp (nth 1 op))
1005                (funcall (car (nth 1 op)) op)
1006              (math-read-token)
1007              (let ((val (math-read-expr-level (nth 3 op))))
1008                (cond ((eq (nth 1 op) 'ident)
1009                       val)
1010                      ((and (Math-numberp val)
1011                            (equal (car op) "u-"))
1012                       (math-neg val))
1013                      (t (list (nth 1 op) val))))))
1014           ((eq exp-token 'symbol)
1015            (let ((sym (intern exp-data)))
1016              (math-read-token)
1017              (if (equal exp-data calc-function-open)
1018                  (let ((f (assq sym math-expr-function-mapping)))
1019                    (math-read-token)
1020                    (if (consp (cdr f))
1021                        (funcall (car (cdr f)) f sym)
1022                      (let ((args (if (or (equal exp-data calc-function-close)
1023                                          (eq exp-token 'end))
1024                                      nil
1025                                    (math-read-expr-list))))
1026                        (if (not (or (equal exp-data calc-function-close)
1027                                     (eq exp-token 'end)))
1028                            (throw 'syntax "Expected `)'"))
1029                        (math-read-token)
1030                        (if (and (eq calc-language 'fortran) args
1031                                 (calc-extensions)
1032                                 (let ((calc-matrix-mode 'scalar))
1033                                   (math-known-matrixp
1034                                    (list 'var sym
1035                                          (intern
1036                                           (concat "var-"
1037                                                   (symbol-name sym)))))))
1038                            (math-parse-fortran-subscr sym args)
1039                          (if f
1040                              (setq sym (cdr f))
1041                            (and (= (aref (symbol-name sym) 0) ?\\)
1042                                 (< (prefix-numeric-value calc-language-option)
1043                                    0)
1044                                 (setq sym (intern (substring (symbol-name sym)
1045                                                              1))))
1046                            (or (string-match "-" (symbol-name sym))
1047                                (setq sym (intern
1048                                           (concat "calcFunc-"
1049                                                   (symbol-name sym))))))
1050                          (cons sym args)))))
1051                (if math-read-expr-quotes
1052                    sym
1053                  (let ((val (list 'var
1054                                   (intern (math-remove-dashes
1055                                            (symbol-name sym)))
1056                                   (if (string-match "-" (symbol-name sym))
1057                                       sym
1058                                     (intern (concat "var-"
1059                                                     (symbol-name sym)))))))
1060                    (let ((v (assq (nth 1 val) math-expr-variable-mapping)))
1061                      (and v (setq val (if (consp (cdr v))
1062                                           (funcall (car (cdr v)) v val)
1063                                         (list 'var
1064                                               (intern
1065                                                (substring (symbol-name (cdr v))
1066                                                           4))
1067                                               (cdr v))))))
1068                    (while (and (memq calc-language '(c pascal maple))
1069                                (equal exp-data "["))
1070                      (math-read-token)
1071                      (setq val (append (list 'calcFunc-subscr val)
1072                                        (math-read-expr-list)))
1073                      (if (equal exp-data "]")
1074                          (math-read-token)
1075                        (throw 'syntax "Expected ']'")))
1076                    val)))))
1077           ((eq exp-token 'dollar)
1078            (let ((abs (if (> exp-data 0) exp-data (- exp-data))))
1079              (if (>= (length calc-dollar-values) abs)
1080                  (let ((num exp-data))
1081                    (math-read-token)
1082                    (setq calc-dollar-used (max calc-dollar-used num))
1083                    (math-check-complete (nth (1- abs) calc-dollar-values)))
1084                (throw 'syntax (if calc-dollar-values
1085                                   "Too many $'s"
1086                                 "$'s not allowed in this context")))))
1087           ((eq exp-token 'hash)
1088            (or calc-hashes-used
1089                (throw 'syntax "#'s not allowed in this context"))
1090            (calc-extensions)
1091            (if (<= exp-data (length calc-arg-values))
1092                (let ((num exp-data))
1093                  (math-read-token)
1094                  (setq calc-hashes-used (max calc-hashes-used num))
1095                  (nth (1- num) calc-arg-values))
1096              (throw 'syntax "Too many # arguments")))
1097           ((equal exp-data "(")
1098            (let* ((exp (let ((exp-keep-spaces nil))
1099                          (math-read-token)
1100                          (if (or (equal exp-data "\\dots")
1101                                  (equal exp-data "\\ldots"))
1102                              '(neg (var inf var-inf))
1103                            (math-read-expr-level 0)))))
1104              (let ((exp-keep-spaces nil))
1105                (cond
1106                 ((equal exp-data ",")
1107                  (progn
1108                    (math-read-token)
1109                    (let ((exp2 (math-read-expr-level 0)))
1110                      (setq exp
1111                            (if (and exp2 (Math-realp exp) (Math-realp exp2))
1112                                (math-normalize (list 'cplx exp exp2))
1113                              (list '+ exp (list '* exp2 '(var i var-i))))))))
1114                 ((equal exp-data ";")
1115                  (progn
1116                    (math-read-token)
1117                    (let ((exp2 (math-read-expr-level 0)))
1118                      (setq exp (if (and exp2 (Math-realp exp)
1119                                         (Math-anglep exp2))
1120                                    (math-normalize (list 'polar exp exp2))
1121                                  (calc-extensions)
1122                                  (list '* exp
1123                                        (list 'calcFunc-exp
1124                                              (list '*
1125                                                    (math-to-radians-2 exp2)
1126                                                    '(var i var-i)))))))))
1127                 ((or (equal exp-data "\\dots")
1128                      (equal exp-data "\\ldots"))
1129                  (progn
1130                    (math-read-token)
1131                    (let ((exp2 (if (or (equal exp-data ")")
1132                                        (equal exp-data "]")
1133                                        (eq exp-token 'end))
1134                                    '(var inf var-inf)
1135                                  (math-read-expr-level 0))))
1136                      (setq exp
1137                            (list 'intv
1138                                  (if (equal exp-data ")") 0 1)
1139                                  exp
1140                                  exp2)))))))
1141              (if (not (or (equal exp-data ")")
1142                           (and (equal exp-data "]") (eq (car-safe exp) 'intv))
1143                           (eq exp-token 'end)))
1144                  (throw 'syntax "Expected `)'"))
1145              (math-read-token)
1146              exp))
1147           ((eq exp-token 'string)
1148            (calc-extensions)
1149            (math-read-string))
1150           ((equal exp-data "[")
1151            (calc-extensions)
1152            (math-read-brackets t "]"))
1153           ((equal exp-data "{")
1154            (calc-extensions)
1155            (math-read-brackets nil "}"))
1156           ((equal exp-data "<")
1157            (calc-extensions)
1158            (math-read-angle-brackets))
1159           (t (throw 'syntax "Expected a number"))))
1160 )
1161
1162
1163