home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / packages / lispm-fonts.el < prev    next >
Encoding:
Text File  |  1993-02-17  |  6.2 KB  |  183 lines
  1. ;; Quick hack to parse LISPM-style font-shift codes.
  2. ;; Copyright (C) 1992-1993 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20.  
  21. ;; This only copes with MIT/LMI/TI style font shifts, not Symbolics.
  22. ;; It doesn't do diagram lines (ha ha).  It doesn't do output.  That
  23. ;; has to wait until it is possible to attach faces to characters
  24. ;; instead of just intervals, since this code is really talking about
  25. ;; attributes of the text instead of attributes of regions of the
  26. ;; buffer.  We could do it by mapping over the extents and hacking
  27. ;; the overlaps by hand, but that would be hard.
  28.  
  29. (make-face 'variable)
  30. (or (face-differs-from-default-p 'variable)
  31.     (set-face-font 'variable
  32.            "-*-helvetica-medium-r-*-*-*-120-*-*-*-*-*-*"))
  33.  
  34. (make-face 'variable-bold)
  35. (or (face-differs-from-default-p 'variable-bold)
  36.     (progn
  37.       ;; This is no good because helvetica-12-bold is a LOT larger than
  38.       ;; helvetica-12-medium.  Someone really blew it there.
  39.       ;; (copy-face 'variable 'variable-bold)
  40.       ;; (make-face-bold 'variable-bold)
  41.       (set-face-font 'variable-bold
  42.              "-*-helvetica-bold-r-*-*-*-100-*-*-*-*-*-*")))
  43.  
  44. (make-face 'variable-italic)
  45. (or (face-differs-from-default-p 'variable-italic)
  46.     (progn
  47.       (copy-face 'variable-bold 'variable-italic) ; see above
  48.       (make-face-unbold 'variable-italic)
  49.       (make-face-italic 'variable-italic)))
  50.  
  51. (make-face 'variable-bold-italic)
  52. (or (face-differs-from-default-p 'variable-bold-italic)
  53.     (progn
  54.       (copy-face 'variable-bold 'variable-bold-italic)
  55.       (make-face-italic 'variable-bold-italic)))
  56.  
  57. (defconst lispm-font-to-face
  58.   '(("tvfont"        . default)
  59.     ("cptfont"        . default)
  60.     ("cptfontb"        . bold)
  61.     ("cptfonti"        . italic)
  62.     ("cptfontbi"    . bold-italic)
  63.     ("base-font"    . default)
  64.     ("bigfnt"        . bold)
  65.     ("cmb8"        . variable-bold)
  66.     ("higher-medfnb"    . bold)
  67.     ("higher-tr8"    . default)
  68.     ("medfnb"        . bold)
  69.     ("medfnt"        . normal)
  70.     ("medfntb"        . bold)
  71.     ("wider-font"    . bold)
  72.     ("wider-medfnt"    . bold)
  73.     ("mets"        . variable-large)
  74.     ("metsb"        . variable-large-bold)
  75.     ("metsbi"        . variable-large-bold-italic)
  76.     ("metsi"        . variable-large-italic)
  77.     ("cmr5"        . variable)
  78.     ("cmr10"        . variable)
  79.     ("cmr18"        . variable)
  80.     ("cmold"        . variable)
  81.     ("cmdunh"        . variable)
  82.     ("hl10"        . variable)
  83.     ("hl10b"        . variable-bold)
  84.     ("hl12"        . variable)
  85.     ("hl12b"        . variable-bold)
  86.     ("hl12bi"        . variable-bold-italic)
  87.     ("hl12i"        . variable-italic)
  88.     ("hl6"        . variable)
  89.     ("hl7"        . variable)
  90.     ("tr10"        . variable)
  91.     ("tr10b"        . variable-bold)
  92.     ("tr10bi"        . variable-bold-italic)
  93.     ("tr10i"        . variable-italic)
  94.     ("tr12"        . variable)
  95.     ("tr12b"        . variable-bold)
  96.     ("tr12bi"        . variable-bold-italic)
  97.     ("tr12i"        . variable-italic)
  98.     ("tr18"        . variable-large)
  99.     ("tr18b"        . variable-large-bold)
  100.     ("tr8"        . variable)
  101.     ("tr8b"        . variable-bold)
  102.     ("tr8i"        . variable-italic)
  103.     ("5x5"        . small)
  104.     ("tiny"        . small)
  105.     ("43vxms"        . variable-large)
  106.     ("courier"        . bold)
  107.     ("adobe-courier10"    . default)
  108.     ("adobe-courier14"    . bold)
  109.     ("adobe-courier10b"    . bold)
  110.     ("adobe-courier14b"    . bold)
  111.     ("adobe-hl12"    . variable)
  112.     ("adobe-hl14"    . variable)
  113.     ("adobe-hl14b"    . variable-bold)
  114.     )
  115.   "Alist of LISPM font names to Emacs face names.")
  116.  
  117.  
  118. (defun lispm-font-to-face (lispm-font)
  119.   (if (symbolp lispm-font)
  120.       (setq lispm-font (symbol-name lispm-font)))
  121.   (let ((case-fold-search t)
  122.     face)
  123.     (setq lispm-font (downcase lispm-font))
  124.     (if (string-match "^fonts:+" lispm-font)
  125.     (setq lispm-font (substring lispm-font (match-end 0))))
  126.     (if (setq face (cdr (assoc lispm-font lispm-font-to-face)))
  127.     (if (find-face face)
  128.         face
  129.       (message "warning: unknown face %s" face)
  130.       'default)
  131.       (message "warning: unknown Lispm font %s" (upcase lispm-font))
  132.       'default)))
  133.  
  134. (defvar fonts)  ; the -*- line of the file will set this.
  135.  
  136. (defun lispm-fontify-hack-local-variables ()
  137.   ;; Sometimes code has font-shifts in the -*- line, which means that the
  138.   ;; local variables will have been read incorrectly by the emacs-lisp reader.
  139.   ;; In particular, the `fonts' variable might be corrupted.  So if there
  140.   ;; are font-shifts in the prop line, re-parse it.
  141.   (if (let ((case-fold-search t))
  142.     (and (looking-at "[ \t]*;.*-\\*-.*fonts[ \t]*:.*-\\*-")
  143.          (looking-at ".*\^F")))
  144.       (save-excursion
  145.     (save-restriction
  146.       (end-of-line)
  147.       (narrow-to-region (point-min) (point))
  148.       (goto-char (point-min))
  149.       (while (re-search-forward "\^F[0-9a-zA-Z*]" nil t)
  150.         (delete-region (match-beginning 0) (match-end 0)))
  151.       (hack-local-variables)))))
  152.  
  153. (defun lispm-fontify-buffer ()
  154.   (save-excursion
  155.     (goto-char (point-min))
  156.     (lispm-fontify-hack-local-variables)
  157.     (let ((font-stack nil)
  158.       (p (point))
  159.       c)
  160.       (while (search-forward "\^F" nil t)
  161.     (delete-char -1)
  162.     (setq c (following-char))
  163.     (delete-char 1)
  164.     (cond ((= c ?\^F)
  165.            (insert "\^F"))
  166.           ((= c ?*)
  167.            (if (and font-stack (/= p (point)))
  168.            (set-extent-face (make-extent p (point)) (car font-stack)))
  169.            (setq p (point))
  170.            (setq font-stack (cdr font-stack)))
  171.           ((or (< c ?0) (> c ?Z)) ; error...
  172.            nil)
  173.           ((>= (setq c (- c ?0)) (length fonts)) ; error...
  174.            nil)
  175.           (t
  176.            (if (and font-stack (/= p (point)))
  177.            (set-extent-face (make-extent p (point)) (car font-stack)))
  178.            (setq font-stack (cons (lispm-font-to-face (nth c fonts))
  179.                       font-stack))
  180.            (setq p (point)))))
  181.       (if (and font-stack (/= p (point)))
  182.       (set-extent-face (make-extent p (point)) (car font-stack))))))
  183.