cgit.sxemacs.org Git - packages/blob - xemacs-packages/calc/calc-maint.el

   1 ;; Calculator for GNU Emacs, maintenance routines
   2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
   3 ;; Written by Dave Gillespie, daveg@synaptics.com.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is distributed in the hope that it will be useful,
   8 ;; but WITHOUT ANY WARRANTY.  No author or distributor
   9 ;; accepts responsibility to anyone for the consequences of using it
  10 ;; or for whether it serves any particular purpose or works at all,
  11 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12 ;; License for full details.
  13
  14 ;; Everyone is granted permission to copy, modify and redistribute
  15 ;; GNU Emacs, but only under the conditions described in the
  16 ;; GNU Emacs General Public License.   A copy of this license is
  17 ;; supposed to have been given to you along with GNU Emacs so you
  18 ;; can know your rights and responsibilities.  It should be in a
  19 ;; file named COPYING.  Among other things, the copyright notice
  20 ;; and this notice must be preserved on all copies.
  21
  22
  23
  24
  25 (defun calc-compile ()
  26   "Compile all parts of Calc.
  27 Unix usage:
  28      emacs -batch -l calc-maint -f calc-compile"
  29   (interactive)
  30   (if (equal (user-full-name) "David Gillespie")
  31       (load "~/lisp/newbytecomp"))
  32   (setq byte-compile-verbose t)
  33   (if noninteractive
  34       (let ((old-message (symbol-function 'message))
  35             (old-write-region (symbol-function 'write-region))
  36             (comp-was-func nil)
  37             (comp-len 0))
  38         (unwind-protect
  39             (progn
  40               (fset 'message (symbol-function 'calc-compile-message))
  41               (fset 'write-region (symbol-function 'calc-compile-write-region))
  42               (calc-do-compile))
  43           (fset 'message old-message)
  44           (fset 'write-region old-write-region)))
  45     (calc-do-compile))
  46 )
  47
  48 (defun calc-do-compile ()
  49   (let ((make-backup-files nil)
  50         (changed-rules nil)
  51         (changed-units nil)
  52         (message-bug (string-match "^18.\\([0-4][0-9]\\|5[0-6]\\)"
  53                                    emacs-version)))
  54     (setq max-lisp-eval-depth (max 400 max-lisp-eval-depth))
  55     ;; Enable some irrelevant warnings to avoid compiler bug in 19.29:
  56     (setq byte-compile-warnings (and (string-match "^19.29" emacs-version)
  57                                      '(obsolete)))
  58
  59     ;; Make sure we're in the right directory.
  60     (find-file "calc.el")
  61     (if (= (buffer-size) 0)
  62         (error "This command must be used in the Calc source directory."))
  63
  64     ;; Make sure current directory is in load-path.
  65     (setq load-path (cons default-directory load-path))
  66     (load "calc-macs.el" nil t t)
  67     (provide 'calc)
  68     (provide 'calc-ext)
  69
  70     ;; Compile all the source files.
  71     (let ((files (append
  72                   '("calc.el" "calc-ext.el")
  73                   (sort (directory-files
  74                          default-directory nil
  75                          "\\`calc-.[^x].*\\.el\\'")
  76                         'string<))))
  77       (while files
  78         (if (file-newer-than-file-p (car files) (concat (car files) "c"))
  79             (progn
  80               (if (string-match "calc-rules" (car files))
  81                   (setq changed-rules t))
  82               (if (string-match "calc-units" (car files))
  83                   (setq changed-units t))
  84               (or message-bug (message ""))
  85               (byte-compile-file (car files)))
  86           (message "File %s is up to date." (car files)))
  87         (if (string-match "calc\\(-ext\\)?.el" (car files))
  88             (load (concat (car files) "c") nil t t))
  89         (setq files (cdr files))))
  90
  91     (if (or changed-units changed-rules)
  92         (condition-case err
  93             (progn
  94
  95               ;; Pre-build the units table.
  96               (if (and changed-units
  97                        (not (string-match "XEmacs" emacs-version)))
  98                   (progn
  99                     (or message-bug (message ""))
 100                     (save-excursion
 101                       (calc-create-buffer)
 102                       (math-build-units-table))
 103                     (find-file "calc-units.elc")
 104                     (goto-char (point-max))
 105                     (insert "\n(setq math-units-table '"
 106                             (prin1-to-string math-units-table)
 107                             ")\n")
 108                     (save-buffer)))
 109
 110               ;; Pre-build rewrite rules for j D, j M, etc.
 111               (if (and changed-rules (not (string-match "^19" emacs-version)))
 112                   (let ((rules nil))
 113                     (or message-bug (message ""))
 114                     (find-file "calc-rules.elc")
 115                     (goto-char (point-min))
 116                     (while (re-search-forward "defun calc-\\([A-Za-z]*Rules\\)"
 117                                               nil t)
 118                       (setq rules (cons (buffer-substring (match-beginning 1)
 119                                                           (match-end 1))
 120                                         rules)))
 121                     (goto-char (point-min))
 122                     (re-search-forward "\n(defun calc-[A-Za-z]*Rules")
 123                     (beginning-of-line)
 124                     (delete-region (point) (point-max))
 125                     (mapcar (function
 126                              (lambda (v)
 127                                (let* ((vv (intern (concat "var-" v)))
 128                                       (val (save-excursion
 129                                              (calc-create-buffer)
 130                                              (calc-var-value vv))))
 131                                  (insert "\n(defun calc-" v " () '"
 132                                          (prin1-to-string val) ")\n"))))
 133                             (sort rules 'string<))
 134                     (save-buffer))))
 135           (error (message "Unable to pre-build tables %s" err))))
 136     (message "Done.  Don't forget to install with \"make public\" or \"make private\"."))
 137 )
 138
 139 (defun calc-compile-message (fmt &rest args)
 140   (cond ((and (= (length args) 2)
 141               (stringp (car args))
 142               (string-match ".elc?\\'" (car args))
 143               (symbolp (nth 1 args)))
 144          (let ((name (symbol-name (nth 1 args))))
 145            (princ (if comp-was-func ", " "  "))
 146            (if (and comp-was-func (eq (string-match comp-was-func name) 0))
 147                (setq name (substring name (1- (length comp-was-func))))
 148              (setq comp-was-func (if (string-match "\\`[a-zA-Z]+-" name)
 149                                      (substring name 0 (match-end 0))
 150                                    " ")))
 151            (if (> (+ comp-len (length name)) 75)
 152                (progn
 153                  (princ "\n  ")
 154                  (setq comp-len 0)))
 155            (princ name)
 156            (send-string-to-terminal "")  ; cause an fflush(stdout)
 157            (setq comp-len (+ comp-len 2 (length name)))))
 158         ((and (setq comp-was-func nil
 159                     comp-len 0)
 160               (= (length args) 1)
 161               (stringp (car args))
 162               (string-match ".elc?\\'" (car args)))
 163          (or (string-match "Saving file %s..." fmt)
 164              (funcall old-message fmt (file-name-nondirectory (car args)))))
 165         ((string-match "\\(Preparing\\|Building\\).*\\.\\.\\.$" fmt)
 166          (send-string-to-terminal (apply 'format fmt args)))
 167         ((string-match "\\(Preparing\\|Building\\).*\\.\\.\\. *done$" fmt)
 168          (send-string-to-terminal "done\n"))
 169         (t (apply old-message fmt args)))
 170 )
 171
 172 (defun calc-compile-write-region (start end filename &optional append visit &rest rest)
 173   (if (eq visit t)
 174       (set-buffer-auto-saved))
 175   (if (and (string-match "\\.elc" filename)
 176            (= start (point-min))
 177            (= end (point-max)))
 178       (save-excursion
 179         (goto-char (point-min))
 180         (if (search-forward "\n(require (quote calc-macs))\n" nil t)
 181             (replace-match ""))
 182         (setq end (point-max))))
 183   (apply old-write-region start end filename append 'quietly rest)
 184   (message "Wrote %s" filename)
 185   nil
 186 )
 187
 188
 189
 190 (defun calc-split-tutorial (&optional force)
 191   (interactive "P")
 192   (calc-split-manual force 1))
 193
 194
 195 (defun calc-split-reference (&optional force)
 196   (interactive "P")
 197   (calc-split-manual force 2))
 198
 199
 200 (defun calc-split-manual (&optional force part)
 201   "Split the Calc manual into separate Tutorial and Reference manuals.
 202 Use this if your TeX installation is too small-minded to handle
 203 calc.texinfo all at once.
 204 Usage:  C-x C-f calc.texinfo RET
 205         M-x calc-split-manual RET"
 206   (interactive "P")
 207   (or (let ((case-fold-search t))
 208         (string-match "calc\\.texinfo" (buffer-name)))
 209       force
 210       (error "This command should be used in the calc.texinfo buffer."))
 211   (let ((srcbuf (current-buffer))
 212         tutpos refpos endpos (maxpos (point-max)))
 213     (goto-char 1)
 214     (search-forward "@c [tutorial]")
 215     (beginning-of-line)
 216     (setq tutpos (point))
 217     (search-forward "@c [reference]")
 218     (beginning-of-line)
 219     (setq refpos (point))
 220     (search-forward "@c [end]")
 221     (beginning-of-line)
 222     (setq endpos (point))
 223     (or (eq part 2)
 224         (progn
 225           (find-file "calctut.tex")
 226           (erase-buffer)
 227           (insert-buffer-substring srcbuf 1 refpos)
 228           (insert-buffer-substring srcbuf endpos maxpos)
 229           (calc-split-volume "I" "ref" "Tutorial" "Reference")
 230           (save-buffer)))
 231     (or (eq part 1)
 232         (progn
 233           (find-file "calcref.tex")
 234           (erase-buffer)
 235           (insert-buffer-substring srcbuf 1 tutpos)
 236           (insert "\n@tex\n\\global\\advance\\chapno by 1\n@end tex\n")
 237           (insert-buffer-substring srcbuf refpos maxpos)
 238           (calc-split-volume "II" "tut" "Reference" "Tutorial")
 239           (save-buffer)))
 240     (switch-to-buffer srcbuf)
 241     (goto-char 1))
 242   (message (cond ((eq part 1) "Wrote file calctut.tex")
 243                  ((eq part 2) "Wrote file calcref.tex")
 244                  (t "Wrote files calctut.tex and calcref.tex")))
 245 )
 246
 247 (defun calc-split-volume (number fix name other-name)
 248   (goto-char 1)
 249   (search-forward "@c [title]\n")
 250   (search-forward "Manual")
 251   (delete-backward-char 6)
 252   (insert name)
 253   (search-forward "@c [volume]\n")
 254   (insert "@sp 1\n@center Volume " number ": " name "\n")
 255   (let ((pat (format "@c \\[fix-%s \\(.*\\)\\]\n" fix)))
 256     (while (re-search-forward pat nil t)
 257       (let ((topic (buffer-substring (match-beginning 1) (match-end 1))))
 258         (re-search-forward "@\\(p?xref\\){[^}]*}")
 259         (let ((cmd (buffer-substring (match-beginning 1) (match-end 1))))
 260           (delete-region (match-beginning 0) (match-end 0))
 261           (insert (if (equal cmd "pxref") "see" "See")
 262                   " ``" topic "'' in @emph{the Calc "
 263                   other-name "}")))))
 264   (goto-char 1)
 265   (while (search-forward "@c [when-split]\n" nil t)
 266     (while (looking-at "@c ")
 267       (delete-char 3)
 268       (forward-line 1)))
 269   (goto-char 1)
 270   (while (search-forward "@c [not-split]\n" nil t)
 271     (while (not (looking-at "@c"))
 272       (insert "@c ")
 273       (forward-line 1)))
 274 )
 275
 276
 277 (defun calc-inline-summary ()
 278   "Make a special \"calcsum.tex\" file to be used with main manual."
 279   (calc-split-summary nil t)
 280 )
 281
 282 (defun calc-split-summary (&optional force in-line)
 283   "Make a special \"calcsum.tex\" file with just the Calc summary."
 284   (interactive "P")
 285   (or (let ((case-fold-search t))
 286         (string-match "calc\\.texinfo" (buffer-name)))
 287       force
 288       (error "This command should be used in the calc.texinfo buffer."))
 289   (let ((srcbuf (current-buffer))
 290         begpos sumpos endpos midpos)
 291     (goto-char 1)
 292     (search-forward "{Calc Manual}")
 293     (backward-char 1)
 294     (delete-backward-char 6)
 295     (insert "Summary")
 296     (search-forward "@c [begin]")
 297     (beginning-of-line)
 298     (setq begpos (point))
 299     (search-forward "@c [summary]")
 300     (beginning-of-line)
 301     (setq sumpos (point))
 302     (search-forward "@c [end-summary]")
 303     (beginning-of-line)
 304     (setq endpos (point))
 305     (find-file "calcsum.tex")
 306     (erase-buffer)
 307     (insert-buffer-substring srcbuf 1 begpos)
 308     (insert "@tex\n"
 309             "\\global\\advance\\appendixno2\n"
 310             "\\gdef\\xref#1.{See ``#1.''}\n")
 311     (setq midpos (point))
 312     (insert "@end tex\n")
 313     (insert-buffer-substring srcbuf sumpos endpos)
 314     (insert "@bye\n")
 315     (goto-char 1)
 316     (if (search-forward "{. a b c" nil t)
 317         (replace-match "{... a b c"))
 318     (goto-char 1)
 319     (if in-line
 320         (let ((buf (current-buffer))
 321               (page nil))
 322           (find-file "calc.aux")
 323           (if (> (buffer-size) 0)
 324               (progn
 325                 (goto-char 1)
 326                 (re-search-forward "{Summary-pg}{\\([0-9]+\\)}")
 327                 (setq page (string-to-int (buffer-substring (match-beginning 1)
 328                                                             (match-end 1))))))
 329           (switch-to-buffer buf)
 330           (if page
 331               (progn
 332                 (message "Adjusting starting page number to %d" page)
 333                 (goto-char midpos)
 334                 (insert (format "\\global\\pageno=%d\n" page)))
 335             (message "Unable to find page number from calc.aux")))
 336       (if (search-forward "@c smallbook" nil t)
 337           (progn   ; activate "smallbook" format for compactness
 338             (beginning-of-line)
 339             (forward-char 1)
 340             (delete-char 2))))
 341     (let ((buf (current-buffer)))
 342       (find-file "calc.ky")
 343       (if (> (buffer-size) 0)
 344           (let ((ibuf (current-buffer)))
 345             (message "Mixing in page numbers from Key Index (calc.ky)")
 346             (switch-to-buffer buf)
 347             (goto-char 1)
 348             (search-forward "notes at the end")
 349             (insert "; the number in italics is\n"
 350                     "the page number where the command is described")
 351             (while (re-search-forward
 352                     "@r{.*@: *\\([^ ]\\(.*[^ ]\\)?\\) *@:.*@:.*@:\\(.*\\)@:.*}"
 353                     nil t)
 354               (let ((key (buffer-substring (match-beginning 1) (match-end 1)))
 355                     (pos (match-beginning 3))
 356                     num)
 357                 (set-buffer ibuf)
 358                 (goto-char 1)
 359                 (let ((p '( ( "I H " . "H I " )  ; oops!
 360                             ( "@@ ' \"" . "@@" ) ( "h m s" . "@@" )
 361                             ( "\\\\" . "{\\tt\\indexbackslash }" )
 362                             ( "_" . "{\\_}" )
 363                             ( "\\^" . "{\\tt\\hat}" )
 364                             ( "<" . "{\\tt\\less}" )
 365                             ( ">" . "{\\tt\\gtr}" )
 366                             ( "\"" ) ( "@{" ) ( "@}" )
 367                             ( "~" ) ( "|" ) ( "@@" )
 368                             ( "\\+" . "{\\tt\\char43}" )
 369                             ( "# l" . "# L" )
 370                             ( "I f I" . "f I" ) ( "I f Q" . "f Q" )
 371                             ( "V &" . "&" ) ( "C-u " . "" ) ))
 372                       (case-fold-search nil))
 373                   (while p
 374                     (if (string-match (car (car p)) key)
 375                         (setq key (concat (substring key 0 (match-beginning 0))
 376                                           (or (cdr (car p))
 377                                               (format "{\\tt\\char'%03o}"
 378                                                       (aref key (1- (match-end
 379                                                                      0)))))
 380                                           (substring key (match-end 0)))))
 381                     (setq p (cdr p)))
 382                   (setq num (and (search-forward (format "\\entry {%s}{" key)
 383                                                  nil t)
 384                                  (looking-at "[0-9]+")
 385                                  (buffer-substring (point) (match-end 0)))))
 386                 (set-buffer buf)
 387                 (goto-char pos)
 388                 (insert "@pgref{" (or num "") "}")))
 389             (goto-char midpos)
 390             (insert "\\gdef\\pgref#1{\\hbox to 2em{\\indsl\\hss#1}\\ \\ }\n"))
 391         (message
 392          "Unable to find Key Index (calc.ky); no page numbers inserted"))
 393       (switch-to-buffer buf))
 394     (save-buffer))
 395   (message "Wrote file calcsum.tex")
 396 )
 397
 398
 399
 400 (defun calc-public-autoloads ()
 401   "Modify the public \"default\" file to contain the necessary autoload and
 402 global-set-key commands for Calc."
 403   (interactive)
 404   (let ((home default-directory)
 405         (p load-path)
 406         instbuf name)
 407     (while (and p
 408                 (not (file-exists-p
 409                       (setq name (expand-file-name "default" (car p)))))
 410                 (not (file-exists-p
 411                       (setq name (expand-file-name "default.el" (car p))))))
 412       (setq p (cdr p)))
 413     (or p (error "Unable to find \"default\" file.  Create one and try again."))
 414     (find-file name)
 415     (if buffer-read-only (error "No write permission for \"%s\"" buffer-file-name))
 416     (goto-char (point-max))
 417     (calc-add-autoloads home "calc-public-autoloads"))
 418 )
 419
 420 (defun calc-private-autoloads ()
 421   "Modify the user's \".emacs\" file to contain the necessary autoload and
 422 global-set-key commands for Calc."
 423   (interactive)
 424   (let ((home default-directory))
 425     (find-file "~/.emacs")
 426     (goto-char (point-max))
 427     (calc-add-autoloads home "calc-private-autoloads"))
 428 )
 429
 430 (defun calc-add-autoloads (home cmd)
 431   (barf-if-buffer-read-only)
 432   (let (top)
 433     (if (and (re-search-backward ";;; Commands added by calc-.*-autoloads"
 434                                  nil t)
 435              (setq top (point))
 436              (search-forward ";;; End of Calc autoloads" nil t))
 437         (progn
 438           (forward-line 1)
 439           (message "(Removing previous autoloads)")
 440           (delete-region top (point)))
 441       (insert "\n\n")
 442       (backward-char 1)))
 443   (insert ";;; Commands added by " cmd " on "
 444           (current-time-string) ".
 445 \(autoload 'calc-dispatch          \"calc\" \"Calculator Options\" t)
 446 \(autoload 'full-calc              \"calc\" \"Full-screen Calculator\" t)
 447 \(autoload 'full-calc-keypad       \"calc\" \"Full-screen X Calculator\" t)
 448 \(autoload 'calc-eval              \"calc\" \"Use Calculator from Lisp\")
 449 \(autoload 'defmath                \"calc\" nil t t)
 450 \(autoload 'calc                           \"calc\" \"Calculator Mode\" t)
 451 \(autoload 'quick-calc             \"calc\" \"Quick Calculator\" t)
 452 \(autoload 'calc-keypad            \"calc\" \"X windows Calculator\" t)
 453 \(autoload 'calc-embedded          \"calc\" \"Use Calc inside any buffer\" t)
 454 \(autoload 'calc-embedded-activate  \"calc\" \"Activate =>'s in buffer\" t)
 455 \(autoload 'calc-grab-region       \"calc\" \"Grab region of Calc data\" t)
 456 \(autoload 'calc-grab-rectangle    \"calc\" \"Grab rectangle of data\" t)
 457 \(setq load-path (nconc load-path (list \"" (directory-file-name home) "\")))
 458 \(global-set-key \"\\e#\" 'calc-dispatch)
 459 ;;; End of Calc autoloads.\n")
 460   (let ((delete-old-versions t))
 461     (save-buffer))
 462 )
 463
 464
 465
 466 ;;; End.