1 ;; Calculator for GNU Emacs, part I [calc-aent.el]
2 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
3 ;; Written by Dave Gillespie, daveg@synaptics.com.
5 ;; This file is part of GNU Emacs.
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.
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.
24 ;; This file is autoloaded from calc.el.
28 (eval-when-compile '(require calc-macs))
30 (defun calc-Need-calc-aent () nil)
33 (defun calc-do-quick-calc ()
35 (if (eq major-mode 'calc-mode)
36 (calc-algebraic-entry t)
40 (let* ((calc-command-flags nil)
41 (calc-dollar-values calc-quick-prev-results)
43 (enable-recursive-minibuffers t)
44 (calc-language (if (memq calc-language '(nil big))
46 (entry (calc-do-alg-entry "" "Quick calc: " t))
47 (alg-exp (mapcar (function
49 (if (and (not calc-extensions-loaded)
50 calc-previous-alg-entry
52 "\\`[-0-9._+*/^() ]+\\'"
53 calc-previous-alg-entry))
56 (math-evaluate-expr x))))
58 (if (and (= (length alg-exp) 1)
59 (eq (car-safe (car alg-exp)) 'calcFunc-assign)
60 (= (length (car alg-exp)) 3)
61 (eq (car-safe (nth 1 (car alg-exp))) 'var))
64 (set (nth 2 (nth 1 (car alg-exp))) (nth 2 (car alg-exp)))
65 (calc-refresh-evaltos (nth 2 (nth 1 (car alg-exp))))
66 (setq alg-exp (list (nth 2 (car alg-exp))))))
67 (setq calc-quick-prev-results alg-exp
68 buf (mapconcat (function (lambda (x)
69 (math-format-value x 1000)))
73 (if (and (= (length alg-exp) 1)
74 (memq (car-safe (car alg-exp)) '(nil bigpos bigneg))
76 (= calc-number-radix 10))
77 (setq buf (concat buf " ("
78 (let ((calc-number-radix 16))
79 (math-format-value (car alg-exp) 1000))
81 (let ((calc-number-radix 8))
82 (math-format-value (car alg-exp) 1000))
83 (if (and (integerp (car alg-exp))
85 (< (car alg-exp) 127))
86 (format ", \"%c\"" (car alg-exp))
89 (if (and (< (length buf) (frame-width)) (= (length entry) 1)
90 calc-extensions-loaded)
91 (let ((long (concat (math-format-value (car entry) 1000)
93 (if (<= (length long) (- (frame-width) 8))
96 (message "Result: %s" buf)))
97 (if (eq last-command-char 10)
99 (setq kill-ring (cons shortbuf kill-ring))
100 (if (> (length kill-ring) kill-ring-max)
101 (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil))
102 (setq kill-ring-yank-pointer kill-ring)))))
104 (defun calc-do-calc-eval (str separator args)
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)
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)
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)
148 ((eq separator 'macro)
150 (let* ((calc-buffer (current-buffer))
151 (calc-window (get-buffer-window calc-buffer))
152 (save-window (selected-window)))
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)))))
166 (or (not (integerp str))
168 (calc-pop (min str (calc-stack-size))))
173 (<= str (calc-stack-size))
174 (math-format-value (calc-top-n str (car args)) 1000)))
175 ((eq separator 'rawtop)
178 (<= str (calc-stack-size))
179 (calc-top-n str (car args))))
181 (let* ((calc-command-flags nil)
183 (calc-language (if (memq calc-language '(nil big))
184 'flat calc-language))
185 (calc-dollar-values (mapcar
190 (setq x (math-read-exprs x))
200 (res (if (stringp str)
201 (math-read-exprs str)
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)
209 (cond ((eq separator 'pred)
211 (if (= (length res) 1)
212 (math-is-true (car res))
213 (calc-eval-error '(0 "Single value expected"))))
215 (if (= (length res) 1)
217 (calc-eval-error '(0 "Single value expected"))))
218 ((eq separator 'list)
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)
229 (calc-explain-why (car calc-next-why))
230 "Number expected"))))
231 (calc-eval-error '(0 "Single value expected"))))
232 ((eq separator 'push)
236 (setq buf (concat buf
237 (and buf (or separator ", "))
238 (math-format-value (car res) 1000))
242 (defun calc-eval-error (msg)
243 (if (and (boundp 'calc-eval-error)
245 (if (eq calc-eval-error 'string)
247 (error "%s" (nth 1 msg)))
251 ;;;; Reading an expression in algebraic form.
253 (defun calc-auto-algebraic-entry (&optional prefix)
255 (calc-algebraic-entry prefix t))
257 (defun calc-algebraic-entry (&optional prefix auto)
260 (let ((calc-language (if prefix nil calc-language))
261 (math-expr-opers (if prefix math-standard-opers math-expr-opers)))
262 (calc-alg-entry (and auto (char-to-string last-command-char))))))
264 (defun calc-alg-entry (&optional initial prompt)
265 (let* ((sel-mode nil)
266 (calc-dollar-values (mapcar 'calc-get-stack-element
267 (nthcdr calc-stack-top calc-stack)))
270 (alg-exp (calc-do-alg-entry initial prompt t)))
271 (if (stringp alg-exp)
274 (calc-alg-edit alg-exp))
275 (let* ((calc-simplify-mode (if (eq last-command-char ?\C-j)
278 (nvals (mapcar 'calc-normalize alg-exp)))
280 (calc-record (if calc-extensions-loaded (car alg-exp) (car nvals))
282 (calc-pop-push-record-list calc-dollar-used
283 (and (not (equal (car alg-exp)
285 calc-extensions-loaded
288 (setq alg-exp (cdr alg-exp)
290 calc-dollar-used 0)))
291 (calc-handle-whys))))
293 (defun calc-do-alg-entry (&optional initial prompt no-normalize)
294 (let* ((calc-buffer (current-buffer))
295 (blink-paren-function 'calcAlg-blink-matching-open)
297 (if (boundp 'calc-alg-ent-map)
299 (setq calc-alg-ent-map (copy-keymap minibuffer-local-map))
300 (define-key calc-alg-ent-map "'" 'calcAlg-previous)
301 (define-key calc-alg-ent-map "`" 'calcAlg-edit)
302 (define-key calc-alg-ent-map "\C-m" 'calcAlg-enter)
303 (define-key calc-alg-ent-map "\C-j" 'calcAlg-enter)
304 (or calc-emacs-type-19
306 (setq calc-alg-ent-esc-map (copy-sequence esc-map))
308 (aset calc-alg-ent-esc-map i 'calcAlg-escape)
310 (or calc-emacs-type-19
311 (define-key calc-alg-ent-map "\e" nil))
312 (if (eq calc-algebraic-mode 'total)
313 (define-key calc-alg-ent-map "\e" calc-alg-ent-esc-map)
314 (define-key calc-alg-ent-map "\ep" 'calcAlg-plus-minus)
315 (define-key calc-alg-ent-map "\em" 'calcAlg-mod)
316 (define-key calc-alg-ent-map "\e=" 'calcAlg-equals)
317 (define-key calc-alg-ent-map "\e\r" 'calcAlg-equals)
318 (define-key calc-alg-ent-map "\e%" 'self-insert-command))
319 (setq calc-aborted-prefix nil)
320 (let ((buf (read-from-minibuffer (or prompt "Algebraic: ")
322 calc-alg-ent-map nil)))
323 (if (eq alg-exp 'error)
324 (if (eq (car-safe (setq alg-exp (math-read-exprs buf))) 'error)
326 (setq calc-aborted-prefix "alg'")
328 (and alg-exp (setq alg-exp (mapcar 'calc-normalize alg-exp))))
331 (defun calcAlg-plus-minus ()
333 (if (calc-minibuffer-contains ".* \\'")
337 (defun calcAlg-mod ()
339 (if (not (calc-minibuffer-contains ".* \\'"))
341 (if (calc-minibuffer-contains ".* mod +\\'")
342 (if calc-previous-modulo
343 (insert (math-format-flat-expr calc-previous-modulo 0))
347 (defun calcAlg-previous ()
349 (if (calc-minibuffer-contains "\\`\\'")
350 (if calc-previous-alg-entry
351 (insert calc-previous-alg-entry)
355 (defun calcAlg-equals ()
360 (progn (setq prefix-arg (length alg-exp))
361 (calc-unread-command ?=)))))
363 (defun calcAlg-escape ()
365 (calc-unread-command)
368 (use-local-map calc-mode-map))
371 (defun calcAlg-edit ()
373 (if (or (not calc-plain-entry)
374 (calc-minibuffer-contains
375 "\\`\\([^\"]*\"[^\"]*\"\\)*[^\"]*\"[^\"]*\\'"))
377 (setq alg-exp (minibuffer-contents))
378 (and (> (length alg-exp) 0) (setq calc-previous-alg-entry alg-exp))
380 (setq calc-plain-entry nil)
382 (defun calcAlg-enter ()
384 (let* ((str (minibuffer-contents))
385 (exp (and (> (length str) 0)
387 (set-buffer calc-buffer)
388 (math-read-exprs str)))))
389 (if (eq (car-safe exp) 'error)
391 (goto-char (minibuffer-prompt-end))
392 (forward-char (nth 1 exp))
394 (calc-temp-minibuffer-message
395 (concat " [" (or (nth 2 exp) "Error") "]"))
396 (calc-clear-unread-commands))
397 (setq alg-exp (if (calc-minibuffer-contains "\\` *\\[ *\\'")
400 (and (> (length str) 0) (setq calc-previous-alg-entry str))
403 (defun calcAlg-blink-matching-open ()
404 (let ((oldpos (point))
408 (setq blinkpos (scan-sexps oldpos -1))
411 (> oldpos (1+ (point-min)))
412 (or (and (= (char-after (1- oldpos)) ?\))
413 (= (char-after blinkpos) ?\[))
414 (and (= (char-after (1- oldpos)) ?\])
415 (= (char-after blinkpos) ?\()))
418 (looking-at ".+\\(\\.\\.\\|\\\\dots\\|\\\\ldots\\)")))
419 (let ((saved (aref (syntax-table) (char-after blinkpos))))
422 (aset (syntax-table) (char-after blinkpos)
423 (+ (logand saved 255)
424 (lsh (char-after (1- oldpos)) 8)))
425 (blink-matching-open))
426 (aset (syntax-table) (char-after blinkpos) saved)))
427 (blink-matching-open))))
430 (defun calc-alg-digit-entry ()
432 (cond ((eq last-command-char ?e)
433 (if (> calc-number-radix 14) (format "%d.^" calc-number-radix) "1e"))
434 ((eq last-command-char ?#) (format "%d#" calc-number-radix))
435 ((eq last-command-char ?_) "-")
436 ((eq last-command-char ?@) "0@ ")
437 (t (char-to-string last-command-char)))))
439 (defun calcDigit-algebraic ()
441 (if (calc-minibuffer-contains ".*[@oh] *[^'m ]+[^'m]*\\'")
443 (setq calc-digit-value (minibuffer-contents))
446 (defun calcDigit-edit ()
448 (calc-unread-command)
449 (setq calc-digit-value (minibuffer-contents))
453 ;;; Algebraic expression parsing. [Public]
455 (defun math-read-exprs (exp-str)
458 (exp-keep-spaces nil)
460 (if calc-language-input-filter
461 (setq exp-str (funcall calc-language-input-filter exp-str)))
462 (while (setq exp-token (string-match "\\.\\.\\([^.]\\|.[^.]\\)" exp-str))
463 (setq exp-str (concat (substring exp-str 0 exp-token) "\\dots"
464 (substring exp-str (+ exp-token 2)))))
465 (math-build-parse-table)
467 (let ((val (catch 'syntax (math-read-expr-list))))
469 (list 'error exp-old-pos val)
470 (if (equal exp-token 'end)
472 (list 'error exp-old-pos "Syntax error"))))))
474 (defun math-read-expr-list ()
475 (let* ((exp-keep-spaces nil)
476 (val (list (math-read-expr-level 0)))
478 (while (equal exp-data ",")
480 (let ((rest (list (math-read-expr-level 0))))
485 (setq calc-user-parse-table nil)
486 (setq calc-last-main-parse-table nil)
487 (setq calc-last-lang-parse-table nil)
488 (setq calc-user-tokens nil)
489 (setq calc-user-token-chars nil)
491 (defun math-build-parse-table ()
492 (let ((mtab (cdr (assq nil calc-user-parse-tables)))
493 (ltab (cdr (assq calc-language calc-user-parse-tables))))
494 (or (and (eq mtab calc-last-main-parse-table)
495 (eq ltab calc-last-lang-parse-table))
496 (let ((p (append mtab ltab))
498 (setq calc-user-parse-table p)
499 (setq calc-user-token-chars nil)
501 (math-find-user-tokens (car (car p)))
503 (setq calc-user-tokens (mapconcat 'identity
504 (sort (mapcar 'car toks)
505 (function (lambda (x y)
509 calc-last-main-parse-table mtab
510 calc-last-lang-parse-table ltab)))))
512 (defun math-find-user-tokens (p) ; uses "toks"
514 (cond ((and (stringp (car p))
515 (or (> (length (car p)) 1) (equal (car p) "$")
516 (equal (car p) "\""))
517 (string-match "[^a-zA-Z0-9]" (car p)))
518 (let ((s (regexp-quote (car p))))
519 (if (string-match "\\`[a-zA-Z0-9]" s)
520 (setq s (concat "\\<" s)))
521 (if (string-match "[a-zA-Z0-9]\\'" s)
522 (setq s (concat s "\\>")))
525 (setq toks (cons (list s) toks))
526 (or (memq (aref (car p) 0) calc-user-token-chars)
527 (setq calc-user-token-chars
528 (cons (aref (car p) 0)
529 calc-user-token-chars)))))))
531 (math-find-user-tokens (nth 1 (car p)))
532 (or (eq (car (car p)) '\?)
533 (math-find-user-tokens (nth 2 (car p))))))
536 (defun math-read-token ()
537 (if (>= exp-pos (length exp-str))
538 (setq exp-old-pos exp-pos
541 (let ((ch (aref exp-str exp-pos)))
542 (setq exp-old-pos exp-pos)
543 (cond ((memq ch '(32 10 9))
544 (setq exp-pos (1+ exp-pos))
546 (setq exp-token 'space
549 ((and (memq ch calc-user-token-chars)
550 (let ((case-fold-search nil))
551 (eq (string-match calc-user-tokens exp-str exp-pos)
553 (setq exp-token 'punc
554 exp-data (math-match-substring exp-str 0)
555 exp-pos (match-end 0)))
556 ((or (and (>= ch ?a) (<= ch ?z))
557 (and (>= ch ?A) (<= ch ?Z)))
558 (string-match (if (memq calc-language '(c fortran pascal maple))
562 (setq exp-token 'symbol
563 exp-pos (match-end 0)
564 exp-data (math-restore-dashes
565 (math-match-substring exp-str 0)))
566 (if (eq calc-language 'eqn)
567 (let ((code (assoc exp-data math-eqn-ignore-words)))
571 ((consp (nth 1 code))
573 (if (assoc exp-data (cdr code))
574 (setq exp-data (format "%s %s"
575 (car code) exp-data))))
576 ((eq (nth 1 code) 'punc)
577 (setq exp-token 'punc
578 exp-data (nth 2 code)))
581 (math-read-token))))))
582 ((or (and (>= ch ?0) (<= ch ?9))
584 (eq (string-match "\\.[0-9]" exp-str exp-pos) exp-pos))
586 (eq (string-match "_\\.?[0-9]" exp-str exp-pos) exp-pos)
588 (and (memq calc-language '(nil flat big unform
590 (eq (string-match "[^])}\"a-zA-Z0-9'$]_"
591 exp-str (1- exp-pos))
593 (or (and (eq calc-language 'c)
594 (string-match "0[xX][0-9a-fA-F]+" exp-str exp-pos))
595 (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))
596 (setq exp-token 'number
597 exp-data (math-match-substring exp-str 0)
598 exp-pos (match-end 0)))
600 (if (and (eq calc-language 'pascal)
602 "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Z]\\)"
605 (setq exp-token 'number
606 exp-data (math-match-substring exp-str 1)
607 exp-pos (match-end 1))
608 (if (eq (string-match "\\$\\([1-9][0-9]*\\)" exp-str exp-pos)
610 (setq exp-data (- (string-to-int (math-match-substring
612 (string-match "\\$+" exp-str exp-pos)
613 (setq exp-data (- (match-end 0) (match-beginning 0))))
614 (setq exp-token 'dollar
615 exp-pos (match-end 0))))
617 (if (eq (string-match "#\\([1-9][0-9]*\\)" exp-str exp-pos)
619 (setq exp-data (string-to-int
620 (math-match-substring exp-str 1))
621 exp-pos (match-end 0))
623 exp-pos (1+ exp-pos)))
624 (setq exp-token 'hash))
625 ((eq (string-match "~=\\|<=\\|>=\\|<>\\|/=\\|\\+/-\\|\\\\dots\\|\\\\ldots\\|\\*\\*\\|<<\\|>>\\|==\\|!=\\|&&&\\||||\\|!!!\\|&&\\|||\\|!!\\|:=\\|::\\|=>"
628 (setq exp-token 'punc
629 exp-data (math-match-substring exp-str 0)
630 exp-pos (match-end 0)))
632 (string-match "\\(\"\\([^\"\\]\\|\\\\.\\)*\\)\\(\"\\|\\'\\)" exp-str exp-pos))
633 (if (eq calc-language 'eqn)
635 (setq exp-str (copy-sequence exp-str))
636 (aset exp-str (match-beginning 1) ?\{)
637 (if (< (match-end 1) (length exp-str))
638 (aset exp-str (match-end 1) ?\}))
640 (setq exp-token 'string
641 exp-data (math-match-substring exp-str 1)
642 exp-pos (match-end 0))))
643 ((and (= ch ?\\) (eq calc-language 'tex)
644 (< exp-pos (1- (length exp-str))))
645 (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" exp-str exp-pos)
646 (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" exp-str exp-pos))
647 (setq exp-token 'symbol
648 exp-pos (match-end 0)
649 exp-data (math-restore-dashes
650 (math-match-substring exp-str 1)))
651 (let ((code (assoc exp-data math-tex-ignore-words)))
655 ((eq (nth 1 code) 'punc)
656 (setq exp-token 'punc
657 exp-data (nth 2 code)))
658 ((and (eq (nth 1 code) 'mat)
659 (string-match " *{" exp-str exp-pos))
660 (setq exp-pos (match-end 0)
663 (let ((right (string-match "}" exp-str exp-pos)))
665 (setq exp-str (copy-sequence exp-str))
666 (aset exp-str right ?\])))))))
667 ((and (= ch ?\.) (eq calc-language 'fortran)
668 (eq (string-match "\\.[a-zA-Z][a-zA-Z][a-zA-Z]?\\."
669 exp-str exp-pos) exp-pos))
670 (setq exp-token 'punc
671 exp-data (upcase (math-match-substring exp-str 0))
672 exp-pos (match-end 0)))
673 ((and (eq calc-language 'math)
674 (eq (string-match "\\[\\[\\|->\\|:>" exp-str exp-pos)
676 (setq exp-token 'punc
677 exp-data (math-match-substring exp-str 0)
678 exp-pos (match-end 0)))
679 ((and (eq calc-language 'eqn)
680 (eq (string-match "->\\|<-\\|+-\\|\\\\dots\\|~\\|\\^"
683 (setq exp-token 'punc
684 exp-data (math-match-substring exp-str 0)
685 exp-pos (match-end 0))
686 (and (eq (string-match "\\\\dots\\." exp-str exp-pos) exp-pos)
687 (setq exp-pos (match-end 0)))
688 (if (memq (aref exp-data 0) '(?~ ?^))
690 ((eq (string-match "%%.*$" exp-str exp-pos) exp-pos)
691 (setq exp-pos (match-end 0))
694 (if (and (eq ch ?\{) (memq calc-language '(tex eqn)))
696 (if (and (eq ch ?\}) (memq calc-language '(tex eqn)))
698 (if (and (eq ch ?\&) (eq calc-language 'tex))
700 (setq exp-token 'punc
701 exp-data (char-to-string ch)
702 exp-pos (1+ exp-pos)))))))
705 (defun math-read-expr-level (exp-prec &optional exp-term)
706 (let* ((x (math-read-factor)) (first t) op op2)
707 (while (and (or (and calc-user-parse-table
708 (setq op (calc-check-user-syntax x exp-prec))
710 op '("2x" ident 999999 -1)))
711 (and (setq op (assoc exp-data math-expr-opers))
713 (or (and (setq op2 (assoc
715 (cdr (memq op math-expr-opers))))
716 (eq (= (nth 3 op) -1)
718 (eq (= (nth 3 op2) -1)
719 (not (math-factor-after)))
722 (and (or (eq (nth 2 op) -1)
723 (memq exp-token '(symbol number dollar hash))
725 (and (equal exp-data "[")
726 (not (eq calc-language 'math))
727 (not (and exp-keep-spaces
728 (eq (car-safe x) 'vec)))))
729 (or (not (setq op (assoc exp-data math-expr-opers)))
731 (or (not calc-user-parse-table)
732 (not (eq exp-token 'symbol))
733 (let ((p calc-user-parse-table))
736 (car (car (car p)))))
738 (nth 1 (car (car p)))
742 (setq op (assoc "2x" math-expr-opers))))
743 (not (and exp-term (equal exp-data exp-term)))
744 (>= (nth 2 op) exp-prec))
745 (if (not (equal (car op) "2x"))
747 (and (memq (nth 1 op) '(sdev mod))
749 (setq x (cond ((consp (nth 1 op))
750 (funcall (car (nth 1 op)) x op))
752 (if (eq (nth 1 op) 'ident)
754 (if (eq (nth 1 op) 'closing)
755 (if (eq (nth 2 op) exp-prec)
759 (throw 'syntax "Mismatched delimiters"))
760 (list (nth 1 op) x))))
762 (memq (nth 1 op) math-alg-inequalities)
763 (memq (car-safe x) math-alg-inequalities))
765 (math-composite-inequalities x op))
768 (math-read-expr-level (nth 3 op) exp-term))))
772 (defun calc-check-user-syntax (&optional x prec)
773 (let ((p calc-user-parse-table)
778 (setq rule (car (car p)))
780 (and (integerp (car rule))
783 (car (setq rule (cdr rule)))))
784 (equal exp-data (car rule)))))
785 (let ((save-exp-pos exp-pos)
786 (save-exp-old-pos exp-old-pos)
787 (save-exp-token exp-token)
788 (save-exp-data exp-data))
790 (setq matches (calc-match-user-syntax rule))))
797 (setq matches (cons x matches)))
798 (setq match (cdr (car p)))
799 (while (and (eq (car-safe match)
801 (= (length match) 3))
802 (setq conds (append (math-flatten-lands
805 match (nth 1 match)))
806 (while (and conds match)
808 (cond ((eq (car-safe (car conds))
810 (setq temp (car conds))
811 (or (= (length temp) 3)
812 (and (= (length temp) 2)
813 (eq (car-safe (nth 1 temp))
815 (= (length (nth 1 temp)) 3)
816 (setq temp (nth 1 temp)))
824 args (cons (nth 1 temp)
826 ((and (eq (car-safe (car conds))
828 (= (length (car conds)) 3))
829 (setq temp (calcFunc-vmatches
833 (nth 2 (car conds))))
836 (while (setq temp (cdr temp))
837 (setq matches (cons (nth 2 (car temp))
839 args (cons (nth 1 (car temp))
842 (or (math-is-true (math-simplify
847 (setq conds (cdr conds)))
849 (not (setq match (math-multi-subst
850 match args matches)))
851 (setq exp-old-pos save-exp-old-pos
852 exp-token save-exp-token
853 exp-data save-exp-data
854 exp-pos save-exp-pos)))))))
858 (defun calc-match-user-syntax (p &optional term)
860 (save-exp-pos exp-pos)
861 (save-exp-old-pos exp-old-pos)
862 (save-exp-token exp-token)
863 (save-exp-data exp-data))
865 (cond ((stringp (car p))
866 (and (equal exp-data (car p))
871 (and (setq m (catch 'syntax
872 (math-read-expr-level
875 (if (consp (nth 1 p))
876 (car (nth 1 (nth 1 p)))
880 (setq matches (nconc matches (list m)))))
881 ((eq (car (car p)) '\?)
882 (setq m (calc-match-user-syntax (nth 1 (car p))))
887 (cons 'vec (and (listp m) m))))))
888 (or (listp m) (not (nth 2 (car p)))
889 (not (eq (aref (car (nth 2 (car p))) 0) ?\$))
890 (eq exp-token 'end)))
892 (setq m (calc-match-user-syntax (nth 1 (car p))
893 (car (nth 2 (car p)))))
895 (let ((vec (cons 'vec m))
899 mm (calc-match-user-syntax
902 (car (nth 2 (car p))))))
904 (setq vec (nconc vec mm)))
905 (setq matches (nconc matches (list vec))))
906 (and (eq (car (car p)) '*)
907 (setq matches (nconc matches (list '(vec)))))))))
910 (setq exp-pos save-exp-pos
911 exp-old-pos save-exp-old-pos
912 exp-token save-exp-token
913 exp-data save-exp-data
917 (defconst math-alg-inequalities
918 '(calcFunc-lt calcFunc-gt calcFunc-leq calcFunc-geq
919 calcFunc-eq calcFunc-neq))
921 (defun math-remove-dashes (x)
922 (if (string-match "\\`\\(.*\\)-\\(.*\\)\\'" x)
924 (concat (math-match-substring x 1) "#" (math-match-substring x 2)))
927 (defun math-restore-dashes (x)
928 (if (string-match "\\`\\(.*\\)[#_]\\(.*\\)\\'" x)
930 (concat (math-match-substring x 1) "-" (math-match-substring x 2)))
933 (defun math-read-if (cond op)
934 (let ((then (math-read-expr-level 0)))
935 (or (equal exp-data ":")
936 (throw 'syntax "Expected ':'"))
938 (list 'calcFunc-if cond then (math-read-expr-level (nth 3 op)))))
940 (defun math-factor-after ()
941 (let ((exp-pos exp-pos)
942 exp-old-pos exp-token exp-data)
944 (or (memq exp-token '(number symbol dollar hash string))
945 (and (assoc exp-data '(("-") ("+") ("!") ("|") ("/")))
946 (assoc (concat "u" exp-data) math-expr-opers))
947 (eq (nth 2 (assoc exp-data math-expr-opers)) -1)
948 (assoc exp-data '(("(") ("[") ("{"))))))
950 (defun math-read-factor ()
952 (cond ((eq exp-token 'number)
953 (let ((num (math-read-number exp-data)))
956 (setq exp-old-pos exp-pos)
957 (throw 'syntax "Bad format")))
959 (if (and math-read-expr-quotes
963 ((and calc-user-parse-table
964 (setq op (calc-check-user-syntax)))
966 ((or (equal exp-data "-")
970 (equal exp-data "/"))
971 (setq exp-data (concat "u" exp-data))
973 ((and (setq op (assoc exp-data math-expr-opers))
975 (if (consp (nth 1 op))
976 (funcall (car (nth 1 op)) op)
978 (let ((val (math-read-expr-level (nth 3 op))))
979 (cond ((eq (nth 1 op) 'ident)
981 ((and (Math-numberp val)
982 (equal (car op) "u-"))
984 (t (list (nth 1 op) val))))))
985 ((eq exp-token 'symbol)
986 (let ((sym (intern exp-data)))
988 (if (equal exp-data calc-function-open)
989 (let ((f (assq sym math-expr-function-mapping)))
992 (funcall (car (cdr f)) f sym)
993 (let ((args (if (or (equal exp-data calc-function-close)
996 (math-read-expr-list))))
997 (if (not (or (equal exp-data calc-function-close)
998 (eq exp-token 'end)))
999 (throw 'syntax "Expected `)'"))
1001 (if (and (eq calc-language 'fortran) args
1003 (let ((calc-matrix-mode 'scalar))
1008 (symbol-name sym)))))))
1009 (math-parse-fortran-subscr sym args)
1012 (and (= (aref (symbol-name sym) 0) ?\\)
1013 (< (prefix-numeric-value calc-language-option)
1015 (setq sym (intern (substring (symbol-name sym)
1017 (or (string-match "-" (symbol-name sym))
1020 (symbol-name sym))))))
1022 (if math-read-expr-quotes
1024 (let ((val (list 'var
1025 (intern (math-remove-dashes
1027 (if (string-match "-" (symbol-name sym))
1029 (intern (concat "var-"
1030 (symbol-name sym)))))))
1031 (let ((v (assq (nth 1 val) math-expr-variable-mapping)))
1032 (and v (setq val (if (consp (cdr v))
1033 (funcall (car (cdr v)) v val)
1036 (substring (symbol-name (cdr v))
1039 (while (and (memq calc-language '(c pascal maple))
1040 (equal exp-data "["))
1042 (setq val (append (list 'calcFunc-subscr val)
1043 (math-read-expr-list)))
1044 (if (equal exp-data "]")
1046 (throw 'syntax "Expected ']'")))
1048 ((eq exp-token 'dollar)
1049 (let ((abs (if (> exp-data 0) exp-data (- exp-data))))
1050 (if (>= (length calc-dollar-values) abs)
1051 (let ((num exp-data))
1053 (setq calc-dollar-used (max calc-dollar-used num))
1054 (math-check-complete (nth (1- abs) calc-dollar-values)))
1055 (throw 'syntax (if calc-dollar-values
1057 "$'s not allowed in this context")))))
1058 ((eq exp-token 'hash)
1059 (or calc-hashes-used
1060 (throw 'syntax "#'s not allowed in this context"))
1062 (if (<= exp-data (length calc-arg-values))
1063 (let ((num exp-data))
1065 (setq calc-hashes-used (max calc-hashes-used num))
1066 (nth (1- num) calc-arg-values))
1067 (throw 'syntax "Too many # arguments")))
1068 ((equal exp-data "(")
1069 (let* ((exp (let ((exp-keep-spaces nil))
1071 (if (or (equal exp-data "\\dots")
1072 (equal exp-data "\\ldots"))
1073 '(neg (var inf var-inf))
1074 (math-read-expr-level 0)))))
1075 (let ((exp-keep-spaces nil))
1077 ((equal exp-data ",")
1080 (let ((exp2 (math-read-expr-level 0)))
1082 (if (and exp2 (Math-realp exp) (Math-realp exp2))
1083 (math-normalize (list 'cplx exp exp2))
1084 (list '+ exp (list '* exp2 '(var i var-i))))))))
1085 ((equal exp-data ";")
1088 (let ((exp2 (math-read-expr-level 0)))
1089 (setq exp (if (and exp2 (Math-realp exp)
1091 (math-normalize (list 'polar exp exp2))
1096 (math-to-radians-2 exp2)
1097 '(var i var-i)))))))))
1098 ((or (equal exp-data "\\dots")
1099 (equal exp-data "\\ldots"))
1102 (let ((exp2 (if (or (equal exp-data ")")
1103 (equal exp-data "]")
1104 (eq exp-token 'end))
1106 (math-read-expr-level 0))))
1109 (if (equal exp-data ")") 0 1)
1112 (if (not (or (equal exp-data ")")
1113 (and (equal exp-data "]") (eq (car-safe exp) 'intv))
1114 (eq exp-token 'end)))
1115 (throw 'syntax "Expected `)'"))
1118 ((eq exp-token 'string)
1121 ((equal exp-data "[")
1123 (math-read-brackets t "]"))
1124 ((equal exp-data "{")
1126 (math-read-brackets nil "}"))
1127 ((equal exp-data "<")
1129 (math-read-angle-brackets))
1130 (t (throw 'syntax "Expected a number")))))
1132 ;;; calc-aent.el ends here