home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume24 / gnucalc / part19 < prev    next >
Encoding:
Text File  |  1991-10-31  |  55.3 KB  |  1,776 lines

  1. Newsgroups: comp.sources.misc
  2. From: daveg@synaptics.com (David Gillespie)
  3. Subject:  v24i067:  gnucalc - GNU Emacs Calculator, v2.00, Part19/56
  4. Message-ID: <1991Oct31.072559.17839@sparky.imd.sterling.com>
  5. X-Md4-Signature: c17169ce2fe78b8fee5f579d2932282f
  6. Date: Thu, 31 Oct 1991 07:25:59 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: daveg@synaptics.com (David Gillespie)
  10. Posting-number: Volume 24, Issue 67
  11. Archive-name: gnucalc/part19
  12. Environment: Emacs
  13. Supersedes: gmcalc: Volume 13, Issue 27-45
  14.  
  15. ---- Cut Here and unpack ----
  16. #!/bin/sh
  17. # this is Part.19 (part 19 of a multipart archive)
  18. # do not concatenate these parts, unpack them in order with /bin/sh
  19. # file calc-keypd.el continued
  20. #
  21. if test ! -r _shar_seq_.tmp; then
  22.     echo 'Please unpack part 1 first!'
  23.     exit 1
  24. fi
  25. (read Scheck
  26.  if test "$Scheck" != 19; then
  27.     echo Please unpack part "$Scheck" next!
  28.     exit 1
  29.  else
  30.     exit 0
  31.  fi
  32. ) < _shar_seq_.tmp || exit 1
  33. if test ! -f _shar_wnt_.tmp; then
  34.     echo 'x - still skipping calc-keypd.el'
  35. else
  36. echo 'x - continuing file calc-keypd.el'
  37. sed 's/^X//' << 'SHAR_EOF' >> 'calc-keypd.el' &&
  38. X           calc-word-size) calc-word-size )
  39. X       ( "ARSH"  calc-rshift-arith ) )
  40. X     ( ( "A"     ("A") )
  41. X       ( "B"     ("B") )
  42. X       ( "C"     ("C") )
  43. X       ( "D"     ("D") )
  44. X       ( "E"     ("E") )
  45. X       ( "F"     ("F") ) ) )
  46. )
  47. X
  48. ;;; |----+----+----+----+----+----|
  49. ;;; |SUM |PROD|MAX |MAP*|MAP^|MAP$|
  50. ;;; |----+----+----+----+----+----|
  51. ;;; |INV |DET |TRN |IDNT|CRSS|"x" |
  52. ;;; |----+----+----+----+----+----|
  53. ;;; |PACK|UNPK|INDX|BLD |LEN |... |
  54. X
  55. (defvar calc-keypad-vector-menu
  56. X  '( ( ( "SUM"   calc-vector-sum calc-vector-alt-sum calc-vector-mean )
  57. X       ( "PROD"  calc-vector-product nil calc-vector-sdev )
  58. X       ( "MAX"   calc-vector-max calc-vector-min )
  59. X       ( "MAP*"  (lambda () (interactive)
  60. X           (calc-map '(2 calcFunc-mul "*"))) )
  61. X       ( "MAP^"  (lambda () (interactive)
  62. X           (calc-map '(2 calcFunc-pow "^"))) )
  63. X       ( "MAP$"  calc-map-stack ) )
  64. X     ( ( "MINV"  calc-inv )
  65. X       ( "MDET"  calc-mdet )
  66. X       ( "MTRN"  calc-transpose calc-conj-transpose )
  67. X       ( "IDNT"  (progn calc-num-prefix calc-ident) )
  68. X       ( "CRSS"  calc-cross )
  69. X       ( "\"x\"" "\excalc-algebraic-entry\rx\r"
  70. X             "\excalc-algebraic-entry\ry\r"
  71. X         "\excalc-algebraic-entry\rz\r"
  72. X         "\excalc-algebraic-entry\rt\r") )
  73. X     ( ( "PACK"  calc-pack )
  74. X       ( "UNPK"  calc-unpack )
  75. X       ( "INDX"  (progn calc-num-prefix calc-index) "\C-u\excalc-index\r" )
  76. X       ( "BLD"   (progn calc-num-prefix calc-build-vector) )
  77. X       ( "LEN"   calc-vlength )
  78. X       ( "..."   calc-full-vectors ) ) )
  79. )
  80. X
  81. ;;; |----+----+----+----+----+----|
  82. ;;; |FLT |FIX |SCI |ENG |GRP |    |
  83. ;;; |----+----+----+----+----+----|
  84. ;;; |RAD |DEG |FRAC|POLR|SYMB|PREC|
  85. ;;; |----+----+----+----+----+----|
  86. ;;; |SWAP|RLL3|RLL4|OVER|STO |RCL |
  87. X
  88. (defvar calc-keypad-modes-menu
  89. X  '( ( ( "FLT"   calc-normal-notation )
  90. X       ( "FIX"   calc-fix-notation )
  91. X       ( "SCI"   calc-sci-notation )
  92. X       ( "ENG"   calc-eng-notation )
  93. X       ( "GRP"   calc-group-digits "\C-u-3\excalc-group-digits\r" )
  94. X       ( ""     nil ) )
  95. X     ( ( "RAD"   calc-radians-mode )
  96. X       ( "DEG"   calc-degrees-mode )
  97. X       ( "FRAC"  calc-frac-mode )
  98. X       ( "POLR"  calc-polar-mode )
  99. X       ( "SYMB"     calc-symbolic-mode )
  100. X       ( "PREC"  calc-precision ) )
  101. X     ( ( "SWAP"  calc-roll-down )
  102. X       ( "RLL3"  (progn 3 calc-roll-up) (progn 3 calc-roll-down) )
  103. X       ( "RLL4"  (progn 4 calc-roll-up) (progn 4 calc-roll-down) )
  104. X       ( "OVER"  calc-over )
  105. X       ( "STO"   calc-keypad-store )
  106. X       ( "RCL"   calc-keypad-recall ) ) )
  107. )
  108. X
  109. SHAR_EOF
  110. echo 'File calc-keypd.el is complete' &&
  111. chmod 0644 calc-keypd.el ||
  112. echo 'restore of calc-keypd.el failed'
  113. Wc_c="`wc -c < 'calc-keypd.el'`"
  114. test 22155 -eq "$Wc_c" ||
  115.     echo 'calc-keypd.el: original size 22155, current size' "$Wc_c"
  116. rm -f _shar_wnt_.tmp
  117. fi
  118. # ============= calc-lang.el ==============
  119. if test -f 'calc-lang.el' -a X"$1" != X"-c"; then
  120.     echo 'x - skipping calc-lang.el (File already exists)'
  121.     rm -f _shar_wnt_.tmp
  122. else
  123. > _shar_wnt_.tmp
  124. echo 'x - extracting calc-lang.el (Text)'
  125. sed 's/^X//' << 'SHAR_EOF' > 'calc-lang.el' &&
  126. ;; Calculator for GNU Emacs, part II [calc-lang.el]
  127. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  128. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  129. X
  130. ;; This file is part of GNU Emacs.
  131. X
  132. ;; GNU Emacs is distributed in the hope that it will be useful,
  133. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  134. ;; accepts responsibility to anyone for the consequences of using it
  135. ;; or for whether it serves any particular purpose or works at all,
  136. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  137. ;; License for full details.
  138. X
  139. ;; Everyone is granted permission to copy, modify and redistribute
  140. ;; GNU Emacs, but only under the conditions described in the
  141. ;; GNU Emacs General Public License.   A copy of this license is
  142. ;; supposed to have been given to you along with GNU Emacs so you
  143. ;; can know your rights and responsibilities.  It should be in a
  144. ;; file named COPYING.  Among other things, the copyright notice
  145. ;; and this notice must be preserved on all copies.
  146. X
  147. X
  148. X
  149. ;; This file is autoloaded from calc-ext.el.
  150. (require 'calc-ext)
  151. X
  152. (require 'calc-macs)
  153. X
  154. (defun calc-Need-calc-lang () nil)
  155. X
  156. X
  157. ;;; Alternate entry/display languages.
  158. X
  159. (defun calc-set-language (lang &optional option no-refresh)
  160. X  (setq math-expr-opers (or (get lang 'math-oper-table) math-standard-opers)
  161. X    math-expr-function-mapping (get lang 'math-function-table)
  162. X    math-expr-variable-mapping (get lang 'math-variable-table)
  163. X    calc-language-input-filter (get lang 'math-input-filter)
  164. X    calc-language-output-filter (get lang 'math-output-filter)
  165. X    calc-vector-brackets (or (get lang 'math-vector-brackets) "[]")
  166. X    calc-complex-format (get lang 'math-complex-format)
  167. X    calc-radix-formatter (get lang 'math-radix-formatter)
  168. X    calc-function-open (or (get lang 'math-function-open) "(")
  169. X    calc-function-close (or (get lang 'math-function-close) ")"))
  170. X  (if no-refresh
  171. X      (setq calc-language lang
  172. X        calc-language-option option)
  173. X    (calc-change-mode '(calc-language calc-language-option)
  174. X              (list lang option) t))
  175. )
  176. X
  177. (defun calc-normal-language ()
  178. X  (interactive)
  179. X  (calc-wrapper
  180. X   (calc-set-language nil)
  181. X   (message "Normal language mode."))
  182. )
  183. X
  184. (defun calc-flat-language ()
  185. X  (interactive)
  186. X  (calc-wrapper
  187. X   (calc-set-language 'flat)
  188. X   (message "Flat language mode (all stack entries shown on one line)."))
  189. )
  190. X
  191. (defun calc-big-language ()
  192. X  (interactive)
  193. X  (calc-wrapper
  194. X   (calc-set-language 'big)
  195. X   (message "\"Big\" language mode."))
  196. )
  197. X
  198. (defun calc-unformatted-language ()
  199. X  (interactive)
  200. X  (calc-wrapper
  201. X   (calc-set-language 'unform)
  202. X   (message "Unformatted language mode."))
  203. )
  204. X
  205. X
  206. (defun calc-c-language ()
  207. X  (interactive)
  208. X  (calc-wrapper
  209. X   (calc-set-language 'c)
  210. X   (message "`C' language mode."))
  211. )
  212. X
  213. (put 'c 'math-oper-table
  214. X  '( ( "u+"    ident         -1 1000 )
  215. X     ( "u-"    neg         -1 1000 )
  216. X     ( "u!"    calcFunc-lnot -1 1000 )
  217. X     ( "~"     calcFunc-not  -1 1000 )
  218. X     ( "*"     *         190 191 )
  219. X     ( "/"     /         190 191 )
  220. X     ( "%"     %         190 191 )
  221. X     ( "+"     +         180 181 )
  222. X     ( "-"     -         180 181 )
  223. X     ( "<<"    calcFunc-lsh  170 171 )
  224. X     ( ">>"    calcFunc-rsh  170 171 )
  225. X     ( "<"     calcFunc-lt   160 161 )
  226. X     ( ">"     calcFunc-gt   160 161 )
  227. X     ( "<="    calcFunc-leq  160 161 )
  228. X     ( ">="    calcFunc-geq  160 161 )
  229. X     ( "=="    calcFunc-eq   150 151 )
  230. X     ( "!="    calcFunc-neq  150 151 )
  231. X     ( "&"     calcFunc-and  140 141 )
  232. X     ( "^"     calcFunc-xor  131 130 )
  233. X     ( "|"     calcFunc-or   120 121 )
  234. X     ( "&&"    calcFunc-land 110 111 )
  235. X     ( "||"    calcFunc-lor  100 101 )
  236. X     ( "?"     (math-read-if)  91  90 )
  237. X     ( "!!!"   calcFunc-pnot  -1  88 )
  238. X     ( "&&&"   calcFunc-pand  85  86 )
  239. X     ( "|||"   calcFunc-por   75  76 )
  240. X     ( "="     calcFunc-assign 51 50 )
  241. X     ( ":="    calcFunc-assign 51 50 )
  242. X     ( "::"    calcFunc-condition 45 46 )
  243. )) ; should support full assignments
  244. X
  245. (put 'c 'math-function-table
  246. X  '( ( acos       . calcFunc-arccos )
  247. X     ( acosh       . calcFunc-arccosh )
  248. X     ( asin       . calcFunc-arcsin )
  249. X     ( asinh       . calcFunc-arcsinh )
  250. X     ( atan       . calcFunc-arctan )
  251. X     ( atan2       . calcFunc-arctan2 )
  252. X     ( atanh       . calcFunc-arctanh )
  253. ))
  254. X
  255. (put 'c 'math-variable-table
  256. X  '( ( M_PI       . var-pi )
  257. X     ( M_E       . var-e )
  258. ))
  259. X
  260. (put 'c 'math-vector-brackets "{}")
  261. X
  262. (put 'c 'math-radix-formatter
  263. X     (function (lambda (r s)
  264. X         (if (= r 16) (format "0x%s" s)
  265. X           (if (= r 8) (format "0%s" s)
  266. X             (format "%d#%s" r s))))))
  267. X
  268. X
  269. (defun calc-pascal-language (n)
  270. X  (interactive "P")
  271. X  (calc-wrapper
  272. X   (and n (setq n (prefix-numeric-value n)))
  273. X   (calc-set-language 'pascal n)
  274. X   (message (if (and n (/= n 0))
  275. X        (if (> n 0)
  276. X            "Pascal language mode (all uppercase)."
  277. X          "Pascal language mode (all lowercase).")
  278. X          "Pascal language mode.")))
  279. )
  280. X
  281. (put 'pascal 'math-oper-table
  282. X  '( ( "not"   calcFunc-lnot -1 1000 )
  283. X     ( "*"     *         190 191 )
  284. X     ( "/"     /         190 191 )
  285. X     ( "and"   calcFunc-and  190 191 )
  286. X     ( "div"   calcFunc-idiv 190 191 )
  287. X     ( "mod"   %         190 191 )
  288. X     ( "u+"    ident         -1  185 )
  289. X     ( "u-"    neg         -1  185 )
  290. X     ( "+"     +         180 181 )
  291. X     ( "-"     -         180 181 )
  292. X     ( "or"    calcFunc-or   180 181 )
  293. X     ( "xor"   calcFunc-xor  180 181 )
  294. X     ( "shl"   calcFunc-lsh  180 181 )
  295. X     ( "shr"   calcFunc-rsh  180 181 )
  296. X     ( "in"    calcFunc-in   160 161 )
  297. X     ( "<"     calcFunc-lt   160 161 )
  298. X     ( ">"     calcFunc-gt   160 161 )
  299. X     ( "<="    calcFunc-leq  160 161 )
  300. X     ( ">="    calcFunc-geq  160 161 )
  301. X     ( "="     calcFunc-eq   160 161 )
  302. X     ( "<>"    calcFunc-neq  160 161 )
  303. X     ( "!!!"   calcFunc-pnot  -1  85 )
  304. X     ( "&&&"   calcFunc-pand  80  81 )
  305. X     ( "|||"   calcFunc-por   75  76 )
  306. X     ( ":="    calcFunc-assign 51 50 )
  307. X     ( "::"    calcFunc-condition 45 46 )
  308. ))
  309. X
  310. (put 'pascal 'math-input-filter 'calc-input-case-filter)
  311. (put 'pascal 'math-output-filter 'calc-output-case-filter)
  312. X
  313. (put 'pascal 'math-radix-formatter
  314. X     (function (lambda (r s)
  315. X         (if (= r 16) (format "$%s" s)
  316. X           (format "%d#%s" r s)))))
  317. X
  318. (defun calc-input-case-filter (str)
  319. X  (cond ((or (null calc-language-option) (= calc-language-option 0))
  320. X     str)
  321. X    (t
  322. X     (downcase str)))
  323. )
  324. X
  325. (defun calc-output-case-filter (str)
  326. X  (cond ((or (null calc-language-option) (= calc-language-option 0))
  327. X     str)
  328. X    ((> calc-language-option 0)
  329. X     (upcase str))
  330. X    (t
  331. X     (downcase str)))
  332. )
  333. X
  334. X
  335. (defun calc-fortran-language (n)
  336. X  (interactive "P")
  337. X  (calc-wrapper
  338. X   (and n (setq n (prefix-numeric-value n)))
  339. X   (calc-set-language 'fortran n)
  340. X   (message (if (and n (/= n 0))
  341. X        (if (> n 0)
  342. X            "FORTRAN language mode (all uppercase)."
  343. X          "FORTRAN language mode (all lowercase).")
  344. X          "FORTRAN language mode.")))
  345. )
  346. X
  347. (put 'fortran 'math-oper-table
  348. X  '( ( "u/"    (math-parse-fortran-vector) -1 1 )
  349. X     ( "/"     (math-parse-fortran-vector-end) 1 -1 )
  350. X     ( "**"    ^             201 200 )
  351. X     ( "u+"    ident         -1  191 )
  352. X     ( "u-"    neg         -1  191 )
  353. X     ( "*"     *         190 191 )
  354. X     ( "/"     /         190 191 )
  355. X     ( "+"     +         180 181 )
  356. X     ( "-"     -         180 181 )
  357. X     ( ".LT."  calcFunc-lt   160 161 )
  358. X     ( ".GT."  calcFunc-gt   160 161 )
  359. X     ( ".LE."  calcFunc-leq  160 161 )
  360. X     ( ".GE."  calcFunc-geq  160 161 )
  361. X     ( ".EQ."  calcFunc-eq   160 161 )
  362. X     ( ".NE."  calcFunc-neq  160 161 )
  363. X     ( ".NOT." calcFunc-lnot -1  121 )
  364. X     ( ".AND." calcFunc-land 110 111 )
  365. X     ( ".OR."  calcFunc-lor  100 101 )
  366. X     ( "!!!"   calcFunc-pnot  -1  85 )
  367. X     ( "&&&"   calcFunc-pand  80  81 )
  368. X     ( "|||"   calcFunc-por   75  76 )
  369. X     ( "="     calcFunc-assign 51 50 )
  370. X     ( ":="    calcFunc-assign 51 50 )
  371. X     ( "::"    calcFunc-condition 45 46 )
  372. ))
  373. X
  374. (put 'fortran 'math-vector-brackets "//")
  375. X
  376. (put 'fortran 'math-function-table
  377. X  '( ( acos       . calcFunc-arccos )
  378. X     ( acosh       . calcFunc-arccosh )
  379. X     ( aimag       . calcFunc-im )
  380. X     ( aint       . calcFunc-ftrunc )
  381. X     ( asin       . calcFunc-arcsin )
  382. X     ( asinh       . calcFunc-arcsinh )
  383. X     ( atan       . calcFunc-arctan )
  384. X     ( atan2       . calcFunc-arctan2 )
  385. X     ( atanh       . calcFunc-arctanh )
  386. X     ( conjg       . calcFunc-conj )
  387. X     ( log       . calcFunc-ln )
  388. X     ( nint       . calcFunc-round )
  389. X     ( real       . calcFunc-re )
  390. ))
  391. X
  392. (put 'fortran 'math-input-filter 'calc-input-case-filter)
  393. (put 'fortran 'math-output-filter 'calc-output-case-filter)
  394. X
  395. (defun math-parse-fortran-vector (op)
  396. X  (let ((math-parsing-fortran-vector '(end . "\000")))
  397. X    (prog1
  398. X    (math-read-brackets t "]")
  399. X      (setq exp-token (car math-parsing-fortran-vector)
  400. X        exp-data (cdr math-parsing-fortran-vector))))
  401. )
  402. X
  403. (defun math-parse-fortran-vector-end (x op)
  404. X  (if math-parsing-fortran-vector
  405. X      (progn
  406. X    (setq math-parsing-fortran-vector (cons exp-token exp-data)
  407. X          exp-token 'end
  408. X          exp-data "\000")
  409. X    x)
  410. X    (throw 'syntax "Unmatched closing `/'"))
  411. )
  412. (setq math-parsing-fortran-vector nil)
  413. X
  414. X
  415. (defun calc-tex-language (n)
  416. X  (interactive "P")
  417. X  (calc-wrapper
  418. X   (and n (setq n (prefix-numeric-value n)))
  419. X   (calc-set-language 'tex n)
  420. X   (message (if (and n (/= n 0))
  421. X        (if (> n 0)
  422. X            "TeX language mode with \\hbox{func}(\\hbox{var})."
  423. X          "TeX language mode with \\func{\\hbox{var}}.")
  424. X          "TeX language mode.")))
  425. )
  426. X
  427. (put 'tex 'math-oper-table
  428. X  '( ( "u+"       ident           -1 1000 )
  429. X     ( "u-"       neg           -1 1000 )
  430. X     ( "\\hat"    calcFunc-hat     -1  950 )
  431. X     ( "\\check"  calcFunc-check   -1  950 )
  432. X     ( "\\tilde"  calcFunc-tilde   -1  950 )
  433. X     ( "\\acute"  calcFunc-acute   -1  950 )
  434. X     ( "\\grave"  calcFunc-grave   -1  950 )
  435. X     ( "\\dot"    calcFunc-dot     -1  950 )
  436. X     ( "\\ddot"   calcFunc-dotdot  -1  950 )
  437. X     ( "\\breve"  calcFunc-breve   -1  950 )
  438. X     ( "\\bar"    calcFunc-bar     -1  950 )
  439. X     ( "\\vec"    calcFunc-Vec     -1  950 )
  440. X     ( "\\underline" calcFunc-under -1  950 )
  441. X     ( "u|"       calcFunc-abs       -1    0 )
  442. X     ( "|"        closing        0   -1 )
  443. X     ( "\\lfloor" calcFunc-floor   -1    0 )
  444. X     ( "\\rfloor" closing           0   -1 )
  445. X     ( "\\lceil"  calcFunc-ceil    -1    0 )
  446. X     ( "\\rceil"  closing           0   -1 )
  447. X     ( "\\pm"      sdev           300 300 )
  448. X     ( "!"        calcFunc-fact       210  -1 )
  449. X     ( "^"      ^           201 200 )
  450. X     ( "_"      calcFunc-subscr  201 200 )
  451. X     ( "\\times"  *           191 190 )
  452. X     ( "*"        *           191 190 )
  453. X     ( "2x"      *           191 190 )
  454. X     ( "+"      +           180 181 )
  455. X     ( "-"      -           180 181 )
  456. X     ( "\\over"      /           170 171 )
  457. X     ( "/"      /           170 171 )
  458. X     ( "\\choose" calcFunc-choose  170 171 )
  459. X     ( "\\mod"      %           170 171 )
  460. X     ( "<"      calcFunc-lt       160 161 )
  461. X     ( ">"      calcFunc-gt       160 161 )
  462. X     ( "\\leq"      calcFunc-leq       160 161 )
  463. X     ( "\\geq"      calcFunc-geq       160 161 )
  464. X     ( "="      calcFunc-eq       160 161 )
  465. X     ( "\\neq"      calcFunc-neq       160 161 )
  466. X     ( "\\ne"      calcFunc-neq       160 161 )
  467. X     ( "\\lnot"   calcFunc-lnot     -1 121 )
  468. X     ( "\\land"      calcFunc-land    110 111 )
  469. X     ( "\\lor"      calcFunc-lor     100 101 )
  470. X     ( "?"      (math-read-if)    91  90 )
  471. X     ( "!!!"      calcFunc-pnot        -1  85 )
  472. X     ( "&&&"      calcFunc-pand        80  81 )
  473. X     ( "|||"      calcFunc-por        75  76 )
  474. X     ( "\\gets"      calcFunc-assign   51  50 )
  475. X     ( ":="      calcFunc-assign   51  50 )
  476. X     ( "::"       calcFunc-condition 45 46 )
  477. X     ( "\\to"      calcFunc-evalto   40  41 )
  478. X     ( "\\to"      calcFunc-evalto   40  -1 )
  479. X     ( "=>"       calcFunc-evalto   40  41 )
  480. X     ( "=>"       calcFunc-evalto   40  -1 )
  481. ))
  482. X
  483. (put 'tex 'math-function-table
  484. X  '( ( \\arccos       . calcFunc-arccos )
  485. X     ( \\arcsin       . calcFunc-arcsin )
  486. X     ( \\arctan       . calcFunc-arctan )
  487. X     ( \\arg       . calcFunc-arg )
  488. X     ( \\cos       . calcFunc-cos )
  489. X     ( \\cosh       . calcFunc-cosh )
  490. X     ( \\det       . calcFunc-det )
  491. X     ( \\exp       . calcFunc-exp )
  492. X     ( \\gcd       . calcFunc-gcd )
  493. X     ( \\ln       . calcFunc-ln )
  494. X     ( \\log       . calcFunc-log10 )
  495. X     ( \\max       . calcFunc-max )
  496. X     ( \\min       . calcFunc-min )
  497. X     ( \\tan       . calcFunc-tan )
  498. X     ( \\sin       . calcFunc-sin )
  499. X     ( \\sinh       . calcFunc-sinh )
  500. X     ( \\sqrt       . calcFunc-sqrt )
  501. X     ( \\tanh       . calcFunc-tanh )
  502. X     ( \\phi       . calcFunc-totient )
  503. X     ( \\mu       . calcFunc-moebius )
  504. ))
  505. X
  506. (put 'tex 'math-variable-table
  507. X  '( ( \\pi       . var-pi )
  508. X     ( \\infty       . var-inf )
  509. X     ( \\infty       . var-uinf )
  510. X     ( \\phi       . var-phi )
  511. X     ( \\gamma     . var-gamma )
  512. X     ( \\sum       . (math-parse-tex-sum calcFunc-sum) )
  513. X     ( \\prod      . (math-parse-tex-sum calcFunc-prod) )
  514. ))
  515. X
  516. (put 'tex 'math-complex-format 'i)
  517. X
  518. (defun math-parse-tex-sum (f val)
  519. X  (let (low high save)
  520. X    (or (equal exp-data "_") (throw 'syntax "Expected `_'"))
  521. X    (math-read-token)
  522. X    (setq save exp-old-pos)
  523. X    (setq low (math-read-factor))
  524. X    (or (eq (car-safe low) 'calcFunc-eq)
  525. X    (progn
  526. X      (setq exp-old-pos (1+ save))
  527. X      (throw 'syntax "Expected equation")))
  528. X    (or (equal exp-data "^") (throw 'syntax "Expected `^'"))
  529. X    (math-read-token)
  530. X    (setq high (math-read-factor))
  531. X    (list (nth 2 f) (math-read-factor) (nth 1 low) (nth 2 low) high))
  532. )
  533. X
  534. (defun math-tex-input-filter (str)   ; allow parsing of 123\,456\,789.
  535. X  (while (string-match "[0-9]\\\\,[0-9]" str)
  536. X    (setq str (concat (substring str 0 (1+ (match-beginning 0)))
  537. X              (substring str (1- (match-end 0))))))
  538. X  str
  539. )
  540. (put 'tex 'math-input-filter 'math-tex-input-filter)
  541. X
  542. X
  543. (defun calc-eqn-language (n)
  544. X  (interactive "P")
  545. X  (calc-wrapper
  546. X   (calc-set-language 'eqn)
  547. X   (message "Eqn language mode."))
  548. )
  549. X
  550. (put 'eqn 'math-oper-table
  551. X  '( ( "u+"       ident           -1 1000 )
  552. X     ( "u-"       neg           -1 1000 )
  553. X     ( "prime"    (math-parse-eqn-prime) 950  -1 )
  554. X     ( "prime"    calcFunc-Prime   950  -1 )
  555. X     ( "dot"      calcFunc-dot     950  -1 )
  556. X     ( "dotdot"   calcFunc-dotdot  950  -1 )
  557. X     ( "hat"      calcFunc-hat     950  -1 )
  558. X     ( "tilde"    calcFunc-tilde   950  -1 )
  559. X     ( "vec"      calcFunc-Vec     950  -1 )
  560. X     ( "dyad"     calcFunc-dyad    950  -1 )
  561. X     ( "bar"      calcFunc-bar     950  -1 )
  562. X     ( "under"    calcFunc-under   950  -1 )
  563. X     ( "sub"      calcFunc-subscr  931 930 )
  564. X     ( "sup"      ^           921 920 )
  565. X     ( "sqrt"      calcFunc-sqrt    -1  910 )
  566. X     ( "over"      /           900 901 )
  567. X     ( "u|"       calcFunc-abs       -1    0 )
  568. X     ( "|"        closing        0   -1 )
  569. X     ( "left floor"  calcFunc-floor -1   0 )
  570. X     ( "right floor" closing        0   -1 )
  571. X     ( "left ceil"   calcFunc-ceil  -1   0 )
  572. X     ( "right ceil"  closing        0   -1 )
  573. X     ( "+-"      sdev           300 300 )
  574. X     ( "!"        calcFunc-fact       210  -1 )
  575. X     ( "times"    *           191 190 )
  576. X     ( "*"        *           191 190 )
  577. X     ( "2x"      *           191 190 )
  578. X     ( "/"      /           180 181 )
  579. X     ( "%"      %           180 181 )
  580. X     ( "+"      +           170 171 )
  581. X     ( "-"      -           170 171 )
  582. X     ( "<"      calcFunc-lt       160 161 )
  583. X     ( ">"      calcFunc-gt       160 161 )
  584. X     ( "<="      calcFunc-leq       160 161 )
  585. X     ( ">="      calcFunc-geq       160 161 )
  586. X     ( "="      calcFunc-eq       160 161 )
  587. X     ( "=="      calcFunc-eq       160 161 )
  588. X     ( "!="      calcFunc-neq       160 161 )
  589. X     ( "u!"       calcFunc-lnot     -1 121 )
  590. X     ( "&&"      calcFunc-land    110 111 )
  591. X     ( "||"      calcFunc-lor     100 101 )
  592. X     ( "?"      (math-read-if)    91  90 )
  593. X     ( "!!!"      calcFunc-pnot        -1  85 )
  594. X     ( "&&&"      calcFunc-pand        80  81 )
  595. X     ( "|||"      calcFunc-por        75  76 )
  596. X     ( "<-"      calcFunc-assign   51  50 )
  597. X     ( ":="      calcFunc-assign   51  50 )
  598. X     ( "::"      calcFunc-condition 45 46 )
  599. X     ( "->"      calcFunc-evalto   40  41 )
  600. X     ( "->"      calcFunc-evalto   40  -1 )
  601. X     ( "=>"       calcFunc-evalto   40  41 )
  602. X     ( "=>"       calcFunc-evalto   40  -1 )
  603. ))
  604. X
  605. (put 'eqn 'math-function-table
  606. X  '( ( arc\ cos       . calcFunc-arccos )
  607. X     ( arc\ cosh   . calcFunc-arccosh )
  608. X     ( arc\ sin       . calcFunc-arcsin )
  609. X     ( arc\ sinh   . calcFunc-arcsinh )
  610. X     ( arc\ tan       . calcFunc-arctan )
  611. X     ( arc\ tanh   . calcFunc-arctanh )
  612. X     ( GAMMA       . calcFunc-gamma )
  613. X     ( phi       . calcFunc-totient )
  614. X     ( mu       . calcFunc-moebius )
  615. X     ( matrix       . (math-parse-eqn-matrix) )
  616. ))
  617. X
  618. (put 'eqn 'math-variable-table
  619. X  '( ( inf       . var-uinf )
  620. ))
  621. X
  622. (put 'eqn 'math-complex-format 'i)
  623. X
  624. (defun math-parse-eqn-matrix (f sym)
  625. X  (let ((vec nil))
  626. X    (while (assoc exp-data '(("ccol") ("lcol") ("rcol")))
  627. X      (math-read-token)
  628. X      (or (equal exp-data calc-function-open)
  629. X      (throw 'syntax "Expected `{'"))
  630. X      (math-read-token)
  631. X      (setq vec (cons (cons 'vec (math-read-expr-list)) vec))
  632. X      (or (equal exp-data calc-function-close)
  633. X      (throw 'syntax "Expected `}'"))
  634. X      (math-read-token))
  635. X    (or (equal exp-data calc-function-close)
  636. X    (throw 'syntax "Expected `}'"))
  637. X    (math-read-token)
  638. X    (math-transpose (cons 'vec (nreverse vec))))
  639. )
  640. X
  641. (defun math-parse-eqn-prime (x sym)
  642. X  (if (eq (car-safe x) 'var)
  643. X      (if (equal exp-data calc-function-open)
  644. X      (progn
  645. X        (math-read-token)
  646. X        (let ((args (if (or (equal exp-data calc-function-close)
  647. X                (eq exp-token 'end))
  648. X                nil
  649. X              (math-read-expr-list))))
  650. X          (if (not (or (equal exp-data calc-function-close)
  651. X               (eq exp-token 'end)))
  652. X          (throw 'syntax "Expected `)'"))
  653. X          (math-read-token)
  654. X          (cons (intern (format "calcFunc-%s'" (nth 1 x))) args)))
  655. X    (list 'var
  656. X          (intern (concat (symbol-name (nth 1 x)) "'"))
  657. X          (intern (concat (symbol-name (nth 2 x)) "'"))))
  658. X    (list 'calcFunc-Prime x))
  659. )
  660. X
  661. X
  662. (defun calc-mathematica-language ()
  663. X  (interactive)
  664. X  (calc-wrapper
  665. X   (calc-set-language 'math)
  666. X   (message "Mathematica language mode."))
  667. )
  668. X
  669. (put 'math 'math-oper-table
  670. X  '( ( "[["    (math-read-math-subscr) 250 -1 )
  671. X     ( "!"     calcFunc-fact  210 -1 )
  672. X     ( "!!"    calcFunc-dfact 210 -1 )
  673. X     ( "^"     ^         201 200 )
  674. X     ( "u+"    ident         -1  197 )
  675. X     ( "u-"    neg         -1  197 )
  676. X     ( "/"     /         195 196 )
  677. X     ( "*"     *         190 191 )
  678. X     ( "2x"    *         190 191 )
  679. X     ( "+"     +         180 181 )
  680. X     ( "-"     -         180 181 )
  681. X     ( "<"     calcFunc-lt   160 161 )
  682. X     ( ">"     calcFunc-gt   160 161 )
  683. X     ( "<="    calcFunc-leq  160 161 )
  684. X     ( ">="    calcFunc-geq  160 161 )
  685. X     ( "=="    calcFunc-eq   150 151 )
  686. X     ( "!="    calcFunc-neq  150 151 )
  687. X     ( "u!"    calcFunc-lnot -1  121 )
  688. X     ( "&&"    calcFunc-land 110 111 )
  689. X     ( "||"    calcFunc-lor  100 101 )
  690. X     ( "!!!"   calcFunc-pnot  -1  85 )
  691. X     ( "&&&"   calcFunc-pand  80  81 )
  692. X     ( "|||"   calcFunc-por   75  76 )
  693. X     ( ":="    calcFunc-assign 51 50 )
  694. X     ( "="     calcFunc-assign 51 50 )
  695. X     ( "->"    calcFunc-assign 51 50 )
  696. X     ( ":>"    calcFunc-assign 51 50 )
  697. X     ( "::"    calcFunc-condition 45 46 )
  698. ))
  699. X
  700. (put 'math 'math-function-table
  701. X  '( ( Abs       . calcFunc-abs )
  702. X     ( ArcCos       . calcFunc-arccos )
  703. X     ( ArcCosh       . calcFunc-arccosh )
  704. X     ( ArcSin       . calcFunc-arcsin )
  705. X     ( ArcSinh       . calcFunc-arcsinh )
  706. X     ( ArcTan       . calcFunc-arctan )
  707. X     ( ArcTanh       . calcFunc-arctanh )
  708. X     ( Arg       . calcFunc-arg )
  709. X     ( Binomial       . calcFunc-choose )
  710. X     ( Ceiling       . calcFunc-ceil )
  711. X     ( Conjugate   . calcFunc-conj )
  712. X     ( Cos       . calcFunc-cos )
  713. X     ( Cosh       . calcFunc-cosh )
  714. X     ( D       . calcFunc-deriv )
  715. X     ( Dt       . calcFunc-tderiv )
  716. X     ( Det       . calcFunc-det )
  717. X     ( Exp       . calcFunc-exp )
  718. X     ( EulerPhi       . calcFunc-totient )
  719. X     ( Floor       . calcFunc-floor )
  720. X     ( Gamma       . calcFunc-gamma )
  721. X     ( GCD       . calcFunc-gcd )
  722. X     ( If       . calcFunc-if )
  723. X     ( Im       . calcFunc-im )
  724. X     ( Inverse       . calcFunc-inv )
  725. X     ( Integrate   . calcFunc-integ )
  726. X     ( Join       . calcFunc-vconcat )
  727. X     ( LCM       . calcFunc-lcm )
  728. X     ( Log       . calcFunc-ln )
  729. X     ( Max       . calcFunc-max )
  730. X     ( Min       . calcFunc-min )
  731. X     ( Mod       . calcFunc-mod )
  732. X     ( MoebiusMu   . calcFunc-moebius )
  733. X     ( Random       . calcFunc-random )
  734. X     ( Round       . calcFunc-round )
  735. X     ( Re       . calcFunc-re )
  736. X     ( Sign       . calcFunc-sign )
  737. X     ( Sin       . calcFunc-sin )
  738. X     ( Sinh       . calcFunc-sinh )
  739. X     ( Sqrt       . calcFunc-sqrt )
  740. X     ( Tan       . calcFunc-tan )
  741. X     ( Tanh       . calcFunc-tanh )
  742. X     ( Transpose   . calcFunc-trn )
  743. X     ( Length       . calcFunc-vlen )
  744. ))
  745. X
  746. (put 'math 'math-variable-table
  747. X  '( ( I       . var-i )
  748. X     ( Pi       . var-pi )
  749. X     ( E       . var-e )
  750. X     ( GoldenRatio . var-phi )
  751. X     ( EulerGamma  . var-gamma )
  752. X     ( Infinity       . var-inf )
  753. X     ( ComplexInfinity . var-uinf )
  754. X     ( Indeterminate . var-nan )
  755. ))
  756. X
  757. (put 'math 'math-vector-brackets "{}")
  758. (put 'math 'math-complex-format 'I)
  759. (put 'math 'math-function-open "[")
  760. (put 'math 'math-function-close "]")
  761. X
  762. (put 'math 'math-radix-formatter
  763. X     (function (lambda (r s) (format "%d^^%s" r s))))
  764. X
  765. (defun math-read-math-subscr (x op)
  766. X  (let ((idx (math-read-expr-level 0)))
  767. X    (or (and (equal exp-data "]")
  768. X         (progn
  769. X           (math-read-token)
  770. X           (equal exp-data "]")))
  771. X    (throw 'syntax "Expected ']]'"))
  772. X    (math-read-token)
  773. X    (list 'calcFunc-subscr x idx))
  774. )
  775. X
  776. X
  777. (defun calc-maple-language ()
  778. X  (interactive)
  779. X  (calc-wrapper
  780. X   (calc-set-language 'maple)
  781. X   (message "Maple language mode."))
  782. )
  783. X
  784. (put 'maple 'math-oper-table
  785. X  '( ( "matrix" ident         -1  300 )
  786. X     ( "MATRIX" ident         -1  300 )
  787. X     ( "!"     calcFunc-fact  210 -1 )
  788. X     ( "^"     ^         201 200 )
  789. X     ( "**"    ^         201 200 )
  790. X     ( "u+"    ident         -1  197 )
  791. X     ( "u-"    neg         -1  197 )
  792. X     ( "/"     /         191 192 )
  793. X     ( "*"     *         191 192 )
  794. X     ( "intersect" calcFunc-vint 191 192 )
  795. X     ( "+"     +         180 181 )
  796. X     ( "-"     -         180 181 )
  797. X     ( "union" calcFunc-vunion 180 181 )
  798. X     ( "minus" calcFunc-vdiff 180 181 )
  799. X     ( "mod"   %         170 170 )
  800. X     ( ".."    calcFunc-mapleintv 165 165 )
  801. X     ( "\\dots" (math-read-maple-dots) 165 165 )
  802. X     ( "<"     calcFunc-lt   160 160 )
  803. X     ( ">"     calcFunc-gt   160 160 )
  804. X     ( "<="    calcFunc-leq  160 160 )
  805. X     ( ">="    calcFunc-geq  160 160 )
  806. X     ( "="     calcFunc-eq   160 160 )
  807. X     ( "<>"    calcFunc-neq  160 160 )
  808. X     ( "not"   calcFunc-lnot -1  121 )
  809. X     ( "and"   calcFunc-land 110 111 )
  810. X     ( "or"    calcFunc-lor  100 101 )
  811. X     ( "!!!"   calcFunc-pnot  -1  85 )
  812. X     ( "&&&"   calcFunc-pand  80  81 )
  813. X     ( "|||"   calcFunc-por   75  76 )
  814. X     ( ":="    calcFunc-assign 51 50 )
  815. X     ( "::"    calcFunc-condition 45 46 )
  816. ))
  817. X
  818. (put 'maple 'math-function-table
  819. X  '( ( bernoulli   . calcFunc-bern )
  820. X     ( binomial       . calcFunc-choose )
  821. X     ( diff       . calcFunc-deriv )
  822. X     ( GAMMA       . calcFunc-gamma )
  823. X     ( ifactor       . calcFunc-prfac )
  824. X     ( igcd        . calcFunc-gcd )
  825. X     ( ilcm       . calcFunc-lcm )
  826. X     ( int         . calcFunc-integ )
  827. X     ( modp       . % )
  828. X     ( irem       . % )
  829. X     ( iquo       . calcFunc-idiv )
  830. X     ( isprime       . calcFunc-prime )
  831. X     ( length       . calcFunc-vlen )
  832. X     ( member       . calcFunc-in )
  833. X     ( crossprod   . calcFunc-cross )
  834. X     ( inverse       . calcFunc-inv )
  835. X     ( trace       . calcFunc-tr )
  836. X     ( transpose   . calcFunc-trn )
  837. X     ( vectdim       . calcFunc-vlen )
  838. ))
  839. X
  840. (put 'maple 'math-variable-table
  841. X  '( ( I       . var-i )
  842. X     ( Pi       . var-pi )
  843. X     ( E       . var-e )
  844. X     ( infinity       . var-inf )
  845. X     ( infinity    . var-uinf )
  846. X     ( infinity    . var-nan )
  847. ))
  848. X
  849. (put 'maple 'math-complex-format 'I)
  850. X
  851. (defun math-read-maple-dots (x op)
  852. X  (list 'intv 3 x (math-read-expr-level (nth 3 op)))
  853. )
  854. X
  855. X
  856. X
  857. X
  858. X
  859. (defun math-read-big-rec (h1 v1 h2 v2 &optional baseline prec short)
  860. X  (or prec (setq prec 0))
  861. X
  862. X  ;; Clip whitespace above or below.
  863. X  (while (and (< v1 v2) (math-read-big-emptyp h1 v1 h2 (1+ v1)))
  864. X    (setq v1 (1+ v1)))
  865. X  (while (and (< v1 v2) (math-read-big-emptyp h1 (1- v2) h2 v2))
  866. X    (setq v2 (1- v2)))
  867. X
  868. X  ;; If formula is a single line high, normal parser can handle it.
  869. X  (if (<= v2 (1+ v1))
  870. X      (if (or (<= v2 v1)
  871. X          (> h1 (length (setq v2 (nth v1 lines)))))
  872. X      (math-read-big-error h1 v1)
  873. X    (setq the-baseline v1
  874. X          the-h2 h2
  875. X          v2 (nth v1 lines)
  876. X          h2 (math-read-expr (substring v2 h1 (min h2 (length v2)))))
  877. X    (if (eq (car-safe h2) 'error)
  878. X        (math-read-big-error (+ h1 (nth 1 h2)) v1 (nth 2 h2))
  879. X      h2))
  880. X
  881. X    ;; Clip whitespace at left or right.
  882. X    (while (and (< h1 h2) (math-read-big-emptyp h1 v1 (1+ h1) v2))
  883. X      (setq h1 (1+ h1)))
  884. X    (while (and (< h1 h2) (math-read-big-emptyp (1- h2) v1 h2 v2))
  885. X      (setq h2 (1- h2)))
  886. X
  887. X    ;; Scan to find widest left-justified "----" in the region.
  888. X    (let* ((widest nil)
  889. X       (widest-h2 0)
  890. X       (lines-v1 (nthcdr v1 lines))
  891. X       (p lines-v1)
  892. X       (v v1)
  893. X       (other-v nil)
  894. X       other-char line len h)
  895. X      (while (< v v2)
  896. X    (setq line (car p)
  897. X          len (min h2 (length line)))
  898. X    (and (< h1 len)
  899. X         (/= (aref line h1) ?\ )
  900. X         (if (and (= (aref line h1) ?\-)
  901. X              ;; Make sure it's not a minus sign.
  902. X              (or (and (< (1+ h1) len) (= (aref line (1+ h1)) ?\-))
  903. X              (/= (math-read-big-char h1 (1- v)) ?\ )
  904. X              (/= (math-read-big-char h1 (1+ v)) ?\ )))
  905. X         (progn
  906. X           (setq h h1)
  907. X           (while (and (< (setq h (1+ h)) len)
  908. X                   (= (aref line h) ?\-)))
  909. X           (if (> h widest-h2)
  910. X               (setq widest v
  911. X                 widest-h2 h)))
  912. X           (or other-v (setq other-v v other-char (aref line h1)))))
  913. X    (setq v (1+ v)
  914. X          p (cdr p)))
  915. X
  916. X      (cond ((not (setq v other-v))
  917. X         (math-read-big-error h1 v1))   ; Should never happen!
  918. X
  919. X        ;; Quotient.
  920. X        (widest
  921. X         (setq h widest-h2
  922. X           v widest)
  923. X         (let ((num (math-read-big-rec h1 v1 h v))
  924. X           (den (math-read-big-rec h1 (1+ v) h v2)))
  925. X           (setq p (if (and (math-integerp num) (math-integerp den))
  926. X               (math-make-frac num den)
  927. X             (list '/ num den)))))
  928. X
  929. X        ;; Big radical sign.
  930. X        ((= other-char ?\\)
  931. X         (or (= (math-read-big-char (1+ h1) v) ?\|)
  932. X         (math-read-big-error (1+ h1) v "Malformed root sign"))
  933. X         (math-read-big-emptyp h1 v1 (1+ h1) v nil t)
  934. X         (while (= (math-read-big-char (1+ h1) (setq v (1- v))) ?\|))
  935. X         (or (= (math-read-big-char (setq h (+ h1 2)) v) ?\_)
  936. X         (math-read-big-error h v "Malformed root sign"))
  937. X         (while (= (math-read-big-char (setq h (1+ h)) v) ?\_))
  938. X         (math-read-big-emptyp h1 v1 (1+ h1) v nil t)
  939. X         (math-read-big-emptyp h1 (1+ other-v) h v2 nil t)
  940. X         (setq p (list 'calcFunc-sqrt (math-read-big-rec
  941. X                       (+ h1 2) (1+ v)
  942. X                       h (1+ other-v) baseline))
  943. X           v the-baseline))
  944. X
  945. X        ;; Small radical sign.
  946. X        ((and (= other-char ?V)
  947. X          (= (math-read-big-char (1+ h1) (1- v)) ?\_))
  948. X         (setq h (1+ h1))
  949. X         (math-read-big-emptyp h1 v1 h (1- v) nil t)
  950. X         (math-read-big-emptyp h1 (1+ v) h v2 nil t)
  951. X         (math-read-big-emptyp h1 v1 (1+ h1) v nil t)
  952. X         (while (= (math-read-big-char (setq h (1+ h)) (1- v)) ?\_))
  953. X         (setq p (list 'calcFunc-sqrt (math-read-big-rec
  954. X                       (1+ h1) v h (1+ v) t))
  955. X           v the-baseline))
  956. X
  957. X        ;; Binomial coefficient.
  958. X        ((and (= other-char ?\()
  959. X          (= (math-read-big-char (1+ h1) v) ?\ )
  960. X          (= (string-match "( *)" (nth v lines) h1) h1))
  961. X         (setq h (match-end 0))
  962. X         (math-read-big-emptyp h1 v1 (1+ h1) v nil t)
  963. X         (math-read-big-emptyp h1 (1+ v) (1+ h1) v2 nil t)
  964. X         (math-read-big-emptyp (1- h) v1 h v nil t)
  965. X         (math-read-big-emptyp (1- h) (1+ v) h v2 nil t)
  966. X         (setq p (list 'calcFunc-choose
  967. X               (math-read-big-rec (1+ h1) v1 (1- h) v)
  968. X               (math-read-big-rec (1+ h1) (1+ v)
  969. X                          (1- h) v2))))
  970. X
  971. X        ;; Minus sign.
  972. X        ((= other-char ?\-)
  973. X         (setq p (list 'neg (math-read-big-rec (1+ h1) v1 h2 v2 v 250 t))
  974. X           v the-baseline
  975. X           h the-h2))
  976. X
  977. X        ;; Parentheses.
  978. X        ((= other-char ?\()
  979. X         (math-read-big-emptyp h1 v1 (1+ h1) v nil t)
  980. X         (math-read-big-emptyp h1 (1+ v) (1+ h1) v2 nil t)
  981. X         (setq h (math-read-big-balance (1+ h1) v "(" t))
  982. X         (math-read-big-emptyp (1- h) v1 h v nil t)
  983. X         (math-read-big-emptyp (1- h) (1+ v) h v2 nil t)
  984. X         (let ((sep (math-read-big-char (1- h) v))
  985. X           hmid)
  986. X           (if (= sep ?\.)
  987. X           (setq h (1+ h)))
  988. X           (if (= sep ?\])
  989. X           (math-read-big-error (1- h) v "Expected `)'"))
  990. X           (if (= sep ?\))
  991. X           (setq p (math-read-big-rec (1+ h1) v1 (1- h) v2 v))
  992. X         (setq hmid (math-read-big-balance h v "(")
  993. X               p (list p (math-read-big-rec h v1 (1- hmid) v2 v))
  994. X               h hmid)
  995. X         (cond ((= sep ?\.)
  996. X            (setq p (cons 'intv (cons (if (= (math-read-big-char
  997. X                              (1- h) v)
  998. X                             ?\))
  999. X                              0 1)
  1000. X                          p))))
  1001. X               ((= (math-read-big-char (1- h) v) ?\])
  1002. X            (math-read-big-error (1- h) v "Expected `)'"))
  1003. X               ((= sep ?\,)
  1004. X            (or (and (math-realp (car p)) (math-realp (nth 1 p)))
  1005. X                (math-read-big-error
  1006. X                 h1 v "Complex components must be real"))
  1007. X            (setq p (cons 'cplx p)))
  1008. X               ((= sep ?\;)
  1009. X            (or (and (math-realp (car p)) (math-anglep (nth 1 p)))
  1010. X                (math-read-big-error
  1011. X                 h1 v "Complex components must be real"))
  1012. X            (setq p (cons 'polar p)))))))
  1013. X
  1014. X        ;; Matrix.
  1015. X        ((and (= other-char ?\[)
  1016. X          (or (= (math-read-big-char (setq h h1) (1+ v)) ?\[)
  1017. X              (= (math-read-big-char (setq h (1+ h)) v) ?\[)
  1018. X              (and (= (math-read-big-char h v) ?\ )
  1019. X               (= (math-read-big-char (setq h (1+ h)) v) ?\[)))
  1020. X          (= (math-read-big-char h (1+ v)) ?\[))
  1021. X         (math-read-big-emptyp h1 v1 h v nil t)
  1022. X         (let ((vtop v)
  1023. X           (hleft h)
  1024. X           (hright nil))
  1025. X           (setq p nil)
  1026. X           (while (progn
  1027. X            (setq h (math-read-big-balance (1+ hleft) v "["))
  1028. X            (if hright
  1029. X                (or (= h hright)
  1030. X                (math-read-big-error hright v "Expected `]'"))
  1031. X              (setq hright h))
  1032. X            (setq p (cons (math-read-big-rec
  1033. X                       hleft v h (1+ v)) p))
  1034. X            (and (memq (math-read-big-char h v) '(?\  ?\,))
  1035. X                 (= (math-read-big-char hleft (1+ v)) ?\[)))
  1036. X         (setq v (1+ v)))
  1037. X           (or (= hleft h1)
  1038. X           (progn
  1039. X             (if (= (math-read-big-char h v) ?\ )
  1040. X             (setq h (1+ h)))
  1041. X             (and (= (math-read-big-char h v) ?\])
  1042. X              (setq h (1+ h))))
  1043. X           (math-read-big-error (1- h) v "Expected `]'"))
  1044. X           (if (= (math-read-big-char h vtop) ?\,)
  1045. X           (setq h (1+ h)))
  1046. X           (math-read-big-emptyp h1 (1+ v) (1- h) v2 nil t)
  1047. X           (setq v (+ vtop (/ (- v vtop) 2))
  1048. X             p (cons 'vec (nreverse p)))))
  1049. X
  1050. X        ;; Square brackets.
  1051. X        ((= other-char ?\[)
  1052. X         (math-read-big-emptyp h1 v1 (1+ h1) v nil t)
  1053. X         (math-read-big-emptyp h1 (1+ v) (1+ h1) v2 nil t)
  1054. X         (setq p nil
  1055. X           h (1+ h1))
  1056. X         (while (progn
  1057. X              (setq widest (math-read-big-balance h v "[" t))
  1058. X              (math-read-big-emptyp (1- h) v1 h v nil t)
  1059. X              (math-read-big-emptyp (1- h) (1+ v) h v2 nil t)
  1060. X              (setq p (cons (math-read-big-rec
  1061. X                     h v1 (1- widest) v2 v) p)
  1062. X                h widest)
  1063. X              (= (math-read-big-char (1- h) v) ?\,)))
  1064. X         (setq widest (math-read-big-char (1- h) v))
  1065. X         (if (or (memq widest '(?\; ?\)))
  1066. X             (and (eq widest ?\.) (cdr p)))
  1067. X         (math-read-big-error (1- h) v "Expected `]'"))
  1068. X         (if (= widest ?\.)
  1069. X         (setq h (1+ h)
  1070. X               widest (math-read-big-balance h v "[")
  1071. X               p (nconc p (list (math-read-big-big-rec
  1072. X                     h v1 (1- widest) v2 v)))
  1073. X               h widest
  1074. X               p (cons 'intv (cons (if (= (math-read-big-char (1- h) v)
  1075. X                          ?\])
  1076. X                           3 2)
  1077. X                       p)))
  1078. X           (setq p (cons 'vec (nreverse p)))))
  1079. X
  1080. X        ;; Date form.
  1081. X        ((= other-char ?\<)
  1082. X         (setq line (nth v lines))
  1083. X         (string-match ">" line h1)
  1084. X         (setq h (match-end 0))
  1085. X         (math-read-big-emptyp h1 v1 h v nil t)
  1086. X         (math-read-big-emptyp h1 (1+ v) h v2 nil t)
  1087. X         (setq p (math-read-big-rec h1 v h (1+ v) v)))
  1088. X
  1089. X        ;; Variable name or function call.
  1090. X        ((or (and (>= other-char ?a) (<= other-char ?z))
  1091. X         (and (>= other-char ?A) (<= other-char ?Z)))
  1092. X         (setq line (nth v lines))
  1093. X         (string-match "\\([a-zA-Z'_]+\\) *" line h1)
  1094. X         (setq h (match-end 1)
  1095. X           widest (match-end 0)
  1096. X           p (math-match-substring line 1))
  1097. X         (math-read-big-emptyp h1 v1 h v nil t)
  1098. X         (math-read-big-emptyp h1 (1+ v) h v2 nil t)
  1099. X         (if (= (math-read-big-char widest v) ?\()
  1100. X         (progn
  1101. X           (setq line (if (string-match "-" p)
  1102. X                  (intern p)
  1103. X                (intern (concat "calcFunc-" p)))
  1104. X             h (1+ widest)
  1105. X             p nil)
  1106. X           (math-read-big-emptyp widest v1 h v nil t)
  1107. X           (math-read-big-emptyp widest (1+ v) h v2 nil t)
  1108. X           (while (progn
  1109. X                (setq widest (math-read-big-balance h v "(" t))
  1110. X                (math-read-big-emptyp (1- h) v1 h v nil t)
  1111. X                (math-read-big-emptyp (1- h) (1+ v) h v2 nil t)
  1112. X                (setq p (cons (math-read-big-rec
  1113. X                       h v1 (1- widest) v2 v) p)
  1114. X                  h widest)
  1115. X                (= (math-read-big-char (1- h) v) ?\,)))
  1116. X           (or (= (math-read-big-char (1- h) v) ?\))
  1117. X               (math-read-big-error (1- h) v "Expected `)'"))
  1118. X           (setq p (cons line (nreverse p))))
  1119. X           (setq p (list 'var
  1120. X                 (intern (math-remove-dashes p))
  1121. X                 (if (string-match "-" p)
  1122. X                 (intern p)
  1123. X                   (intern (concat "var-" p)))))))
  1124. X
  1125. X        ;; Number.
  1126. X        (t
  1127. X         (setq line (nth v lines))
  1128. X         (or (= (string-match "_?\\([0-9]+.?0*@ *\\)?\\([0-9]+.?0*' *\\)?\\([0-9]+\\(#\\|\\^\\^\\)[0-9a-zA-Z:]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\\([eE][-+_]?[0-9]+\\)?\"?\\)?" line h1) h1)
  1129. X         (math-read-big-error h v "Expected a number"))
  1130. X         (setq h (match-end 0)
  1131. X           p (math-read-number (math-match-substring line 0)))
  1132. X         (math-read-big-emptyp h1 v1 h v nil t)
  1133. X         (math-read-big-emptyp h1 (1+ v) h v2 nil t)))
  1134. X
  1135. X      ;; Now left term is bounded by h1, v1, h, v2; baseline = v.
  1136. X      (if baseline
  1137. X      (or (= v baseline)
  1138. X          (math-read-big-error h1 v "Inconsistent baseline in formula"))
  1139. X    (setq baseline v))
  1140. X
  1141. X      ;; Look for superscripts or subscripts.
  1142. X      (setq line (nth baseline lines)
  1143. X        len (min h2 (length line))
  1144. X        widest h)
  1145. X      (while (and (< widest len)
  1146. X          (= (aref line widest) ?\ ))
  1147. X    (setq widest (1+ widest)))
  1148. X      (and (>= widest len) (setq widest h2))
  1149. X      (if (math-read-big-emptyp h v widest v2)
  1150. X      (if (math-read-big-emptyp h v1 widest v)
  1151. X          (setq h widest)
  1152. X        (setq p (list '^ p (math-read-big-rec h v1 widest v))
  1153. X          h widest))
  1154. X      (if (math-read-big-emptyp h v1 widest v)
  1155. X          (setq p (list 'calcFunc-subscr p
  1156. X                (math-read-big-rec h v widest v2))
  1157. X            h widest)))
  1158. X
  1159. X      ;; Look for an operator name and grab additional terms.
  1160. X      (while (and (< h len)
  1161. X          (if (setq widest (and (math-read-big-emptyp
  1162. X                     h v1 (1+ h) v)
  1163. X                    (math-read-big-emptyp
  1164. X                     h (1+ v) (1+ h) v2)
  1165. X                    (string-match "<=\\|>=\\|\\+/-\\|!=\\|&&\\|||\\|:=\\|=>\\|." line h)
  1166. X                    (assoc (math-match-substring line 0)
  1167. X                           math-standard-opers)))
  1168. X              (and (>= (nth 2 widest) prec)
  1169. X               (setq h (match-end 0)))
  1170. X            (and (not (eq (string-match ",\\|;\\|\\.\\.\\|)\\|\\]\\|:" line h)
  1171. X                  h))
  1172. X             (setq widest '("2x" * 196 195)))))
  1173. X    (cond ((eq (nth 3 widest) -1)
  1174. X           (setq p (list (nth 1 widest) p)))
  1175. X          ((equal (car widest) "?")
  1176. X           (let ((y (math-read-big-rec h v1 h2 v2 baseline nil t)))
  1177. X         (or (= (math-read-big-char the-h2 baseline) ?\:)
  1178. X             (math-read-big-error the-h2 baseline "Expected `:'"))
  1179. X         (setq p (list (nth 1 widest) p y
  1180. X                   (math-read-big-rec (1+ the-h2) v1 h2 v2
  1181. X                          baseline (nth 3 widest) t))
  1182. X               h the-h2)))
  1183. X          (t
  1184. X           (setq p (list (nth 1 widest) p
  1185. X                 (math-read-big-rec h v1 h2 v2
  1186. X                        baseline (nth 3 widest) t))
  1187. X             h the-h2))))
  1188. X
  1189. X      ;; Return all relevant information to caller.
  1190. X      (setq the-baseline baseline
  1191. X        the-h2 h)
  1192. X      (or short (= the-h2 h2)
  1193. X      (math-read-big-error h baseline))
  1194. X      p))
  1195. )
  1196. X
  1197. (defun math-read-big-char (h v)
  1198. X  (or (and (>= h h1)
  1199. X       (< h h2)
  1200. X       (>= v v1)
  1201. X       (< v v2)
  1202. X       (let ((line (nth v lines)))
  1203. X         (and line
  1204. X          (< h (length line))
  1205. X          (aref line h))))
  1206. X      ?\ )
  1207. )
  1208. X
  1209. (defun math-read-big-emptyp (eh1 ev1 eh2 ev2 &optional what error)
  1210. X  (and (< ev1 v1) (setq ev1 v1))
  1211. X  (and (< eh1 h1) (setq eh1 h1))
  1212. X  (and (> ev2 v2) (setq ev2 v2))
  1213. X  (and (> eh2 h2) (setq eh2 h2))
  1214. X  (or what (setq what ?\ ))
  1215. X  (let ((p (nthcdr ev1 lines))
  1216. X    h)
  1217. X    (while (and (< ev1 ev2)
  1218. X        (progn
  1219. X          (setq h (min eh2 (length (car p))))
  1220. X          (while (and (>= (setq h (1- h)) eh1)
  1221. X                  (= (aref (car p) h) what)))
  1222. X          (and error (>= h eh1)
  1223. X               (math-read-big-error h ev1 (if (stringp error)
  1224. X                              error
  1225. X                            "Whitespace expected")))
  1226. X          (< h eh1)))
  1227. X      (setq ev1 (1+ ev1)
  1228. X        p (cdr p)))
  1229. X    (>= ev1 ev2))
  1230. )
  1231. X
  1232. (defun math-read-big-error (h v &optional msg)
  1233. X  (let ((pos 0)
  1234. X    (p lines))
  1235. X    (while (> v 0)
  1236. X      (setq pos (+ pos 1 (length (car p)))
  1237. X        p (cdr p)
  1238. X        v (1- v)))
  1239. X    (setq h (+ pos (min h (length (car p))))
  1240. X      err-msg (list 'error h (or msg "Syntax error")))
  1241. X    (throw 'syntax nil))
  1242. )
  1243. X
  1244. (defun math-read-big-balance (h v what &optional commas)
  1245. X  (let* ((line (nth v lines))
  1246. X     (len (min h2 (length line)))
  1247. X     (count 1))
  1248. X    (while (> count 0)
  1249. X      (if (>= h len)
  1250. X      (if what
  1251. X          (math-read-big-error h1 v (format "Unmatched `%s'" what))
  1252. X        (setq count 0))
  1253. X    (if (memq (aref line h) '(?\( ?\[))
  1254. X        (setq count (1+ count))
  1255. X      (if (if (and commas (= count 1))
  1256. X          (or (memq (aref line h) '(?\) ?\] ?\, ?\;))
  1257. X              (and (eq (aref line h) ?\.)
  1258. X               (< (1+ h) len)
  1259. X               (eq (aref line (1+ h)) ?\.)))
  1260. X        (memq (aref line h) '(?\) ?\])))
  1261. X          (setq count (1- count))))
  1262. X    (setq h (1+ h))))
  1263. X    h)
  1264. )
  1265. X
  1266. X
  1267. X
  1268. X
  1269. SHAR_EOF
  1270. chmod 0644 calc-lang.el ||
  1271. echo 'restore of calc-lang.el failed'
  1272. Wc_c="`wc -c < 'calc-lang.el'`"
  1273. test 36543 -eq "$Wc_c" ||
  1274.     echo 'calc-lang.el: original size 36543, current size' "$Wc_c"
  1275. rm -f _shar_wnt_.tmp
  1276. fi
  1277. # ============= calc-macs.el ==============
  1278. if test -f 'calc-macs.el' -a X"$1" != X"-c"; then
  1279.     echo 'x - skipping calc-macs.el (File already exists)'
  1280.     rm -f _shar_wnt_.tmp
  1281. else
  1282. > _shar_wnt_.tmp
  1283. echo 'x - extracting calc-macs.el (Text)'
  1284. sed 's/^X//' << 'SHAR_EOF' > 'calc-macs.el' &&
  1285. ;; Calculator for GNU Emacs, part I [calc-macs.el]
  1286. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  1287. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  1288. X
  1289. ;; This file is part of GNU Emacs.
  1290. X
  1291. ;; GNU Emacs is distributed in the hope that it will be useful,
  1292. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  1293. ;; accepts responsibility to anyone for the consequences of using it
  1294. ;; or for whether it serves any particular purpose or works at all,
  1295. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  1296. ;; License for full details.
  1297. X
  1298. ;; Everyone is granted permission to copy, modify and redistribute
  1299. ;; GNU Emacs, but only under the conditions described in the
  1300. ;; GNU Emacs General Public License.   A copy of this license is
  1301. ;; supposed to have been given to you along with GNU Emacs so you
  1302. ;; can know your rights and responsibilities.  It should be in a
  1303. ;; file named COPYING.  Among other things, the copyright notice
  1304. ;; and this notice must be preserved on all copies.
  1305. X
  1306. X
  1307. (provide 'calc-macs)
  1308. X
  1309. (defun calc-need-macros () nil)
  1310. X
  1311. X
  1312. (defmacro calc-record-compilation-date-macro ()
  1313. X  (` (setq calc-installed-date (, (concat (current-time-string)
  1314. X                      " by "
  1315. X                      (user-full-name)))))
  1316. )
  1317. X
  1318. X
  1319. (defmacro calc-wrapper (&rest body)
  1320. X  (list 'calc-do (list 'function (append (list 'lambda ()) body)))
  1321. )
  1322. X
  1323. ;; We use "point" here to generate slightly smaller byte-code than "t".
  1324. (defmacro calc-slow-wrapper (&rest body)
  1325. X  (list 'calc-do (list 'function (append (list 'lambda ()) body)) (point))
  1326. )
  1327. X
  1328. X
  1329. (defmacro math-showing-full-precision (body)
  1330. X  (list 'let
  1331. X    '((calc-float-format calc-full-float-format))
  1332. X    body)
  1333. )
  1334. X
  1335. X
  1336. (defmacro math-with-extra-prec (delta &rest body)
  1337. X  (` (math-normalize
  1338. X      (let ((calc-internal-prec (+ calc-internal-prec (, delta))))
  1339. X    (,@ body))))
  1340. )
  1341. X
  1342. X
  1343. ;;; Faster in-line version zerop, normalized values only.
  1344. (defmacro Math-zerop (a)   ; [P N]
  1345. X  (` (if (consp (, a))
  1346. X     (and (not (memq (car (, a)) '(bigpos bigneg)))
  1347. X          (if (eq (car (, a)) 'float)
  1348. X          (eq (nth 1 (, a)) 0)
  1349. X        (math-zerop (, a))))
  1350. X       (eq (, a) 0)))
  1351. )
  1352. X
  1353. (defmacro Math-integer-negp (a)
  1354. X  (` (if (consp (, a))
  1355. X     (eq (car (, a)) 'bigneg)
  1356. X       (< (, a) 0)))
  1357. )
  1358. X
  1359. (defmacro Math-integer-posp (a)
  1360. X  (` (if (consp (, a))
  1361. X     (eq (car (, a)) 'bigpos)
  1362. X       (> (, a) 0)))
  1363. )
  1364. X
  1365. X
  1366. (defmacro Math-negp (a)
  1367. X  (` (if (consp (, a))
  1368. X     (or (eq (car (, a)) 'bigneg)
  1369. X         (and (not (eq (car (, a)) 'bigpos))
  1370. X          (if (memq (car (, a)) '(frac float))
  1371. X              (Math-integer-negp (nth 1 (, a)))
  1372. X            (math-negp (, a)))))
  1373. X       (< (, a) 0)))
  1374. )
  1375. X
  1376. X
  1377. (defmacro Math-looks-negp (a)   ; [P x] [Public]
  1378. X  (` (or (Math-negp (, a))
  1379. X     (and (consp (, a)) (or (eq (car (, a)) 'neg)
  1380. X                (and (memq (car (, a)) '(* /))
  1381. X                     (or (math-looks-negp (nth 1 (, a)))
  1382. X                     (math-looks-negp (nth 2 (, a)))))))))
  1383. )
  1384. X
  1385. X
  1386. (defmacro Math-posp (a)
  1387. X  (` (if (consp (, a))
  1388. X     (or (eq (car (, a)) 'bigpos)
  1389. X         (and (not (eq (car (, a)) 'bigneg))
  1390. X          (if (memq (car (, a)) '(frac float))
  1391. X              (Math-integer-posp (nth 1 (, a)))
  1392. X            (math-posp (, a)))))
  1393. X       (> (, a) 0)))
  1394. )
  1395. X
  1396. X
  1397. (defmacro Math-integerp (a)
  1398. X  (` (or (not (consp (, a)))
  1399. X     (memq (car (, a)) '(bigpos bigneg))))
  1400. )
  1401. X
  1402. X
  1403. (defmacro Math-natnump (a)
  1404. X  (` (if (consp (, a))
  1405. X     (eq (car (, a)) 'bigpos)
  1406. X       (>= (, a) 0)))
  1407. )
  1408. X
  1409. (defmacro Math-ratp (a)
  1410. X  (` (or (not (consp (, a)))
  1411. X     (memq (car (, a)) '(bigpos bigneg frac))))
  1412. )
  1413. X
  1414. (defmacro Math-realp (a)
  1415. X  (` (or (not (consp (, a)))
  1416. X     (memq (car (, a)) '(bigpos bigneg frac float))))
  1417. )
  1418. X
  1419. (defmacro Math-anglep (a)
  1420. X  (` (or (not (consp (, a)))
  1421. X     (memq (car (, a)) '(bigpos bigneg frac float hms))))
  1422. )
  1423. X
  1424. (defmacro Math-numberp (a)
  1425. X  (` (or (not (consp (, a)))
  1426. X     (memq (car (, a)) '(bigpos bigneg frac float cplx polar))))
  1427. )
  1428. X
  1429. (defmacro Math-scalarp (a)
  1430. X  (` (or (not (consp (, a)))
  1431. X     (memq (car (, a)) '(bigpos bigneg frac float cplx polar hms))))
  1432. )
  1433. X
  1434. (defmacro Math-vectorp (a)
  1435. X  (` (and (consp (, a)) (eq (car (, a)) 'vec)))
  1436. )
  1437. X
  1438. (defmacro Math-messy-integerp (a)
  1439. X  (` (and (consp (, a))
  1440. X      (eq (car (, a)) 'float)
  1441. X      (>= (nth 2 (, a)) 0)))
  1442. )
  1443. X
  1444. (defmacro Math-objectp (a)    ;  [Public]
  1445. X  (` (or (not (consp (, a)))
  1446. X     (memq (car (, a))
  1447. X           '(bigpos bigneg frac float cplx polar hms date sdev intv mod))))
  1448. )
  1449. X
  1450. (defmacro Math-objvecp (a)    ;  [Public]
  1451. X  (` (or (not (consp (, a)))
  1452. X     (memq (car (, a))
  1453. X           '(bigpos bigneg frac float cplx polar hms date
  1454. X            sdev intv mod vec))))
  1455. )
  1456. X
  1457. X
  1458. ;;; Compute the negative of A.  [O O; o o] [Public]
  1459. (defmacro Math-integer-neg (a)
  1460. X  (` (if (consp (, a))
  1461. X     (if (eq (car (, a)) 'bigpos)
  1462. X         (cons 'bigneg (cdr (, a)))
  1463. X       (cons 'bigpos (cdr (, a))))
  1464. X       (- (, a))))
  1465. )
  1466. X
  1467. X
  1468. (defmacro Math-equal (a b)
  1469. X  (` (= (math-compare (, a) (, b)) 0))
  1470. )
  1471. X
  1472. (defmacro Math-lessp (a b)
  1473. X  (` (= (math-compare (, a) (, b)) -1))
  1474. )
  1475. X
  1476. X
  1477. (defmacro math-working (msg arg)    ; [Public]
  1478. X  (` (if (eq calc-display-working-message 'lots)
  1479. X     (math-do-working (, msg) (, arg))))
  1480. )
  1481. X
  1482. X
  1483. (defmacro calc-with-default-simplification (body)
  1484. X  (list 'let
  1485. X    '((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num)))
  1486. X                   calc-simplify-mode)))
  1487. X    body)
  1488. )
  1489. X
  1490. X
  1491. (defmacro Math-primp (a)
  1492. X  (` (or (not (consp (, a)))
  1493. X     (memq (car (, a)) '(bigpos bigneg frac float cplx polar
  1494. X                    hms date mod var))))
  1495. )
  1496. X
  1497. X
  1498. (defmacro calc-with-trail-buffer (&rest body)
  1499. X  (` (let ((save-buf (current-buffer))
  1500. X       (calc-command-flags nil))
  1501. X       (unwind-protect
  1502. X       (, (append '(progn
  1503. X             (set-buffer (calc-trail-display t))
  1504. X             (goto-char calc-trail-pointer))
  1505. X              body))
  1506. X     (set-buffer save-buf))))
  1507. )
  1508. X
  1509. X
  1510. (defmacro Math-num-integerp (a)
  1511. X  (` (or (not (consp (, a)))
  1512. X     (memq (car (, a)) '(bigpos bigneg))
  1513. X     (and (eq (car (, a)) 'float)
  1514. X          (>= (nth 2 (, a)) 0))))
  1515. )
  1516. X
  1517. X
  1518. (defmacro Math-bignum-test (a)   ; [B N; B s; b b]
  1519. X  (` (if (consp (, a))
  1520. X     (, a)
  1521. X       (math-bignum (, a))))
  1522. )
  1523. X
  1524. X
  1525. (defmacro Math-equal-int (a b)
  1526. X  (` (or (eq (, a) (, b))
  1527. X     (and (consp (, a))
  1528. X          (eq (car (, a)) 'float)
  1529. X          (eq (nth 1 (, a)) (, b))
  1530. X          (= (nth 2 (, a)) 0))))
  1531. )
  1532. X
  1533. (defmacro Math-natnum-lessp (a b)
  1534. X  (` (if (consp (, a))
  1535. X     (and (consp (, b))
  1536. X          (= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1))
  1537. X       (or (consp (, b))
  1538. X       (< (, a) (, b)))))
  1539. )
  1540. X
  1541. X
  1542. (defmacro math-format-radix-digit (a)   ; [X D]
  1543. X  (` (aref math-radix-digits (, a)))
  1544. )
  1545. X
  1546. X
  1547. SHAR_EOF
  1548. chmod 0644 calc-macs.el ||
  1549. echo 'restore of calc-macs.el failed'
  1550. Wc_c="`wc -c < 'calc-macs.el'`"
  1551. test 6182 -eq "$Wc_c" ||
  1552.     echo 'calc-macs.el: original size 6182, current size' "$Wc_c"
  1553. rm -f _shar_wnt_.tmp
  1554. fi
  1555. # ============= calc-maint.el ==============
  1556. if test -f 'calc-maint.el' -a X"$1" != X"-c"; then
  1557.     echo 'x - skipping calc-maint.el (File already exists)'
  1558.     rm -f _shar_wnt_.tmp
  1559. else
  1560. > _shar_wnt_.tmp
  1561. echo 'x - extracting calc-maint.el (Text)'
  1562. sed 's/^X//' << 'SHAR_EOF' > 'calc-maint.el' &&
  1563. ;; Calculator for GNU Emacs, maintenance routines
  1564. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  1565. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  1566. X
  1567. ;; This file is part of GNU Emacs.
  1568. X
  1569. ;; GNU Emacs is distributed in the hope that it will be useful,
  1570. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  1571. ;; accepts responsibility to anyone for the consequences of using it
  1572. ;; or for whether it serves any particular purpose or works at all,
  1573. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  1574. ;; License for full details.
  1575. X
  1576. ;; Everyone is granted permission to copy, modify and redistribute
  1577. ;; GNU Emacs, but only under the conditions described in the
  1578. ;; GNU Emacs General Public License.   A copy of this license is
  1579. ;; supposed to have been given to you along with GNU Emacs so you
  1580. ;; can know your rights and responsibilities.  It should be in a
  1581. ;; file named COPYING.  Among other things, the copyright notice
  1582. ;; and this notice must be preserved on all copies.
  1583. X
  1584. X
  1585. X
  1586. X
  1587. (defun calc-compile ()
  1588. X  "Compile all parts of Calc.
  1589. Unix usage:
  1590. X     emacs -batch -l calc-maint -f calc-compile"
  1591. X  (interactive)
  1592. X  (if (equal (user-full-name) "David Gillespie")
  1593. X      (load "~/lisp/newbytecomp"))
  1594. X  (setq byte-compile-verbose t)
  1595. X  (if noninteractive
  1596. X      (let ((old-message (symbol-function 'message))
  1597. X        (old-write-region (symbol-function 'write-region))
  1598. X        (comp-was-func nil)
  1599. X        (comp-len 0))
  1600. X    (unwind-protect
  1601. X        (progn
  1602. X          (fset 'message (symbol-function 'calc-compile-message))
  1603. X          (fset 'write-region (symbol-function 'calc-compile-write-region))
  1604. X          (calc-do-compile))
  1605. X      (fset 'message old-message)
  1606. X      (fset 'write-region old-write-region)))
  1607. X    (calc-do-compile))
  1608. )
  1609. X
  1610. (defun calc-do-compile ()
  1611. X  (let ((make-backup-files nil)
  1612. X    (changed-rules nil)
  1613. X    (changed-units nil)
  1614. X    (message-bug (string-match "^18.\\([0-4][0-9]\\|5[0-6]\\)"
  1615. X                   emacs-version)))
  1616. X    (setq max-lisp-eval-depth (max 400 max-lisp-eval-depth))
  1617. X
  1618. X    ;; Make sure we're in the right directory.
  1619. X    (find-file "calc.el")
  1620. X    (if (= (buffer-size) 0)
  1621. X    (error "This command must be used in the Calc source directory."))
  1622. X
  1623. X    ;; Make sure current directory is in load-path.
  1624. X    (setq load-path (cons default-directory load-path))
  1625. X    (load "calc-macs.el" nil t t)
  1626. X    (provide 'calc)
  1627. X    (provide 'calc-ext)
  1628. X
  1629. X    ;; Compile all the source files.
  1630. X    (let ((files (append
  1631. X          '("calc.el" "calc-ext.el")
  1632. X          (sort (directory-files
  1633. X             default-directory nil
  1634. X             "\\`\\(calc-.[^x].*\\|macedit\\)\\.el\\'")
  1635. X            'string<))))
  1636. X      (while files
  1637. X    (if (file-newer-than-file-p (car files) (concat (car files) "c"))
  1638. X        (progn
  1639. X          (if (string-match "calc-rules" (car files))
  1640. X          (setq changed-rules t))
  1641. X          (if (string-match "calc-units" (car files))
  1642. X          (setq changed-units t))
  1643. X          (or message-bug (message ""))
  1644. X          (byte-compile-file (car files)))
  1645. X      (message "File %s is up to date." (car files)))
  1646. X    (if (string-match "calc\\(-ext\\)?.el" (car files))
  1647. X        (load (concat (car files) "c") nil t t))
  1648. X    (setq files (cdr files))))
  1649. X
  1650. X    (if (or changed-units changed-rules)
  1651. X    (condition-case err
  1652. X        (progn
  1653. X
  1654. X          ;; Pre-build the units table.
  1655. X          (if changed-units
  1656. X          (progn
  1657. X            (or message-bug (message ""))
  1658. X            (save-excursion
  1659. X              (calc-create-buffer)
  1660. X              (math-build-units-table))
  1661. X            (find-file "calc-units.elc")
  1662. X            (goto-char (point-max))
  1663. X            (insert "\n(setq math-units-table '"
  1664. X                (prin1-to-string math-units-table)
  1665. X                ")\n")
  1666. X            (save-buffer)))
  1667. X
  1668. X          ;; Pre-build rewrite rules for j D, j M, etc.
  1669. X          (if changed-rules
  1670. X          (let ((rules nil))
  1671. X            (or message-bug (message ""))
  1672. X            (find-file "calc-rules.elc")
  1673. X            (goto-char (point-min))
  1674. X            (while (re-search-forward "defun calc-\\([A-Za-z]*Rules\\)"
  1675. X                          nil t)
  1676. X              (setq rules (cons (buffer-substring (match-beginning 1)
  1677. X                              (match-end 1))
  1678. X                    rules)))
  1679. X            (goto-char (point-min))
  1680. X            (re-search-forward "\n(defun calc-[A-Za-z]*Rules")
  1681. X            (beginning-of-line)
  1682. X            (delete-region (point) (point-max))
  1683. X            (mapcar (function
  1684. X                 (lambda (v)
  1685. X                   (let* ((vv (intern (concat "var-" v)))
  1686. X                      (val (save-excursion
  1687. X                         (calc-create-buffer)
  1688. X                         (calc-var-value vv))))
  1689. X                 (insert "\n(defun calc-" v " () '"
  1690. X                     (prin1-to-string val) ")\n"))))
  1691. X                (sort rules 'string<))
  1692. X            (save-buffer))))
  1693. X      (error (message "Unable to pre-build tables %s" err))))
  1694. X    (message "Done.  Don't forget to install with \"make public\" or \"make private\"."))
  1695. )
  1696. X
  1697. (defun calc-compile-message (fmt &rest args)
  1698. X  (cond ((and (= (length args) 2)
  1699. X          (stringp (car args))
  1700. X          (string-match ".elc?\\'" (car args))
  1701. X          (symbolp (nth 1 args)))
  1702. X     (let ((name (symbol-name (nth 1 args))))
  1703. X       (princ (if comp-was-func ", " "  "))
  1704. X       (if (and comp-was-func (eq (string-match comp-was-func name) 0))
  1705. X           (setq name (substring name (1- (length comp-was-func))))
  1706. X         (setq comp-was-func (if (string-match "\\`[a-zA-Z]+-" name)
  1707. X                     (substring name 0 (match-end 0))
  1708. X                   " ")))
  1709. X       (if (> (+ comp-len (length name)) 75)
  1710. X           (progn
  1711. X         (princ "\n  ")
  1712. X         (setq comp-len 0)))
  1713. X       (princ name)
  1714. X       (send-string-to-terminal "")  ; cause an fflush(stdout)
  1715. X       (setq comp-len (+ comp-len 2 (length name)))))
  1716. X    ((and (setq comp-was-func nil
  1717. X            comp-len 0)
  1718. X          (= (length args) 1)
  1719. X          (stringp (car args))
  1720. X          (string-match ".elc?\\'" (car args)))
  1721. X     (or (string-match "Saving file %s..." fmt)
  1722. X         (funcall old-message fmt (file-name-nondirectory (car args)))))
  1723. X    ((string-match "\\(Preparing\\|Building\\).*\\.\\.\\.$" fmt)
  1724. X     (send-string-to-terminal (apply 'format fmt args)))
  1725. X    ((string-match "\\(Preparing\\|Building\\).*\\.\\.\\. *done$" fmt)
  1726. X     (send-string-to-terminal "done\n"))
  1727. X    (t (apply old-message fmt args)))
  1728. )
  1729. X
  1730. (defun calc-compile-write-region (start end filename &optional append visit)
  1731. X  (if (eq visit t)
  1732. X      (set-buffer-auto-saved))
  1733. X  (if (and (string-match "\\.elc" filename)
  1734. X       (= start (point-min))
  1735. X       (= end (point-max)))
  1736. X      (save-excursion
  1737. X    (goto-char (point-min))
  1738. X    (if (search-forward "\n(require (quote calc-macs))\n" nil t)
  1739. X        (replace-match ""))
  1740. X    (setq end (point-max))))
  1741. X  (funcall old-write-region start end filename append 'quietly)
  1742. X  (message "Wrote %s" filename)
  1743. X  nil
  1744. )
  1745. X
  1746. X
  1747. X
  1748. (defun calc-split-manual (&optional force)
  1749. X  "Split the Calc manual into separate Tutorial and Reference manuals.
  1750. Use this if your TeX installation is too small-minded to handle
  1751. calc.texinfo all at once.
  1752. Usage:  C-x C-f calc.texinfo RET
  1753. X        M-x calc-split-manual RET"
  1754. X  (interactive "P")
  1755. X  (or (let ((case-fold-search t))
  1756. X    (string-match "calc\\.texinfo" (buffer-name)))
  1757. X      force
  1758. X      (error "This command should be used in the calc.texinfo buffer."))
  1759. X  (let ((srcbuf (current-buffer))
  1760. X    tutpos refpos endpos (maxpos (point-max)))
  1761. X    (goto-char 1)
  1762. X    (search-forward "@c [tutorial]")
  1763. SHAR_EOF
  1764. true || echo 'restore of calc-maint.el failed'
  1765. fi
  1766. echo 'End of  part 19'
  1767. echo 'File calc-maint.el is continued in part 20'
  1768. echo 20 > _shar_seq_.tmp
  1769. exit 0
  1770. exit 0 # Just in case...
  1771. -- 
  1772. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1773. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1774. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1775. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1776.