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