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