;;; Written by Kenichi Handa (1998)

;; Define a new character set for Latin extra codes.
(eval-and-compile
  (or (charsetp 'latin-extra)
      (progn
	(defvar latin-extra-iso-final-char
	  (get-unused-iso-final-char 1 96))

	(define-charset nil 'latin-extra
	  (vector 1 96 1 0 latin-extra-iso-final-char 1 "Ltn-ex" "Latin-Extra"
		  "Microsoft Latin extra codes")))))

;; Define a new coding system which can read/write Latin extra codes.
;; The decoder and encoder for this coding system is written in CCL.

(define-ccl-program decode-latin-extra
  `(2
    (loop
     (read r0)
     (if (r0 < 128)
	 (write-repeat r0)
       (if (r0 < 160)
	   ((r0 += 32)
	    (r1 = ,(charset-id 'latin-extra))
	    (write-multibyte-character r1 r0)
	    (repeat))
	 ((r1 = ,(charset-id 'latin-iso8859-1))
	  (write-multibyte-character r1 r0)
	  (repeat)))))))

(define-ccl-program encode-latin-extra
  `(1
    (loop
     (read-multibyte-character r0 r1)
     (if (r0 == ,(charset-id 'ascii))
	 (write-repeat r1)
       (if (r0 == ,(charset-id 'latin-extra))
	   ((r1 += 96)
	    (write-repeat r1))
	 (if (r0 == ,(charset-id 'latin-iso8859-1))
	     ((r1 += 128)
	      (write-repeat r1))))))))

(or (coding-system-p 'iso-latin-1-extra)
    (make-coding-system
     'iso-latin-1-extra
     4 ?E "Latin-1 with Microsoft Extra codes (128..159)"
     '(decode-latin-extra . encode-latin-extra)
     '((safe-charsets (ascii latin-iso8859-1 latin-extra))
       (accept-latin-extra-code . t)
       (valid-codes (0 . 255)))))

;; Use Latin-1 font for Latin extra codes.  For that, we must encode
;; Emacs internal code of Latin extra to Latin-1 font of the code
;; point range 128..159.
(define-ccl-program ccl-encode-latin-font
  `(0
    (if (r0 == ,(charset-id 'latin-extra))
	(r1 += 96)
      (r1 += 128))))

;; Register this encoder in `font-ccl-encoder-alist'.
(setq font-ccl-encoder-alist
      (cons (cons "iso8859-1" ccl-encode-latin-font) font-ccl-encoder-alist))

;; Specify a Latin-1 font for latin-extra in all existing fontsets.
(if window-system
    (let ((l (fontset-list)))
      (while l
	(set-fontset-font (car l)
			  'latin-extra
			  (nth 1 (assq 'latin-iso8859-1
				       (aref (fontset-info (car l)) 2))))
	(setq l (cdr l)))))