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

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