code.delx.au - gnu-emacs/blob - lisp/calc/calc-aent.el

   1 ;;; calc-aent.el --- algebraic entry functions for Calc
   2
   3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2005 Free Software Foundation, Inc.
   4
   5 ;; Author: Dave Gillespie <daveg@synaptics.com>
   6 ;; Maintainer: Jay Belanger <belanger@truman.edu>
   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
  31 (require 'calc)
  32 (require 'calc-macs)
  33
  34 (defun calc-do-quick-calc ()
  35   (calc-check-defines)
  36   (if (eq major-mode 'calc-mode)
  37       (calc-algebraic-entry t)
  38     (let (buf shortbuf)
  39       (save-excursion
  40         (calc-create-buffer)
  41         (let* ((calc-command-flags nil)
  42                (calc-dollar-values calc-quick-prev-results)
  43                (calc-dollar-used 0)
  44                (enable-recursive-minibuffers t)
  45                (calc-language (if (memq calc-language '(nil big))
  46                                   'flat calc-language))
  47                (entry (calc-do-alg-entry "" "Quick calc: " t))
  48                (alg-exp (mapcar (function
  49                                  (lambda (x)
  50                                    (if (and (not (featurep 'calc-ext))
  51                                             calc-previous-alg-entry
  52                                             (string-match
  53                                              "\\`[-0-9._+*/^() ]+\\'"
  54                                              calc-previous-alg-entry))
  55                                        (calc-normalize x)
  56                                      (require 'calc-ext)
  57                                      (math-evaluate-expr x))))
  58                                 entry)))
  59           (when (and (= (length alg-exp) 1)
  60                      (eq (car-safe (car alg-exp)) 'calcFunc-assign)
  61                      (= (length (car alg-exp)) 3)
  62                      (eq (car-safe (nth 1 (car alg-exp))) 'var))
  63             (require 'calc-ext)
  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                    (featurep 'calc-ext))
  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         (kill-new shortbuf)))))
 100
 101 (defun calc-do-calc-eval (str separator args)
 102   (calc-check-defines)
 103   (catch 'calc-error
 104     (save-excursion
 105       (calc-create-buffer)
 106       (cond
 107        ((and (consp str) (not (symbolp (car str))))
 108         (let ((calc-language nil)
 109               (math-expr-opers math-standard-opers)
 110               (calc-internal-prec 12)
 111               (calc-word-size 32)
 112               (calc-symbolic-mode nil)
 113               (calc-matrix-mode nil)
 114               (calc-angle-mode 'deg)
 115               (calc-number-radix 10)
 116               (calc-leading-zeros nil)
 117               (calc-group-digits nil)
 118               (calc-point-char ".")
 119               (calc-frac-format '(":" nil))
 120               (calc-prefer-frac nil)
 121               (calc-hms-format "%s@ %s' %s\"")
 122               (calc-date-format '((H ":" mm C SS pp " ")
 123                                   Www " " Mmm " " D ", " YYYY))
 124               (calc-float-format '(float 0))
 125               (calc-full-float-format '(float 0))
 126               (calc-complex-format nil)
 127               (calc-matrix-just nil)
 128               (calc-full-vectors t)
 129               (calc-break-vectors nil)
 130               (calc-vector-commas ",")
 131               (calc-vector-brackets "[]")
 132               (calc-matrix-brackets '(R O))
 133               (calc-complex-mode 'cplx)
 134               (calc-infinite-mode nil)
 135               (calc-display-strings nil)
 136               (calc-simplify-mode nil)
 137               (calc-display-working-message 'lots)
 138               (strp (cdr str)))
 139           (while strp
 140             (set (car strp) (nth 1 strp))
 141             (setq strp (cdr (cdr strp))))
 142           (calc-do-calc-eval (car str) separator args)))
 143        ((eq separator 'eval)
 144         (eval str))
 145        ((eq separator 'macro)
 146         (require 'calc-ext)
 147         (let* ((calc-buffer (current-buffer))
 148                (calc-window (get-buffer-window calc-buffer))
 149                (save-window (selected-window)))
 150           (if calc-window
 151               (unwind-protect
 152                   (progn
 153                     (select-window calc-window)
 154                     (calc-execute-kbd-macro str nil (car args)))
 155                 (and (window-point save-window)
 156                      (select-window save-window)))
 157             (save-window-excursion
 158               (select-window (get-largest-window))
 159               (switch-to-buffer calc-buffer)
 160               (calc-execute-kbd-macro str nil (car args)))))
 161         nil)
 162        ((eq separator 'pop)
 163         (or (not (integerp str))
 164             (= str 0)
 165             (calc-pop (min str (calc-stack-size))))
 166         (calc-stack-size))
 167        ((eq separator 'top)
 168         (and (integerp str)
 169              (> str 0)
 170              (<= str (calc-stack-size))
 171              (math-format-value (calc-top-n str (car args)) 1000)))
 172        ((eq separator 'rawtop)
 173         (and (integerp str)
 174              (> str 0)
 175              (<= str (calc-stack-size))
 176              (calc-top-n str (car args))))
 177        (t
 178         (let* ((calc-command-flags nil)
 179                (calc-next-why nil)
 180                (calc-language (if (memq calc-language '(nil big))
 181                                   'flat calc-language))
 182                (calc-dollar-values (mapcar
 183                                     (function
 184                                      (lambda (x)
 185                                        (if (stringp x)
 186                                            (progn
 187                                              (setq x (math-read-exprs x))
 188                                              (if (eq (car-safe x)
 189                                                      'error)
 190                                                  (throw 'calc-error
 191                                                         (calc-eval-error
 192                                                          (cdr x)))
 193                                                (car x)))
 194                                          x)))
 195                                     args))
 196                (calc-dollar-used 0)
 197                (res (if (stringp str)
 198                         (math-read-exprs str)
 199                       (list str)))
 200                buf)
 201           (if (eq (car res) 'error)
 202               (calc-eval-error (cdr res))
 203             (setq res (mapcar 'calc-normalize res))
 204             (and (memq 'clear-message calc-command-flags)
 205                  (message ""))
 206             (cond ((eq separator 'pred)
 207                    (require 'calc-ext)
 208                    (if (= (length res) 1)
 209                        (math-is-true (car res))
 210                      (calc-eval-error '(0 "Single value expected"))))
 211                   ((eq separator 'raw)
 212                    (if (= (length res) 1)
 213                        (car res)
 214                      (calc-eval-error '(0 "Single value expected"))))
 215                   ((eq separator 'list)
 216                    res)
 217                   ((memq separator '(num rawnum))
 218                    (if (= (length res) 1)
 219                        (if (math-constp (car res))
 220                            (if (eq separator 'num)
 221                                (math-format-value (car res) 1000)
 222                              (car res))
 223                          (calc-eval-error
 224                           (list 0
 225                                 (if calc-next-why
 226                                     (calc-explain-why (car calc-next-why))
 227                                   "Number expected"))))
 228                      (calc-eval-error '(0 "Single value expected"))))
 229                   ((eq separator 'push)
 230                    (calc-push-list res)
 231                    nil)
 232                   (t (while res
 233                        (setq buf (concat buf
 234                                          (and buf (or separator ", "))
 235                                          (math-format-value (car res) 1000))
 236                              res (cdr res)))
 237                      buf)))))))))
 238
 239 (defvar calc-eval-error nil
 240   "Determines how calc handles errors.
 241 NIL means return a list containing the character position of error.
 242 STRING means return error message as string rather than list.
 243 T means abort and give an error message.")
 244
 245 (defun calc-eval-error (msg)
 246   (if calc-eval-error
 247       (if (eq calc-eval-error 'string)
 248           (nth 1 msg)
 249         (error "%s" (nth 1 msg)))
 250     msg))
 251
 252
 253 ;;;; Reading an expression in algebraic form.
 254
 255 (defun calc-auto-algebraic-entry (&optional prefix)
 256   (interactive "P")
 257   (calc-algebraic-entry prefix t))
 258
 259 (defun calc-algebraic-entry (&optional prefix auto)
 260   (interactive "P")
 261   (calc-wrapper
 262    (let ((calc-language (if prefix nil calc-language))
 263          (math-expr-opers (if prefix math-standard-opers math-expr-opers)))
 264      (calc-alg-entry (and auto (char-to-string last-command-char))))))
 265
 266 (defun calc-alg-entry (&optional initial prompt)
 267   (let* ((sel-mode nil)
 268          (calc-dollar-values (mapcar 'calc-get-stack-element
 269                                      (nthcdr calc-stack-top calc-stack)))
 270          (calc-dollar-used 0)
 271          (calc-plain-entry t)
 272          (alg-exp (calc-do-alg-entry initial prompt t)))
 273     (if (stringp alg-exp)
 274         (progn
 275           (require 'calc-ext)
 276           (calc-alg-edit alg-exp))
 277       (let* ((calc-simplify-mode (if (eq last-command-char ?\C-j)
 278                                      'none
 279                                    calc-simplify-mode))
 280              (nvals (mapcar 'calc-normalize alg-exp)))
 281         (while alg-exp
 282           (calc-record (if (featurep 'calc-ext) (car alg-exp) (car nvals))
 283                        "alg'")
 284           (calc-pop-push-record-list calc-dollar-used
 285                                      (and (not (equal (car alg-exp)
 286                                                       (car nvals)))
 287                                           (featurep 'calc-ext)
 288                                           "")
 289                                      (list (car nvals)))
 290           (setq alg-exp (cdr alg-exp)
 291                 nvals (cdr nvals)
 292                 calc-dollar-used 0)))
 293       (calc-handle-whys))))
 294
 295 (defvar calc-alg-ent-map nil
 296   "The keymap used for algebraic entry.")
 297
 298 (defvar calc-alg-ent-esc-map nil
 299   "The keymap used for escapes in algebraic entry.")
 300
 301 (defvar calc-alg-exp)
 302
 303 (defun calc-do-alg-entry (&optional initial prompt no-normalize)
 304   (let* ((calc-buffer (current-buffer))
 305          (blink-paren-function 'calcAlg-blink-matching-open)
 306          (calc-alg-exp 'error))
 307     (unless calc-alg-ent-map
 308       (setq calc-alg-ent-map (copy-keymap minibuffer-local-map))
 309       (define-key calc-alg-ent-map "'" 'calcAlg-previous)
 310       (define-key calc-alg-ent-map "`" 'calcAlg-edit)
 311       (define-key calc-alg-ent-map "\C-m" 'calcAlg-enter)
 312       (define-key calc-alg-ent-map "\C-j" 'calcAlg-enter)
 313       (let ((i 33))
 314         (setq calc-alg-ent-esc-map (copy-keymap esc-map))
 315         (while (< i 127)
 316           (aset (nth 1 calc-alg-ent-esc-map) i 'calcAlg-escape)
 317           (setq i (1+ i)))))
 318     (define-key calc-alg-ent-map "\e" nil)
 319     (if (eq calc-algebraic-mode 'total)
 320         (define-key calc-alg-ent-map "\e" calc-alg-ent-esc-map)
 321       (define-key calc-alg-ent-map "\ep" 'calcAlg-plus-minus)
 322       (define-key calc-alg-ent-map "\em" 'calcAlg-mod)
 323       (define-key calc-alg-ent-map "\e=" 'calcAlg-equals)
 324       (define-key calc-alg-ent-map "\e\r" 'calcAlg-equals)
 325       (define-key calc-alg-ent-map "\e%" 'self-insert-command))
 326     (setq calc-aborted-prefix nil)
 327     (let ((buf (read-from-minibuffer (or prompt "Algebraic: ")
 328                                      (or initial "")
 329                                      calc-alg-ent-map nil)))
 330       (when (eq calc-alg-exp 'error)
 331         (when (eq (car-safe (setq calc-alg-exp (math-read-exprs buf))) 'error)
 332           (setq calc-alg-exp nil)))
 333       (setq calc-aborted-prefix "alg'")
 334       (or no-normalize
 335           (and calc-alg-exp (setq calc-alg-exp (mapcar 'calc-normalize calc-alg-exp))))
 336       calc-alg-exp)))
 337
 338 (defun calcAlg-plus-minus ()
 339   (interactive)
 340   (if (calc-minibuffer-contains ".* \\'")
 341       (insert "+/- ")
 342     (insert " +/- ")))
 343
 344 (defun calcAlg-mod ()
 345   (interactive)
 346   (if (not (calc-minibuffer-contains ".* \\'"))
 347       (insert " "))
 348   (if (calc-minibuffer-contains ".* mod +\\'")
 349       (if calc-previous-modulo
 350           (insert (math-format-flat-expr calc-previous-modulo 0))
 351         (beep))
 352     (insert "mod ")))
 353
 354 (defun calcAlg-previous ()
 355   (interactive)
 356   (if (calc-minibuffer-contains "\\'")
 357       (if calc-previous-alg-entry
 358           (insert calc-previous-alg-entry)
 359         (beep))
 360     (insert "'")))
 361
 362 (defun calcAlg-equals ()
 363   (interactive)
 364   (unwind-protect
 365       (calcAlg-enter)
 366     (if (consp calc-alg-exp)
 367         (progn (setq prefix-arg (length calc-alg-exp))
 368                (calc-unread-command ?=)))))
 369
 370 (defun calcAlg-escape ()
 371   (interactive)
 372   (calc-unread-command)
 373   (save-excursion
 374     (calc-select-buffer)
 375     (use-local-map calc-mode-map))
 376   (calcAlg-enter))
 377
 378 (defvar calc-plain-entry nil)
 379 (defun calcAlg-edit ()
 380   (interactive)
 381   (if (or (not calc-plain-entry)
 382           (calc-minibuffer-contains
 383            "\\`\\([^\"]*\"[^\"]*\"\\)*[^\"]*\"[^\"]*\\'"))
 384       (insert "`")
 385     (setq calc-alg-exp (minibuffer-contents))
 386     (and (> (length calc-alg-exp) 0) (setq calc-previous-alg-entry calc-alg-exp))
 387     (exit-minibuffer)))
 388
 389 (defvar calc-buffer)
 390
 391 (defun calcAlg-enter ()
 392   (interactive)
 393   (let* ((str (minibuffer-contents))
 394          (exp (and (> (length str) 0)
 395                    (save-excursion
 396                      (set-buffer calc-buffer)
 397                      (math-read-exprs str)))))
 398     (if (eq (car-safe exp) 'error)
 399         (progn
 400           (goto-char (minibuffer-prompt-end))
 401           (forward-char (nth 1 exp))
 402           (beep)
 403           (calc-temp-minibuffer-message
 404            (concat " [" (or (nth 2 exp) "Error") "]"))
 405           (calc-clear-unread-commands))
 406       (setq calc-alg-exp (if (calc-minibuffer-contains "\\` *\\[ *\\'")
 407                         '((incomplete vec))
 408                       exp))
 409       (and (> (length str) 0) (setq calc-previous-alg-entry str))
 410       (exit-minibuffer))))
 411
 412 (defun calcAlg-blink-matching-open ()
 413   (let ((rightpt (point))
 414         (leftpt nil)
 415         (rightchar (preceding-char))
 416         leftchar
 417         rightsyntax
 418         leftsyntax)
 419     (save-excursion
 420       (condition-case ()
 421           (setq leftpt (scan-sexps rightpt -1)
 422                 leftchar (char-after leftpt))
 423         (error nil)))
 424     (if (and leftpt
 425              (or (and (= rightchar ?\))
 426                       (= leftchar ?\[))
 427                  (and (= rightchar ?\])
 428                       (= leftchar ?\()))
 429              (save-excursion
 430                (goto-char leftpt)
 431                (looking-at ".+\\(\\.\\.\\|\\\\dots\\|\\\\ldots\\)")))
 432         (let ((leftsaved (aref (syntax-table) leftchar))
 433               (rightsaved (aref (syntax-table) rightchar)))
 434           (unwind-protect
 435               (progn
 436                 (cond ((= leftchar ?\[)
 437                        (aset (syntax-table) leftchar (cons 4 ?\)))
 438                        (aset (syntax-table) rightchar (cons 5 ?\[)))
 439                       (t
 440                        (aset (syntax-table) leftchar (cons 4 ?\]))
 441                        (aset (syntax-table) rightchar (cons 5 ?\())))
 442                 (blink-matching-open))
 443             (aset (syntax-table) leftchar leftsaved)
 444             (aset (syntax-table) rightchar rightsaved)))
 445       (blink-matching-open))))
 446
 447 (defun calc-alg-digit-entry ()
 448   (calc-alg-entry
 449    (cond ((eq last-command-char ?e)
 450           (if (> calc-number-radix 14) (format "%d.^" calc-number-radix) "1e"))
 451          ((eq last-command-char ?#) (format "%d#" calc-number-radix))
 452          ((eq last-command-char ?_) "-")
 453          ((eq last-command-char ?@) "0@ ")
 454          (t (char-to-string last-command-char)))))
 455
 456 ;; The variable calc-digit-value is initially declared in calc.el,
 457 ;; but can be set by calcDigit-algebraic and calcDigit-edit.
 458 (defvar calc-digit-value)
 459
 460 (defun calcDigit-algebraic ()
 461   (interactive)
 462   (if (calc-minibuffer-contains ".*[@oh] *[^'m ]+[^'m]*\\'")
 463       (calcDigit-key)
 464     (setq calc-digit-value (minibuffer-contents))
 465     (exit-minibuffer)))
 466
 467 (defun calcDigit-edit ()
 468   (interactive)
 469   (calc-unread-command)
 470   (setq calc-digit-value (minibuffer-contents))
 471   (exit-minibuffer))
 472
 473
 474 ;;; Algebraic expression parsing.   [Public]
 475
 476 (defvar math-read-replacement-list
 477   '(;; Misc symbols
 478     ("±" "+/-")  ; plus or minus
 479     ("×" "*")    ; multiplication sign
 480     ("÷" ":")    ; division sign
 481     ("−" "-")    ; subtraction sign
 482     ("∕" "/")    ; division sign
 483     ("∗" "*")    ; asterisk multiplication
 484     ("∞" "inf")  ; infinity symbol
 485     ("≤" "<=")
 486     ("≥" ">=")
 487     ("≦" "<=")
 488     ("≧" ">=")
 489     ;; fractions
 490     ("¼" "(1:4)") ; 1/4
 491     ("½" "(1:2)") ; 1/2
 492     ("¾" "(3:4)") ; 3/4
 493     ("⅓" "(1:3)") ; 1/3
 494     ("⅔" "(2:3)") ; 2/3
 495     ("⅕" "(1:5)") ; 1/5
 496     ("⅖" "(2:5)") ; 2/5
 497     ("⅗" "(3:5)") ; 3/5
 498     ("⅘" "(4:5)") ; 4/5
 499     ("⅙" "(1:6)") ; 1/6
 500     ("⅚" "(5:6)") ; 5/6
 501     ("⅛" "(1:8)") ; 1/8
 502     ("⅜" "(3:8)") ; 3/8
 503     ("⅝" "(5:8)") ; 5/8
 504     ("⅞" "(7:8)") ; 7/8
 505     ("⅟" "1:")    ; 1/...
 506     ;; superscripts
 507     ("⁰" "0")  ; 0
 508     ("¹" "1")  ; 1
 509     ("²" "2")  ; 2
 510     ("³" "3")  ; 3
 511     ("⁴" "4")  ; 4
 512     ("⁵" "5")  ; 5
 513     ("⁶" "6")  ; 6
 514     ("⁷" "7")  ; 7
 515     ("⁸" "8")  ; 8
 516     ("⁹" "9")  ; 9
 517     ("⁺" "+")  ; +
 518     ("⁻" "-")  ; -
 519     ("⁽" "(")  ; (
 520     ("⁾" ")")  ; )
 521     ("ⁿ" "n")  ; n
 522     ("ⁱ" "i")  ; i
 523     ;; subscripts
 524     ("₀"  "0")  ; 0
 525     ("₁"  "1")  ; 1
 526     ("₂"  "2")  ; 2
 527     ("₃"  "3")  ; 3
 528     ("₄"  "4")  ; 4
 529     ("₅"  "5")  ; 5
 530     ("₆"  "6")  ; 6
 531     ("₇"  "7")  ; 7
 532     ("₈"  "8")  ; 8
 533     ("₉"  "9")  ; 9
 534     ("₊"  "+")  ; +
 535     ("₋"  "-")  ; -
 536     ("₍"  "(")  ; (
 537     ("₎"  ")"))  ; )
 538   "A list whose elements (old new) indicate replacements to make
 539 in Calc algebraic input.")
 540
 541 (defvar math-read-superscripts
 542   "⁰¹²³⁴⁵⁶⁷⁸⁹⁺⁻⁽⁾ⁿⁱ" ; 0123456789+-()ni
 543   "A string consisting of the superscripts allowed by Calc.")
 544
 545 (defvar math-read-subscripts
 546   "₀₁₂₃₄₅₆₇₈₉₊₋₍₎" ; 0123456789+-()
 547   "A string consisting of the subscripts allowed by Calc.")
 548
 549 (defun math-read-preprocess-string (str)
 550   "Replace some substrings of STR by Calc equivalents."
 551   (setq str
 552         (replace-regexp-in-string (concat "[" math-read-superscripts "]+")
 553                                   "^(\\&)" str))
 554   (setq str
 555         (replace-regexp-in-string (concat "[" math-read-subscripts "]+")
 556                                   "_(\\&)" str))
 557   (let ((rep-list math-read-replacement-list))
 558     (while rep-list
 559       (setq str
 560             (replace-regexp-in-string (nth 0 (car rep-list))
 561                                       (nth 1 (car rep-list)) str))
 562       (setq rep-list (cdr rep-list))))
 563   str)
 564
 565 ;; The next few variables are local to math-read-exprs (and math-read-expr
 566 ;; in calc-ext.el), but are set in functions they call.
 567
 568 (defvar math-exp-pos)
 569 (defvar math-exp-str)
 570 (defvar math-exp-old-pos)
 571 (defvar math-exp-token)
 572 (defvar math-exp-keep-spaces)
 573 (defvar math-expr-data)
 574
 575 (defun math-read-exprs (math-exp-str)
 576   (let ((math-exp-pos 0)
 577         (math-exp-old-pos 0)
 578         (math-exp-keep-spaces nil)
 579         math-exp-token math-expr-data)
 580     (setq math-exp-str (math-read-preprocess-string math-exp-str))
 581     (if calc-language-input-filter
 582         (setq math-exp-str (funcall calc-language-input-filter math-exp-str)))
 583     (while (setq math-exp-token (string-match "\\.\\.\\([^.]\\|.[^.]\\)" math-exp-str))
 584       (setq math-exp-str (concat (substring math-exp-str 0 math-exp-token) "\\dots"
 585                             (substring math-exp-str (+ math-exp-token 2)))))
 586     (math-build-parse-table)
 587     (math-read-token)
 588     (let ((val (catch 'syntax (math-read-expr-list))))
 589       (if (stringp val)
 590           (list 'error math-exp-old-pos val)
 591         (if (equal math-exp-token 'end)
 592             val
 593           (list 'error math-exp-old-pos "Syntax error"))))))
 594
 595 (defun math-read-expr-list ()
 596   (let* ((math-exp-keep-spaces nil)
 597          (val (list (math-read-expr-level 0)))
 598          (last val))
 599     (while (equal math-expr-data ",")
 600       (math-read-token)
 601       (let ((rest (list (math-read-expr-level 0))))
 602         (setcdr last rest)
 603         (setq last rest)))
 604     val))
 605
 606 (defvar calc-user-parse-table nil)
 607 (defvar calc-last-main-parse-table nil)
 608 (defvar calc-last-lang-parse-table nil)
 609 (defvar calc-user-tokens nil)
 610 (defvar calc-user-token-chars nil)
 611
 612 (defvar math-toks nil
 613   "Tokens to pass between math-build-parse-table and math-find-user-tokens.")
 614
 615 (defun math-build-parse-table ()
 616   (let ((mtab (cdr (assq nil calc-user-parse-tables)))
 617         (ltab (cdr (assq calc-language calc-user-parse-tables))))
 618     (or (and (eq mtab calc-last-main-parse-table)
 619              (eq ltab calc-last-lang-parse-table))
 620         (let ((p (append mtab ltab))
 621               (math-toks nil))
 622           (setq calc-user-parse-table p)
 623           (setq calc-user-token-chars nil)
 624           (while p
 625             (math-find-user-tokens (car (car p)))
 626             (setq p (cdr p)))
 627           (setq calc-user-tokens (mapconcat 'identity
 628                                             (sort (mapcar 'car math-toks)
 629                                                   (function (lambda (x y)
 630                                                               (> (length x)
 631                                                                  (length y)))))
 632                                             "\\|")
 633                 calc-last-main-parse-table mtab
 634                 calc-last-lang-parse-table ltab)))))
 635
 636 (defun math-find-user-tokens (p)
 637   (while p
 638     (cond ((and (stringp (car p))
 639                 (or (> (length (car p)) 1) (equal (car p) "$")
 640                     (equal (car p) "\""))
 641                 (string-match "[^a-zA-Z0-9]" (car p)))
 642            (let ((s (regexp-quote (car p))))
 643              (if (string-match "\\`[a-zA-Z0-9]" s)
 644                  (setq s (concat "\\<" s)))
 645              (if (string-match "[a-zA-Z0-9]\\'" s)
 646                  (setq s (concat s "\\>")))
 647              (or (assoc s math-toks)
 648                  (progn
 649                    (setq math-toks (cons (list s) math-toks))
 650                    (or (memq (aref (car p) 0) calc-user-token-chars)
 651                        (setq calc-user-token-chars
 652                              (cons (aref (car p) 0)
 653                                    calc-user-token-chars)))))))
 654           ((consp (car p))
 655            (math-find-user-tokens (nth 1 (car p)))
 656            (or (eq (car (car p)) '\?)
 657                (math-find-user-tokens (nth 2 (car p))))))
 658     (setq p (cdr p))))
 659
 660 (defun math-read-token ()
 661   (if (>= math-exp-pos (length math-exp-str))
 662       (setq math-exp-old-pos math-exp-pos
 663             math-exp-token 'end
 664             math-expr-data "\000")
 665     (let ((ch (aref math-exp-str math-exp-pos)))
 666       (setq math-exp-old-pos math-exp-pos)
 667       (cond ((memq ch '(32 10 9))
 668              (setq math-exp-pos (1+ math-exp-pos))
 669              (if math-exp-keep-spaces
 670                  (setq math-exp-token 'space
 671                        math-expr-data " ")
 672                (math-read-token)))
 673             ((and (memq ch calc-user-token-chars)
 674                   (let ((case-fold-search nil))
 675                     (eq (string-match calc-user-tokens math-exp-str math-exp-pos)
 676                         math-exp-pos)))
 677              (setq math-exp-token 'punc
 678                    math-expr-data (math-match-substring math-exp-str 0)
 679                    math-exp-pos (match-end 0)))
 680             ((or (and (>= ch ?a) (<= ch ?z))
 681                  (and (>= ch ?A) (<= ch ?Z)))
 682              (string-match (if (memq calc-language '(c fortran pascal maple))
 683                                "[a-zA-Z0-9_#]*"
 684                              "[a-zA-Z0-9'#]*")
 685                            math-exp-str math-exp-pos)
 686              (setq math-exp-token 'symbol
 687                    math-exp-pos (match-end 0)
 688                    math-expr-data (math-restore-dashes
 689                              (math-match-substring math-exp-str 0)))
 690              (if (eq calc-language 'eqn)
 691                  (let ((code (assoc math-expr-data math-eqn-ignore-words)))
 692                    (cond ((null code))
 693                          ((null (cdr code))
 694                           (math-read-token))
 695                          ((consp (nth 1 code))
 696                           (math-read-token)
 697                           (if (assoc math-expr-data (cdr code))
 698                               (setq math-expr-data (format "%s %s"
 699                                                      (car code) math-expr-data))))
 700                          ((eq (nth 1 code) 'punc)
 701                           (setq math-exp-token 'punc
 702                                 math-expr-data (nth 2 code)))
 703                          (t
 704                           (math-read-token)
 705                           (math-read-token))))))
 706             ((or (and (>= ch ?0) (<= ch ?9))
 707                  (and (eq ch '?\.)
 708                       (eq (string-match "\\.[0-9]" math-exp-str math-exp-pos)
 709                           math-exp-pos))
 710                  (and (eq ch '?_)
 711                       (eq (string-match "_\\.?[0-9]" math-exp-str math-exp-pos)
 712                           math-exp-pos)
 713                       (or (eq math-exp-pos 0)
 714                           (and (memq calc-language '(nil flat big unform
 715                                                          tex latex eqn))
 716                                (eq (string-match "[^])}\"a-zA-Z0-9'$]_"
 717                                                  math-exp-str (1- math-exp-pos))
 718                                    (1- math-exp-pos))))))
 719              (or (and (eq calc-language 'c)
 720                       (string-match "0[xX][0-9a-fA-F]+" math-exp-str math-exp-pos))
 721                  (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]+\\)?\"?\\)?"
 722                                math-exp-str math-exp-pos))
 723              (setq math-exp-token 'number
 724                    math-expr-data (math-match-substring math-exp-str 0)
 725                    math-exp-pos (match-end 0)))
 726             ((eq ch ?\$)
 727              (if (and (eq calc-language 'pascal)
 728                       (eq (string-match
 729                            "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Z]\\)"
 730                            math-exp-str math-exp-pos)
 731                           math-exp-pos))
 732                  (setq math-exp-token 'number
 733                        math-expr-data (math-match-substring math-exp-str 1)
 734                        math-exp-pos (match-end 1))
 735                (if (eq (string-match "\\$\\([1-9][0-9]*\\)" math-exp-str math-exp-pos)
 736                        math-exp-pos)
 737                    (setq math-expr-data (- (string-to-number (math-match-substring
 738                                                      math-exp-str 1))))
 739                  (string-match "\\$+" math-exp-str math-exp-pos)
 740                  (setq math-expr-data (- (match-end 0) (match-beginning 0))))
 741                (setq math-exp-token 'dollar
 742                      math-exp-pos (match-end 0))))
 743             ((eq ch ?\#)
 744              (if (eq (string-match "#\\([1-9][0-9]*\\)" math-exp-str math-exp-pos)
 745                      math-exp-pos)
 746                  (setq math-expr-data (string-to-number
 747                                  (math-match-substring math-exp-str 1))
 748                        math-exp-pos (match-end 0))
 749                (setq math-expr-data 1
 750                      math-exp-pos (1+ math-exp-pos)))
 751              (setq math-exp-token 'hash))
 752             ((eq (string-match "~=\\|<=\\|>=\\|<>\\|/=\\|\\+/-\\|\\\\dots\\|\\\\ldots\\|\\*\\*\\|<<\\|>>\\|==\\|!=\\|&&&\\||||\\|!!!\\|&&\\|||\\|!!\\|:=\\|::\\|=>"
 753                                math-exp-str math-exp-pos)
 754                  math-exp-pos)
 755              (setq math-exp-token 'punc
 756                    math-expr-data (math-match-substring math-exp-str 0)
 757                    math-exp-pos (match-end 0)))
 758             ((and (eq ch ?\")
 759                   (string-match "\\(\"\\([^\"\\]\\|\\\\.\\)*\\)\\(\"\\|\\'\\)"
 760                                 math-exp-str math-exp-pos))
 761              (if (eq calc-language 'eqn)
 762                  (progn
 763                    (setq math-exp-str (copy-sequence math-exp-str))
 764                    (aset math-exp-str (match-beginning 1) ?\{)
 765                    (if (< (match-end 1) (length math-exp-str))
 766                        (aset math-exp-str (match-end 1) ?\}))
 767                    (math-read-token))
 768                (setq math-exp-token 'string
 769                      math-expr-data (math-match-substring math-exp-str 1)
 770                      math-exp-pos (match-end 0))))
 771             ((and (= ch ?\\) (eq calc-language 'tex)
 772                   (< math-exp-pos (1- (length math-exp-str))))
 773              (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}"
 774                                math-exp-str math-exp-pos)
 775                  (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)"
 776                                math-exp-str math-exp-pos))
 777              (setq math-exp-token 'symbol
 778                    math-exp-pos (match-end 0)
 779                    math-expr-data (math-restore-dashes
 780                              (math-match-substring math-exp-str 1)))
 781              (let ((code (assoc math-expr-data math-latex-ignore-words)))
 782                (cond ((null code))
 783                      ((null (cdr code))
 784                       (math-read-token))
 785                      ((eq (nth 1 code) 'punc)
 786                       (setq math-exp-token 'punc
 787                             math-expr-data (nth 2 code)))
 788                       ((and (eq (nth 1 code) 'mat)
 789                             (string-match " *{" math-exp-str math-exp-pos))
 790                       (setq math-exp-pos (match-end 0)
 791                             math-exp-token 'punc
 792                             math-expr-data "[")
 793                       (let ((right (string-match "}" math-exp-str math-exp-pos)))
 794                         (and right
 795                              (setq math-exp-str (copy-sequence math-exp-str))
 796                              (aset math-exp-str right ?\])))))))
 797             ((and (= ch ?\\) (eq calc-language 'latex)
 798                   (< math-exp-pos (1- (length math-exp-str))))
 799              (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}"
 800                                math-exp-str math-exp-pos)
 801                  (string-match "\\\\text *{\\([a-zA-Z0-9]+\\)}"
 802                                math-exp-str math-exp-pos)
 803                  (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)"
 804                                math-exp-str math-exp-pos))
 805              (setq math-exp-token 'symbol
 806                    math-exp-pos (match-end 0)
 807                    math-expr-data (math-restore-dashes
 808                              (math-match-substring math-exp-str 1)))
 809              (let ((code (assoc math-expr-data math-tex-ignore-words))
 810                    envname)
 811                (cond ((null code))
 812                      ((null (cdr code))
 813                       (math-read-token))
 814                      ((eq (nth 1 code) 'punc)
 815                       (setq math-exp-token 'punc
 816                             math-expr-data (nth 2 code)))
 817                      ((and (eq (nth 1 code) 'begenv)
 818                            (string-match " *{\\([^}]*\\)}" math-exp-str math-exp-pos))
 819                       (setq math-exp-pos (match-end 0)
 820                             envname (match-string 1 math-exp-str)
 821                             math-exp-token 'punc
 822                             math-expr-data "[")
 823                       (cond ((or (string= envname "matrix")
 824                                  (string= envname "bmatrix")
 825                                  (string= envname "smallmatrix")
 826                                  (string= envname "pmatrix"))
 827                              (if (string-match (concat "\\\\end{" envname "}")
 828                                                math-exp-str math-exp-pos)
 829                                  (setq math-exp-str
 830                                        (replace-match "]" t t math-exp-str))
 831                                (error "%s" (concat "No closing \\end{" envname "}"))))))
 832                       ((and (eq (nth 1 code) 'mat)
 833                             (string-match " *{" math-exp-str math-exp-pos))
 834                       (setq math-exp-pos (match-end 0)
 835                             math-exp-token 'punc
 836                             math-expr-data "[")
 837                       (let ((right (string-match "}" math-exp-str math-exp-pos)))
 838                         (and right
 839                              (setq math-exp-str (copy-sequence math-exp-str))
 840                              (aset math-exp-str right ?\])))))))
 841             ((and (= ch ?\.) (eq calc-language 'fortran)
 842                   (eq (string-match "\\.[a-zA-Z][a-zA-Z][a-zA-Z]?\\."
 843                                     math-exp-str math-exp-pos) math-exp-pos))
 844              (setq math-exp-token 'punc
 845                    math-expr-data (upcase (math-match-substring math-exp-str 0))
 846                    math-exp-pos (match-end 0)))
 847             ((and (eq calc-language 'math)
 848                   (eq (string-match "\\[\\[\\|->\\|:>" math-exp-str math-exp-pos)
 849                       math-exp-pos))
 850              (setq math-exp-token 'punc
 851                    math-expr-data (math-match-substring math-exp-str 0)
 852                    math-exp-pos (match-end 0)))
 853             ((and (eq calc-language 'eqn)
 854                   (eq (string-match "->\\|<-\\|+-\\|\\\\dots\\|~\\|\\^"
 855                                     math-exp-str math-exp-pos)
 856                       math-exp-pos))
 857              (setq math-exp-token 'punc
 858                    math-expr-data (math-match-substring math-exp-str 0)
 859                    math-exp-pos (match-end 0))
 860              (and (eq (string-match "\\\\dots\\." math-exp-str math-exp-pos)
 861                       math-exp-pos)
 862                   (setq math-exp-pos (match-end 0)))
 863              (if (memq (aref math-expr-data 0) '(?~ ?^))
 864                  (math-read-token)))
 865             ((eq (string-match "%%.*$" math-exp-str math-exp-pos) math-exp-pos)
 866              (setq math-exp-pos (match-end 0))
 867              (math-read-token))
 868             (t
 869              (if (and (eq ch ?\{) (memq calc-language '(tex latex eqn)))
 870                  (setq ch ?\())
 871              (if (and (eq ch ?\}) (memq calc-language '(tex latex eqn)))
 872                  (setq ch ?\)))
 873              (if (and (eq ch ?\&) (memq calc-language '(tex latex)))
 874                  (setq ch ?\,))
 875              (setq math-exp-token 'punc
 876                    math-expr-data (char-to-string ch)
 877                    math-exp-pos (1+ math-exp-pos)))))))
 878
 879 (defconst math-alg-inequalities
 880   '(calcFunc-lt calcFunc-gt calcFunc-leq calcFunc-geq
 881                 calcFunc-eq calcFunc-neq))
 882
 883 (defun math-read-expr-level (exp-prec &optional exp-term)
 884   (let* ((x (math-read-factor)) (first t) op op2)
 885     (while (and (or (and calc-user-parse-table
 886                          (setq op (calc-check-user-syntax x exp-prec))
 887                          (setq x op
 888                                op '("2x" ident 999999 -1)))
 889                     (and (setq op (assoc math-expr-data math-expr-opers))
 890                          (/= (nth 2 op) -1)
 891                          (or (and (setq op2 (assoc
 892                                              math-expr-data
 893                                              (cdr (memq op math-expr-opers))))
 894                                   (eq (= (nth 3 op) -1)
 895                                       (/= (nth 3 op2) -1))
 896                                   (eq (= (nth 3 op2) -1)
 897                                       (not (math-factor-after)))
 898                                   (setq op op2))
 899                              t))
 900                     (and (or (eq (nth 2 op) -1)
 901                              (memq math-exp-token '(symbol number dollar hash))
 902                              (equal math-expr-data "(")
 903                              (and (equal math-expr-data "[")
 904                                   (not (eq calc-language 'math))
 905                                   (not (and math-exp-keep-spaces
 906                                             (eq (car-safe x) 'vec)))))
 907                          (or (not (setq op (assoc math-expr-data math-expr-opers)))
 908                              (/= (nth 2 op) -1))
 909                          (or (not calc-user-parse-table)
 910                              (not (eq math-exp-token 'symbol))
 911                              (let ((p calc-user-parse-table))
 912                                (while (and p
 913                                            (or (not (integerp
 914                                                      (car (car (car p)))))
 915                                                (not (equal
 916                                                      (nth 1 (car (car p)))
 917                                                      math-expr-data))))
 918                                  (setq p (cdr p)))
 919                                (not p)))
 920                          (setq op (assoc "2x" math-expr-opers))))
 921                 (not (and exp-term (equal math-expr-data exp-term)))
 922                 (>= (nth 2 op) exp-prec))
 923       (if (not (equal (car op) "2x"))
 924           (math-read-token))
 925       (and (memq (nth 1 op) '(sdev mod))
 926            (require 'calc-ext))
 927       (setq x (cond ((consp (nth 1 op))
 928                      (funcall (car (nth 1 op)) x op))
 929                     ((eq (nth 3 op) -1)
 930                      (if (eq (nth 1 op) 'ident)
 931                          x
 932                        (if (eq (nth 1 op) 'closing)
 933                            (if (eq (nth 2 op) exp-prec)
 934                                (progn
 935                                  (setq exp-prec 1000)
 936                                  x)
 937                              (throw 'syntax "Mismatched delimiters"))
 938                          (list (nth 1 op) x))))
 939                     ((and (not first)
 940                           (memq (nth 1 op) math-alg-inequalities)
 941                           (memq (car-safe x) math-alg-inequalities))
 942                      (require 'calc-ext)
 943                      (math-composite-inequalities x op))
 944                     (t (list (nth 1 op)
 945                              x
 946                              (math-read-expr-level (nth 3 op) exp-term))))
 947             first nil))
 948     x))
 949
 950 ;; calc-arg-values is defined in calc-ext.el, but is used here.
 951 (defvar calc-arg-values)
 952
 953 (defun calc-check-user-syntax (&optional x prec)
 954   (let ((p calc-user-parse-table)
 955         (matches nil)
 956         match rule)
 957     (while (and p
 958                 (or (not (progn
 959                            (setq rule (car (car p)))
 960                            (if x
 961                                (and (integerp (car rule))
 962                                     (>= (car rule) prec)
 963                                     (equal math-expr-data
 964                                            (car (setq rule (cdr rule)))))
 965                              (equal math-expr-data (car rule)))))
 966                     (let ((save-exp-pos math-exp-pos)
 967                           (save-exp-old-pos math-exp-old-pos)
 968                           (save-exp-token math-exp-token)
 969                           (save-exp-data math-expr-data))
 970                       (or (not (listp
 971                                 (setq matches (calc-match-user-syntax rule))))
 972                           (let ((args (progn
 973                                         (require 'calc-ext)
 974                                         calc-arg-values))
 975                                 (conds nil)
 976                                 temp)
 977                             (if x
 978                                 (setq matches (cons x matches)))
 979                             (setq match (cdr (car p)))
 980                             (while (and (eq (car-safe match)
 981                                             'calcFunc-condition)
 982                                         (= (length match) 3))
 983                               (setq conds (append (math-flatten-lands
 984                                                    (nth 2 match))
 985                                                   conds)
 986                                     match (nth 1 match)))
 987                             (while (and conds match)
 988                               (require 'calc-ext)
 989                               (cond ((eq (car-safe (car conds))
 990                                          'calcFunc-let)
 991                                      (setq temp (car conds))
 992                                      (or (= (length temp) 3)
 993                                          (and (= (length temp) 2)
 994                                               (eq (car-safe (nth 1 temp))
 995                                                   'calcFunc-assign)
 996                                               (= (length (nth 1 temp)) 3)
 997                                               (setq temp (nth 1 temp)))
 998                                          (setq match nil))
 999                                      (setq matches (cons
1000                                                     (math-normalize
1001                                                      (math-multi-subst
1002                                                       (nth 2 temp)
1003                                                       args matches))
1004                                                     matches)
1005                                            args (cons (nth 1 temp)
1006                                                       args)))
1007                                     ((and (eq (car-safe (car conds))
1008                                               'calcFunc-matches)
1009                                           (= (length (car conds)) 3))
1010                                      (setq temp (calcFunc-vmatches
1011                                                  (math-multi-subst
1012                                                   (nth 1 (car conds))
1013                                                   args matches)
1014                                                  (nth 2 (car conds))))
1015                                      (if (eq temp 0)
1016                                          (setq match nil)
1017                                        (while (setq temp (cdr temp))
1018                                          (setq matches (cons (nth 2 (car temp))
1019                                                              matches)
1020                                                args (cons (nth 1 (car temp))
1021                                                           args)))))
1022                                     (t
1023                                      (or (math-is-true (math-simplify
1024                                                         (math-multi-subst
1025                                                          (car conds)
1026                                                          args matches)))
1027                                          (setq match nil))))
1028                               (setq conds (cdr conds)))
1029                             (if match
1030                                 (not (setq match (math-multi-subst
1031                                                   match args matches)))
1032                               (setq math-exp-old-pos save-exp-old-pos
1033                                     math-exp-token save-exp-token
1034                                     math-expr-data save-exp-data
1035                                     math-exp-pos save-exp-pos)))))))
1036       (setq p (cdr p)))
1037     (and p match)))
1038
1039 (defun calc-match-user-syntax (p &optional term)
1040   (let ((matches nil)
1041         (save-exp-pos math-exp-pos)
1042         (save-exp-old-pos math-exp-old-pos)
1043         (save-exp-token math-exp-token)
1044         (save-exp-data math-expr-data)
1045         m)
1046     (while (and p
1047                 (cond ((stringp (car p))
1048                        (and (equal math-expr-data (car p))
1049                             (progn
1050                               (math-read-token)
1051                               t)))
1052                       ((integerp (car p))
1053                        (and (setq m (catch 'syntax
1054                                       (math-read-expr-level
1055                                        (car p)
1056                                        (if (cdr p)
1057                                            (if (consp (nth 1 p))
1058                                                (car (nth 1 (nth 1 p)))
1059                                              (nth 1 p))
1060                                          term))))
1061                             (not (stringp m))
1062                             (setq matches (nconc matches (list m)))))
1063                       ((eq (car (car p)) '\?)
1064                        (setq m (calc-match-user-syntax (nth 1 (car p))))
1065                        (or (nth 2 (car p))
1066                            (setq matches
1067                                  (nconc matches
1068                                         (list
1069                                          (cons 'vec (and (listp m) m))))))
1070                        (or (listp m) (not (nth 2 (car p)))
1071                            (not (eq (aref (car (nth 2 (car p))) 0) ?\$))
1072                            (eq math-exp-token 'end)))
1073                       (t
1074                        (setq m (calc-match-user-syntax (nth 1 (car p))
1075                                                        (car (nth 2 (car p)))))
1076                        (if (listp m)
1077                            (let ((vec (cons 'vec m))
1078                                  opos mm)
1079                              (while (and (listp
1080                                           (setq opos math-exp-pos
1081                                                 mm (calc-match-user-syntax
1082                                                     (or (nth 2 (car p))
1083                                                         (nth 1 (car p)))
1084                                                     (car (nth 2 (car p))))))
1085                                          (> math-exp-pos opos))
1086                                (setq vec (nconc vec mm)))
1087                              (setq matches (nconc matches (list vec))))
1088                          (and (eq (car (car p)) '*)
1089                               (setq matches (nconc matches (list '(vec)))))))))
1090       (setq p (cdr p)))
1091     (if p
1092         (setq math-exp-pos save-exp-pos
1093               math-exp-old-pos save-exp-old-pos
1094               math-exp-token save-exp-token
1095               math-expr-data save-exp-data
1096               matches "Failed"))
1097     matches))
1098
1099 (defun math-remove-dashes (x)
1100   (if (string-match "\\`\\(.*\\)-\\(.*\\)\\'" x)
1101       (math-remove-dashes
1102        (concat (math-match-substring x 1) "#" (math-match-substring x 2)))
1103     x))
1104
1105 (defun math-restore-dashes (x)
1106   (if (string-match "\\`\\(.*\\)[#_]\\(.*\\)\\'" x)
1107       (math-restore-dashes
1108        (concat (math-match-substring x 1) "-" (math-match-substring x 2)))
1109     x))
1110
1111 (defun math-read-if (cond op)
1112   (let ((then (math-read-expr-level 0)))
1113     (or (equal math-expr-data ":")
1114         (throw 'syntax "Expected ':'"))
1115     (math-read-token)
1116     (list 'calcFunc-if cond then (math-read-expr-level (nth 3 op)))))
1117
1118 (defun math-factor-after ()
1119   (let ((math-exp-pos math-exp-pos)
1120         math-exp-old-pos math-exp-token math-expr-data)
1121     (math-read-token)
1122     (or (memq math-exp-token '(number symbol dollar hash string))
1123         (and (assoc math-expr-data '(("-") ("+") ("!") ("|") ("/")))
1124              (assoc (concat "u" math-expr-data) math-expr-opers))
1125         (eq (nth 2 (assoc math-expr-data math-expr-opers)) -1)
1126         (assoc math-expr-data '(("(") ("[") ("{"))))))
1127
1128 (defun math-read-factor ()
1129   (let (op)
1130     (cond ((eq math-exp-token 'number)
1131            (let ((num (math-read-number math-expr-data)))
1132              (if (not num)
1133                  (progn
1134                    (setq math-exp-old-pos math-exp-pos)
1135                    (throw 'syntax "Bad format")))
1136              (math-read-token)
1137              (if (and math-read-expr-quotes
1138                       (consp num))
1139                  (list 'quote num)
1140                num)))
1141           ((and calc-user-parse-table
1142                 (setq op (calc-check-user-syntax)))
1143            op)
1144           ((or (equal math-expr-data "-")
1145                (equal math-expr-data "+")
1146                (equal math-expr-data "!")
1147                (equal math-expr-data "|")
1148                (equal math-expr-data "/"))
1149            (setq math-expr-data (concat "u" math-expr-data))
1150            (math-read-factor))
1151           ((and (setq op (assoc math-expr-data math-expr-opers))
1152                 (eq (nth 2 op) -1))
1153            (if (consp (nth 1 op))
1154                (funcall (car (nth 1 op)) op)
1155              (math-read-token)
1156              (let ((val (math-read-expr-level (nth 3 op))))
1157                (cond ((eq (nth 1 op) 'ident)
1158                       val)
1159                      ((and (Math-numberp val)
1160                            (equal (car op) "u-"))
1161                       (math-neg val))
1162                      (t (list (nth 1 op) val))))))
1163           ((eq math-exp-token 'symbol)
1164            (let ((sym (intern math-expr-data)))
1165              (math-read-token)
1166              (if (equal math-expr-data calc-function-open)
1167                  (let ((f (assq sym math-expr-function-mapping)))
1168                    (math-read-token)
1169                    (if (consp (cdr f))
1170                        (funcall (car (cdr f)) f sym)
1171                      (let ((args (if (or (equal math-expr-data calc-function-close)
1172                                          (eq math-exp-token 'end))
1173                                      nil
1174                                    (math-read-expr-list))))
1175                        (if (not (or (equal math-expr-data calc-function-close)
1176                                     (eq math-exp-token 'end)))
1177                            (throw 'syntax "Expected `)'"))
1178                        (math-read-token)
1179                        (if (and (eq calc-language 'fortran) args
1180                                 (require 'calc-ext)
1181                                 (let ((calc-matrix-mode 'scalar))
1182                                   (math-known-matrixp
1183                                    (list 'var sym
1184                                          (intern
1185                                           (concat "var-"
1186                                                   (symbol-name sym)))))))
1187                            (math-parse-fortran-subscr sym args)
1188                          (if f
1189                              (setq sym (cdr f))
1190                            (and (= (aref (symbol-name sym) 0) ?\\)
1191                                 (< (prefix-numeric-value calc-language-option)
1192                                    0)
1193                                 (setq sym (intern (substring (symbol-name sym)
1194                                                              1))))
1195                            (or (string-match "-" (symbol-name sym))
1196                                (setq sym (intern
1197                                           (concat "calcFunc-"
1198                                                   (symbol-name sym))))))
1199                          (cons sym args)))))
1200                (if math-read-expr-quotes
1201                    sym
1202                  (let ((val (list 'var
1203                                   (intern (math-remove-dashes
1204                                            (symbol-name sym)))
1205                                   (if (string-match "-" (symbol-name sym))
1206                                       sym
1207                                     (intern (concat "var-"
1208                                                     (symbol-name sym)))))))
1209                    (let ((v (assq (nth 1 val) math-expr-variable-mapping)))
1210                      (and v (setq val (if (consp (cdr v))
1211                                           (funcall (car (cdr v)) v val)
1212                                         (list 'var
1213                                               (intern
1214                                                (substring (symbol-name (cdr v))
1215                                                           4))
1216                                               (cdr v))))))
1217                    (while (and (memq calc-language '(c pascal maple))
1218                                (equal math-expr-data "["))
1219                      (math-read-token)
1220                      (setq val (append (list 'calcFunc-subscr val)
1221                                        (math-read-expr-list)))
1222                      (if (equal math-expr-data "]")
1223                          (math-read-token)
1224                        (throw 'syntax "Expected ']'")))
1225                    val)))))
1226           ((eq math-exp-token 'dollar)
1227            (let ((abs (if (> math-expr-data 0) math-expr-data (- math-expr-data))))
1228              (if (>= (length calc-dollar-values) abs)
1229                  (let ((num math-expr-data))
1230                    (math-read-token)
1231                    (setq calc-dollar-used (max calc-dollar-used num))
1232                    (math-check-complete (nth (1- abs) calc-dollar-values)))
1233                (throw 'syntax (if calc-dollar-values
1234                                   "Too many $'s"
1235                                 "$'s not allowed in this context")))))
1236           ((eq math-exp-token 'hash)
1237            (or calc-hashes-used
1238                (throw 'syntax "#'s not allowed in this context"))
1239            (require 'calc-ext)
1240            (if (<= math-expr-data (length calc-arg-values))
1241                (let ((num math-expr-data))
1242                  (math-read-token)
1243                  (setq calc-hashes-used (max calc-hashes-used num))
1244                  (nth (1- num) calc-arg-values))
1245              (throw 'syntax "Too many # arguments")))
1246           ((equal math-expr-data "(")
1247            (let* ((exp (let ((math-exp-keep-spaces nil))
1248                          (math-read-token)
1249                          (if (or (equal math-expr-data "\\dots")
1250                                  (equal math-expr-data "\\ldots"))
1251                              '(neg (var inf var-inf))
1252                            (math-read-expr-level 0)))))
1253              (let ((math-exp-keep-spaces nil))
1254                (cond
1255                 ((equal math-expr-data ",")
1256                  (progn
1257                    (math-read-token)
1258                    (let ((exp2 (math-read-expr-level 0)))
1259                      (setq exp
1260                            (if (and exp2 (Math-realp exp) (Math-realp exp2))
1261                                (math-normalize (list 'cplx exp exp2))
1262                              (list '+ exp (list '* exp2 '(var i var-i))))))))
1263                 ((equal math-expr-data ";")
1264                  (progn
1265                    (math-read-token)
1266                    (let ((exp2 (math-read-expr-level 0)))
1267                      (setq exp (if (and exp2 (Math-realp exp)
1268                                         (Math-anglep exp2))
1269                                    (math-normalize (list 'polar exp exp2))
1270                                  (require 'calc-ext)
1271                                  (list '* exp
1272                                        (list 'calcFunc-exp
1273                                              (list '*
1274                                                    (math-to-radians-2 exp2)
1275                                                    '(var i var-i)))))))))
1276                 ((or (equal math-expr-data "\\dots")
1277                      (equal math-expr-data "\\ldots"))
1278                  (progn
1279                    (math-read-token)
1280                    (let ((exp2 (if (or (equal math-expr-data ")")
1281                                        (equal math-expr-data "]")
1282                                        (eq math-exp-token 'end))
1283                                    '(var inf var-inf)
1284                                  (math-read-expr-level 0))))
1285                      (setq exp
1286                            (list 'intv
1287                                  (if (equal math-expr-data ")") 0 1)
1288                                  exp
1289                                  exp2)))))))
1290              (if (not (or (equal math-expr-data ")")
1291                           (and (equal math-expr-data "]") (eq (car-safe exp) 'intv))
1292                           (eq math-exp-token 'end)))
1293                  (throw 'syntax "Expected `)'"))
1294              (math-read-token)
1295              exp))
1296           ((eq math-exp-token 'string)
1297            (require 'calc-ext)
1298            (math-read-string))
1299           ((equal math-expr-data "[")
1300            (require 'calc-ext)
1301            (math-read-brackets t "]"))
1302           ((equal math-expr-data "{")
1303            (require 'calc-ext)
1304            (math-read-brackets nil "}"))
1305           ((equal math-expr-data "<")
1306            (require 'calc-ext)
1307            (math-read-angle-brackets))
1308           (t (throw 'syntax "Expected a number")))))
1309
1310 (provide 'calc-aent)
1311
1312 ;;; arch-tag: 5599e45d-e51e-44bb-9a20-9f4ed8c96c32
1313 ;;; calc-aent.el ends here