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