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