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