;;; -*- Mode: Lisp -*-
;;;
;;; buf2html.l --- convert text of buffer to HTML

;;; Copyright (C) 2001 OHKUBO Hiroshi

;;; Author: OHKUBO Hiroshi <konata_o@hotmail.com>
;;; Version: 0.0.0.5
;;; Time-stamp: <2001/12/15 11:47:34 +0900>
;;; Xyzzy: 0.2.2.220

;;; buf2html:
;;;
;;;     なるべくバッファの表示を再現するような HTML を生成します。
;;;     キーワード、正規表現キーワード、text-attribute に対応していますが、
;;;     一行反転表示には対応していません。
;;;
;;;     勘で書いている部分があるのでおかしな変換があると思います。
;;;     気がついた点を知らせて頂けるとありがたいです。
;;;

;;; Install:
;;;
;;;     1. 解凍して buf2html.l を、~/site-lispにコピーします。
;;;
;;;     2. 必要ならばバイトコンパイルします。
;;;
;;;             M-x byte-compile-file
;;;
;;;     3. .xyzzy または siteinit.l に以下のコードを追加します。
;;;
;;;             (load-library "buf2html")
;;;
;;;     4. 上記の設定を反映させるために、xyzzyを再起動します。
;;;

;;; Usage:
;;;
;;;     1. M-x ini2css-file または M-x ini2css-buffer で xyzzy の
;;;        INI ファイル (標準では xyzzy.ini) からスタイルシートを生成し、
;;;        xyzzy.css というファイル名で保存。
;;;
;;;     2. 変換元のバッファで M-x buf2html または M-x buf2html-with-number し、
;;;        HTML の出力されたバッファを xyzzy.css を保存したフォルダに保存。
;;;

;;; Changes:
;;;     [Version 0.0.0.5]
;;;     Sat, 15 Dec 2001 11:19:03 +0900
;;;             ・ML で亀井さんに教えていただいたキーワード検索の方法に変更。
;;;               ・タグをハイライトするかどうかを html-highlight-mode の値で判定
;;;               ・syntax-symbol-prefix-p が non-nil の場合のハイライト
;;;               ・syntax-table の option に *syntax-option-c-preprocessor* が
;;;                 指定されていた場合の動作
;;;               上記 3 点について xyzzy と同様の動作になったと思います。
;;;
;;;     [Version 0.0.0.4]
;;;     Fri, 14 Dec 2001 18:25:03 +0900
;;;             ・tag のあるモードかどうかを syntax-table で判断するように。
;;;
;;;     Tue, 11 Dec 2001 10:30:34 +0900
;;;             ・Memo 修正。
;;;             ・<TITLE></TITLE> の間では半角スペースを &nbsp; に変換
;;;               しないように変更。
;;;
;;;     [Version 0.0.0.3]
;;;     Mon, 10 Dec 2001 17:58:20 +0900
;;;             ・context をパースする際の message の位置を変更。
;;;             ・行番号付き出力 buf2html-with-number 追加。
;;;             ・HTML 出力後バッファの modify flag を nil に。
;;;             ・その他修正。
;;;
;;;     [Version 0.0.0.2]
;;;     Fri, 07 Dec 2001 07:40:23 +0900
;;;             ・message の位置を修正。
;;;             ・bgr2rgb を buf2html-bgr2rgb に名称変更。
;;;             ・余分な HTML タグの削減。
;;;             ・キーワードが大文字小文字を区別するかの判定。
;;;             ・tag 文字 (syntax-open-tag-p, syntax-close-tag-p) を
;;;               キーワードより優先させるように修正。
;;;             ・その他修正。
;;;
;;;     [Version 0.0.0.1]
;;;     Fri, 07 Dec 2001 02:37:41 +0900
;;;             ・門田さんの mode2htm.l, ini2css.l を参考にして初版作成。
;;;

;;; Todo:
;;;     ・できれば行反転表示への対応
;;;     ・制御文字の表示
;;;     ・改行、タブ、EOF、全角スペース、半角スペースの表示
;;;     ・行間への対応
;;;     ・固定幅 bold 表示
;;;     ・lang や charset へのまともな対応
;;;     ・余分な HTML タグの削減
;;;     ・TAB 文字への対処
;;;     ・速度改善
;;;

;;; Memo:
;;;     ・正規表現キーワードよりもキーワードの方が優先される。
;;;       色が重ならないだけでなく、キーワード自体が重ならない。
;;;     ・キーワードの色よりもタグの開始・終了の色の方が優先される。
;;;       ただしタグの開始・終了文字の部分はキーワード構成部分となり得る。
;;;     ・html-highlight-mode が non-nil の場合は :tag の中でしか context は
;;;       切り替わらない。
;;;     ・context が nil 中での :string は 終了の " 自体までだが、
;;;       context が :tag 中での :string は終了の " の前まで。
;;;       "abcdefghijklmn"    "abcdefghijklmn"
;;;        ^^^^^^^^^^^^^^^ と  ^^^^^^^^^^^^^^ の違い。
;;;     ・正規表現キーワードは指定されたコンテキスト内であれば、隣接した
;;;       コンテキストをまたいでもよい。
;;;       単一のコンテキスト内でキーワードが完結する必要はない。
;;;       ("abc \"\" def" t (:color 1 0 :underline) (:string))
;;;       は 2 つの :string コンテキストによる「"abc "" def"」 をキーワードと
;;;       認識する。
;;;     ・正規表現キーワードにて個々の色設定がなされていても、begin end により除外
;;;       されている場合色はつかない。
;;;     ・("123\\(45\\(67\\)89\\)0" nil ((1 . (:color 1)) (2 . (:color 2))) t 1 1)
;;;       では、(:color 1) の色で 456789 に色がつくのではなく、67 には
;;;       (:color 2) の色で色がつく。
;;;       最後の begin end は色をつける point の範囲を group 番号で指定している。
;;;     ・text-attribute に (:underline nil) 等を指定しても、
;;;       (正規表現)キーワードで underline 等が指定されている場合は
;;;       それらは無効化されない。
;;;     ・color の nil と (:color nil) は異なる。
;;;     ・color に nil を指定するとその色指定は無視されるよう。
;;;
;;;
;;;     ・html-highlight-mode が non-nil の場合は基本的にキーワードは
;;;       タグ内部のみだが、0.2.2.207 で追加された記述方法で
;;;       nil context の中にもキーワード指定ができる。
;;;       keyword-hash-table をよくみていないがもしかしたら、キーワードファイル
;;;       自体を読んで parse しなければならない?
;;;     ・ed::regexp-keyword-list は必ず (compile-regexp-keyword-list) されている?
;;;     ・「正規表現のキーワード色分けの、グループごとの色指定」における
;;;       「colorがnilなら、同一範囲にマッチした若いグループ番号の色。tなら元の色。」
;;;       は具体的にどういうことなのか。「元の色」とは何か。
;;;       「元の色」は「地の色」(「文字色」「背景色」)であっているのか。
;;;       context は考慮する必要はないのか。
;;;

;;; Data structure:
;;;
;;;     <UNITS>  : (<UNIT>*)
;;;     <UNIT>   : (<TYPE> . <RANGE>)
;;;     <RANGES> : (<RANGE>*)
;;;     <RANGE>  : (<FROM> . <TO>)
;;;     <TYPE>   : (<keyword> . <INFO>)
;;;     <FROM>   : <POINT>
;;;     <TO>     : <POINT>
;;;     <POINT>  : <number>
;;;
;;;     <number> : /[0-9]+/
;;;     <keyword>: nil
;;;              | :string
;;;              | :comment
;;;              | :tag
;;;              | :buf2html-keyword
;;;              | :buf2html-regexp-keyword
;;;              | :buf2html-regexp-keyword-group
;;;              | :buf2html-text-attribute
;;;              | :buf2html-line-feed
;;;
;;;     <INFO>   : <TYPE> の <keyword> 毎に色々。
;;;
;;;       <keyword> == nil | :string | :comment | :tag
;;;              : nil
;;;
;;;       <keyword> == :buf2html-keyword
;;;              : compiled-color
;;;
;;;       <keyword> == :buf2html-regexp-keyword
;;;              : regexp-keyword-group-units
;;;
;;;       <keyword> == :buf2html-regexp-keyword-group
;;;              : compiled-color
;;;
;;;       <keyword> == :buf2html-text-attribute
;;;              : (btag . etag)
;;;
;;;       <keyword> == :buf2html-line-feed
;;;              : nil
;;;
;;;
;;;     ・<UNITS> を構成する <UNIT> は (<TYPE> . (<FROM> . <TO>)) の
;;;       <FROM> で昇順ソートされていなければならない。
;;;
;;;     ・<TO> は実際には範囲に含まれない。
;;;       <FROM>, <TO> は (buffer-substring <FROM> <TO>) となる値。
;;;

;;; Code:

(provide "buf2html")

(defconstant *buf2html-version* "0.0.0.5"
  "buf2html: Version")

(defvar *buf2html-color-context* t
  "buf2html: context の解析を行う")
(defvar *buf2html-color-keyword* t
  "buf2html: キーワードの解析を行う")
(defvar *buf2html-color-regexp-keyword* t
  "buf2html: 正規表現キーワードの解析を行う")
(defvar *buf2html-color-text-attribute* t
  "buf2html: text-attribute の解析を行う")

(defvar *buf2html-auto-mode-parameter-string* "Mode: html"
  "buf2html: HTML 文書に含める xyzzy 用のモード指定")
(defvar *buf2html-date-format* "%a, %d %b %Y %H:%M:%S %Z"
  "buf2html: HTML 文書に含める日付書式")
(defvar *buf2html-time-stamp-start* "Last updated: <"
  "buf2html: 日付の前の文字列")
(defvar *buf2html-time-stamp-end* ">"
  "buf2html: 日付の後の文字列")

(defvar *buf2html-buffer-tmp* "*buf2html: Tmp*"
  "buf2html: 作業バッファ名")
(defvar *buf2html-buffer-css* "*buf2html: CSS*"
  "buf2html: スタイルシート出力バッファ名")
(defvar *buf2html-buffer-html* "*buf2html: HTML*"
  "buf2html: HTML 文書出力バッファ名")

(defvar *buf2html-convert-half-space* nil
  "buf2html: 半角スペースを必ず &nbsp; に変換")
(defvar *buf2html-number-link* t
  "buf2html: 行番号出力時、行番号の <A> タグを付加")

(defvar *buf2html-string-encode-alist*
  '(("&" . "&amp;")
    ("<" . "&lt;")
    (">" . "&gt;")
    ( "\"" . "&quot;")
;   " " は状況に応じて変換
;   (" " . "&nbsp;")
    )
  "buf2html: 変換する文字参照リスト")

(defvar *buf2html-char-code-limit* 128
  "buf2html: syntax-table を調べる char-code の限界
全て調べる場合は lisp:char-code-limit を指定")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; buf2html-with-number
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun buf2html-with-number ()
  "buf2html: xyzzy の表示に従ってバッファを行番号つきで HTML に変換"
  (interactive)
  (buf2html t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; buf2html
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun buf2html (&optional line-number-p)
  "buf2html: xyzzy の表示に従ってバッファを HTML に変換"
  (interactive)
  (let ((point-max (point-max))
        (compiled-color-tag-table (make-hash-table))
        all-units keyword-units regexp-keyword-units text-attribute-units
        tag-char-units line-feed-units
        opitimized-keyword-color-list line-feed-p
        (source-buffer (selected-buffer)))
    (long-operation
      (save-excursion
        (buf2html-set-buffer *buf2html-buffer-html*)
        (with-output-to-buffer (*buf2html-buffer-html*)
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;; context
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          (if *buf2html-color-context*
              (setq all-units (buf2html-get-units-context))
            (setq all-units (cons nil (cons (point-min) (point-max)))))

          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;; tag-char
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          (if html-highlight-mode
              (setq tag-char-units
                    (buf2html-get-units-tag-char
                     (buf2html-get-ranges-if-context all-units '(:tag)))))

          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;; keyword
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          (when (and *buf2html-color-context*
                     *buf2html-color-keyword*
                     (boundp 'ed::keyword-hash-table))

            (setq keyword-units
                  (buf2html-get-units-keyword
                   (buf2html-range-concatenate
                    (if html-highlight-mode
                        (buf2html-get-ranges-if-context all-units '(:tag))
                      (buf2html-get-ranges-if-not-context all-units '(:string :comment))))))

            ;; keyword の compiled-color の値(数)にあった HTML タグの登録
            (buf2html-add-compiled-color-tag-hash-table
             compiled-color-tag-table (mapcar #'cdar keyword-units))

            ;; keyword の範囲を適用
            (message "Merge keyword range.")
            (setq all-units (buf2html-unit-cover all-units keyword-units))

            ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
            ;; c-preprocessor 用の特殊キーワード検索
            (when (not (zerop (logand (get-syntax-option (syntax-table))
                                      *syntax-option-c-preprocessor*)))
              (setq keyword-units
                    (buf2html-get-units-keyword-c-preprocessor
                     (buf2html-range-concatenate
                      (if html-highlight-mode
                          (buf2html-get-ranges-if-context all-units '(:tag))
                        (buf2html-get-ranges-if-not-context all-units '(:string :comment))))))

              ;; keyword の compiled-color の値(数)にあった HTML タグの登録
              (buf2html-add-compiled-color-tag-hash-table
               compiled-color-tag-table (mapcar #'cdar keyword-units))

              ;; keyword の範囲を適用
              (message "Merge c preprocessor keyword range.")
              (setq all-units (buf2html-unit-cover all-units keyword-units))
              )
            )

          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;; regexp-keyword
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          (when (and *buf2html-color-context*
                     *buf2html-color-regexp-keyword*
                     (boundp 'ed::regexp-keyword-list))
            ;; 正規表現キーワードの compiled-color の値にあった HTML タグの登録
            (buf2html-add-compiled-color-tag-hash-table
             compiled-color-tag-table
             (buf2html-make-regexp-keyword-color-list ed::regexp-keyword-list))

            (let (regexp colors compiled-context begin end (i 0)
                  (regexp-keyword-list-length (length ed::regexp-keyword-list)))
              (dolist (regexp-keyword ed::regexp-keyword-list)
                (incf i)
                (message "Parse regexp keyword: ~D/~D" i regexp-keyword-list-length)
;               (setq regexp (car regexp-keyword))
;               (setq colors (cadr regexp-keyword))
                (setq compiled-context (caddr regexp-keyword))
;               (setq begin (cadddr regexp-keyword))
;               (setq end (car (cddddr regexp-keyword)))
                (setq regexp-keyword-units
                      (buf2html-get-units-regexp-keyword
                       (buf2html-range-concatenate
                        (buf2html-get-ranges-if-context
                         all-units
                         (buf2html-decode-compiled-context compiled-context)))
                       regexp-keyword))
                ;; regexp-keyword の範囲を適用
                (message "Merge regexp keyword range: ~D/~D"
                         i regexp-keyword-list-length)
                (setq all-units
                      (buf2html-unit-cover all-units regexp-keyword-units))))
            )
          
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;; tag-char をキーワードよりも優先
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          (when html-highlight-mode
            (message "Merge tag-char range.")
            (setq all-units (buf2html-unit-cover all-units tag-char-units)))
          
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;; 最適化
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          (setq all-units (buf2html-unit-concatenate all-units))

          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;; 行分割 (line-feed)
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          (setq line-feed-p line-number-p)
          (when line-feed-p
            (setq line-feed-units (buf2html-get-units-line-feed))
            (setq all-units (buf2html-unit-cover all-units line-feed-units)))

          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;; text-attribute
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          (when *buf2html-color-text-attribute*
            (message "Parse text attribute.")
            (setq text-attribute-units (buf2html-get-units-text-attribute)))

          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;; 出力
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          (buf2html-print-header line-number-p)
          (buf2html-print-body all-units compiled-color-tag-table
                               text-attribute-units line-number-p)
          (buf2html-print-footer line-number-p)
          (message "Output HTML: done."))
        (set-buffer-modified-p nil *buf2html-buffer-html*))
      (pop-to-buffer *buf2html-buffer-html*)
      (set-buffer-fileio-encoding (buffer-fileio-encoding source-buffer))
      (set-buffer-eol-code (buffer-eol-code source-buffer))
      (html-mode)
      )))

(defun buf2html-get-units-context (&key begin end nomsg)
  "buf2html: context の範囲のリストを作成"
  (let ((point-max (point-max)) rate pre-rate
        all-units context pre-context from to range)
    (save-excursion
      (unless begin
        (setq begin (point-min)))
      (unless end
        (setq end (point-max)))
      (setq from begin)
      (goto-char from)
      (if (= begin 0)
          (setq context nil)
        (setq context (parse-point-syntax (1- (point)))))
      (setq rate -1)
      (while (and (<= (point) end) (not (eobp)))
        (setq pre-context context)
        (setq context (parse-point-syntax (point)))
        (unless nomsg
          (setq pre-rate rate)
          (setq rate (floor (* 100 (/ (point) point-max))))
          (if (/= pre-rate rate)
              (message "Parse context: ~2D%" rate)))
        (unless (eq pre-context context)
          (do-events)
;         (unless nomsg
;           (message "Parse context: ~2D%" (floor (* 100 (/ (point) point-max)))))
          ;; とりあえず 0.2.2.219 での context を元に適当にやってみる
          (cond
           ; nil から context が切り替わる際は一つ前から
           ((eq pre-context nil)
            (setq to (1- (point))))
           ; nil に切り替わる際はそのまま
           ((eq context nil)
            (setq to (point)))
           ;; :tag については html(+)-mode でしか試していないのであってないかも
           ((eq pre-context :tag)
            (setq to (1- (point))))
           ((and (eq context :tag)
                 (eq pre-context :string))
            (setq to (1+ (point))))
           (t
            (setq to (point))))

          (setq range (cons from to))
          (when (< from to)
            (push (cons (cons pre-context nil) range) all-units)
            (setq from to))
#|
          ; こんな感じのことをすると少しは早くなるかも。でもバグの元かも。
          (cond
           ((eq context :string)
            (skip-syntax-spec-forward "^\"")
            (backward-char)))
|#
          )
        (forward-char))
      (setq range (cons from end))
      (if (< from end)
          (push (cons (cons pre-context nil) range) all-units)))
    (unless nomsg
      (message "Parse context: done."))
    (nreverse all-units)))

(defun buf2html-get-units-line-feed ()
  "buf2html: 改行文字の範囲(位置)のリストを作成"
  (let (line-feed-units point)
    (goto-char (point-min))
    (while (scan-buffer "\n" :tail t)
      (setq point (1- (point)))
      (push (cons (cons :buf2html-line-feed nil) (cons point (1+ point)))
            line-feed-units))
    (nreverse line-feed-units)))

(defun buf2html-get-units-tag-char (ranges)
  "buf2html: タグの開始、終了文字の範囲(位置)のリストを作成"
  (let (tag-char-units from to c)
    (dolist (range ranges)
      (setq from (car range))
      (setq to (cdr range))
      (when (< from to)
        (setq c (char (buffer-substring from (1+ from)) 0))
        (if (or (syntax-open-tag-p c) (syntax-close-tag-p c))
            (push (cons (cons :tag nil) (cons from (1+ from))) tag-char-units))
        (when (< from (1- to))
          (setq c (char (buffer-substring (1- to) to) 0))
          (if (or (syntax-open-tag-p c) (syntax-close-tag-p c))
              (push (cons (cons :tag nil) (cons (1- to) to)) tag-char-units)))))
    (nreverse tag-char-units)))

(defun buf2html-get-units-text-attribute ()
  "buf2html: text-attribute の範囲のリストを作成"
  (let (text-attribute-units btag etag range key value)
    (dolist (text-attributes (list-text-attributes (point-min) (point-max)))
      (setq range (cons (car text-attributes) (cadr text-attributes)))
      (setq text-attributes (cdddr text-attributes))
      (setq btag "")
      (setq etag "")
      (while text-attributes
        (setq key (car text-attributes))
        (setq value (cadr text-attributes))
        (setq text-attributes (cddr text-attributes))
        (case key
          (:foreground
           (setq btag (format nil "~A<SPAN class=\"fg~D\">" btag value))
           (setq etag (format nil "</SPAN>~A" etag)))
          (:background
           (setq btag (format nil "~A<SPAN class=\"bg~D\">" btag value))
           (setq etag (format nil "</SPAN>~A" etag)))
          (:bold
           (when value
             (setq btag (concat btag "<SPAN class=\"bold\">"))
             (setq etag (concat "</SPAN>" etag))))
          (:underline
           (when value
             (setq btag (concat btag "<SPAN class=\"underline\">"))
             (setq etag (concat "</SPAN>" etag))))
          (:strike-out
           (when value
             (setq btag (concat btag "<SPAN class=\"strike-out\">"))
             (setq etag (concat "</SPAN>" etag))))))
      (push (cons (cons :buf2html-text-attribute (cons btag etag)) range)
            text-attribute-units))
    (nreverse text-attribute-units)))

(defun buf2html-get-units-keyword (ranges)
  "buf2html: キーワードの範囲のリストを作成"
  (let ((point-max (point-max)) keyword-units from to regexp compiled-color
        str begin end)
    (dolist (range ranges)
      (setq from (car range))
      (setq to (cdr range))
      (goto-char from)
      (message "Parse keyword: ~2D%" (floor (* 100 (/ from point-max))))
      (setq regexp (compile-regexp "\\(\\s@\\|\\s{\\|\\s\\\\)?\\(\\sw\\|\\s_\\)+"))
      (while (scan-buffer regexp :limit to)
        (setq str (match-string 0))
        (setq begin (match-beginning 0))
        (setq end (match-end 0))
        (when (syntax-symbol-prefix-p (char str 0))
          (setq str (substring 1 str))
          (setq begin (1- begin)))
        (multiple-value-bind (compiled-color init)
            (gethash str ed::keyword-hash-table)
          (when init
            (push (cons (cons :buf2html-keyword compiled-color)
                        (cons begin end)) keyword-units)))
        (goto-char end)))
    (message "Parse keyword: done.")
    (nreverse keyword-units)))

(defun buf2html-get-units-keyword-c-preprocessor (ranges)
  "buf2html: C preprocessor 用キーワードの範囲のリストを作成"
  (let ((point-max (point-max)) keyword-units from to regexp compiled-color
        str begin end)
    (dolist (range ranges)
      (setq from (car range))
      (setq to (cdr range))
      (goto-char from)
      (message "Parse c preprocessor keyword: ~2D%" (floor (* 100 (/ from point-max))))
      (setq regexp (compile-regexp "#[ \t]*\\(\\(\\sw\\|\\s_\\)+\\)"))
      (while (scan-buffer regexp :limit to)
        (setq str (concat "#" (match-string 1)))
        (setq begin (match-beginning 0))
        (setq end (match-end 0))
        (multiple-value-bind (compiled-color init)
            (gethash str ed::keyword-hash-table)
          (when init
            (push (cons (cons :buf2html-keyword compiled-color)
                        (cons begin end)) keyword-units)))
        (goto-char end)))
    (message "Parse c preprocessor keyword: done.")
    (nreverse keyword-units)))

(defun buf2html-get-units-regexp-keyword (ranges regexp-keyword)
  "buf2html: 正規表現キーワードの範囲のリストを作成"
  (let ((regexp (car regexp-keyword))
        (colors (cadr regexp-keyword))
        (compiled-context (caddr regexp-keyword))
        (begin (cadddr regexp-keyword))
        (end (car (cddddr regexp-keyword)))
        regexp-keyword-units from to
        (point-max (point-max))
        whole-range enable-range regexp-keyword-group-units
        group-number group-range compiled-color)
    (dolist (range ranges)
      (setq from (car range))
      (setq to (cdr range))
      (goto-char from)
      (while (scan-buffer regexp :tail t :limit to)
        (setq whole-range (cons (match-beginning 0) (match-end 0)))
        (setq enable-range
              (cons (if (minusp begin) (match-end (* -1 begin)) (match-beginning begin))
                    (if (minusp end) (match-beginning (* -1 end)) (match-end end))))
        (setq whole-range enable-range)
        (setq regexp-keyword-group-units
              (list (cons (cons :buf2html-regexp-keyword-group nil)
                          (copy-list whole-range))))
        (cond
         ((not (consp colors))
          (setq compiled-color colors)
          (setq regexp-keyword-group-units
                (buf2html-unit-cover
                 regexp-keyword-group-units
                 (list (cons (cons :buf2html-regexp-keyword-group compiled-color)
                             enable-range)))))
         (t
          (dolist (color (sort colors #'< :key #'car)); group 順にソート
            (setq group-number (car color))
            (setq compiled-color (cdr color))
            (setq group-range (cons (match-beginning group-number)
                                    (match-end group-number)))
            
            (when (and compiled-color                 ; compiled-color が nil でない
                       (buf2html-in-range-p group-range enable-range))
              (setq regexp-keyword-group-units
                    (buf2html-unit-cover
                     regexp-keyword-group-units
                     (list (cons (cons :buf2html-regexp-keyword-group compiled-color)
                                 group-range))))))))
        (push (cons (cons :buf2html-regexp-keyword regexp-keyword-group-units) whole-range)
              regexp-keyword-units)))
    (nreverse regexp-keyword-units)))

(defun buf2html-make-regexp-keyword-color-list (regexp-keyword-list)
  "buf2html: regexp-keyword-list から color のリストを作成"
  (let (compiled-color-list)
    (when regexp-keyword-list
      ;; nil は使うので必ずいれておく。
      (pushnew nil compiled-color-list :test 'eql)
      (dolist (compiled-colors (mapcar #'cadr regexp-keyword-list))
        (cond
         ((consp compiled-colors)
          (dolist (compiled-color (mapcar #'cdr compiled-colors))
            (pushnew compiled-color compiled-color-list :test 'eql)))
         ((numberp compiled-colors)
          (pushnew compiled-colors compiled-color-list :test 'eql))
         (t
          (pushnew compiled-colors compiled-color-list :test 'eql)))))
    compiled-color-list))

(defun buf2html-add-compiled-color-tag-hash-table (hash-table compiled-colors)
  "buf2html: compiled-colors に対応する HTML タグを hash-table に登録"
  (when (hash-table-p hash-table)
    (dolist (compiled-color compiled-colors)
      (multiple-value-bind (value init)
          (gethash compiled-color hash-table)
        (unless init
          (setf (gethash compiled-color hash-table)
                (buf2html-make-compiled-color-tag compiled-color)))))
    hash-table))

;; 正規表現キーワードのグループ毎の色指定での
;; color 部分が t の場合の動作がよくわからない。
;; nil のときは、compiled-color は nil
;; t   のときは、compiled-color は 0
(defun buf2html-make-compiled-color-tag (compiled-color)
  "buf2html: compiled-color に対応する HTML タグを作成"
  (unless (numberp compiled-color)
    (return-from buf2html-make-compiled-color-tag (cons "" "")))
  (let ((fg-bg-p (= (logand compiled-color #x1) #x1))
        (line-p (= (logand compiled-color #x2) #x2))
        (bold-p (= (logand compiled-color #x200000) #x200000))
        (underline-p (= (logand compiled-color #x800000) #x800000))
        (strike-out-p (= (logand compiled-color #x1000000) #x1000000))
        (color (logand compiled-color (lognot #x1)
                       (lognot #x2) (lognot #x200000) (lognot #x800000) (lognot #x1000000)))
        (btag "") (etag ""))

    (cond
     (fg-bg-p
      (setq btag (format nil "<SPAN class=\"fg~D bg~D\">"
                         (floor (logand color #x1f00) #x200)
                         (floor (logand color #x1f0000) #x20000)))
      (setq etag "</SPAN>"))
     (t
      (cond
       ((= color 0)
        (setq btag "" etag ""))
       ((= color (gethash #\0 ed::*keyword-translate-hash-table*));keyword1
        (setq btag "<SPAN class=\"keyword1\">" etag "</SPAN>"))
       ((= color (gethash #\1 ed::*keyword-translate-hash-table*));keyword2
        (setq btag "<SPAN class=\"keyword2\">" etag "</SPAN>"))
       ((= color (gethash #\2 ed::*keyword-translate-hash-table*));keyword3
        (setq btag "<SPAN class=\"keyword3\">" etag "</SPAN>"))
       ((= color (gethash #\3 ed::*keyword-translate-hash-table*));keyword1 反転
        (setq btag "<SPAN class=\"keyword1inverse\">" etag "</SPAN>"))
       ((= color (gethash #\4 ed::*keyword-translate-hash-table*));keyword2 反転
        (setq btag "<SPAN class=\"keyword2inverse\">" etag "</SPAN>"))
       ((= color (gethash #\5 ed::*keyword-translate-hash-table*));keyword3 反転
        (setq btag "<SPAN class=\"keyword3inverse\">" etag "</SPAN>"))
       ((= color (gethash #\S ed::*keyword-translate-hash-table*));string
        (setq btag "<SPAN class=\"string\">" etag "</SPAN>"))
       ((= color (gethash #\T ed::*keyword-translate-hash-table*));tag
        (setq btag "<SPAN class=\"tag\">" etag "</SPAN>"))
       ((= color (gethash #\C ed::*keyword-translate-hash-table*));comment
        (setq btag "<SPAN class=\"comment\">" etag "</SPAN>")))))

    ;; bold
    (when bold-p
      (setq btag (concat btag "<SPAN class=\"bold\">"))
      (setq etag (concat "</SPAN>" etag)))
    ;; underline
    (when underline-p
      (setq btag (concat btag "<SPAN class=\"underline\">"))
      (setq etag (concat "</SPAN>" etag)))
    ;; strike-out
    (when strike-out-p
      (setq btag (concat btag "<SPAN class=\"strike-out\">"))
      (setq etag (concat "</SPAN>" etag)))
    ;; line (どうすればよい?)
    (when line-p
      t)
    (cons btag etag)))

(defun buf2html-decode-compiled-context (compiled-context)
  "buf2html: compiled-context をデコードし context のリストを作成"
  (let (context-list)
    (if (= (logand compiled-context #x1) #x1)
        (push nil context-list))
    (if (= (logand compiled-context #x2) #x2)
        (push :string context-list))
    (if (= (logand compiled-context #x4) #x4)
        (push :tag context-list))
    (if (= (logand compiled-context #x8) #x8)
        (push :comment context-list))
    context-list))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; range, unit 操作関連
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun buf2html-in-range-p (position_or_range range)
  "buf2html: range に position_or_range が含まれるかどうか"
  (if (null range)
      nil
    (cond
     ((numberp position_or_range)
      (if (and (<= (car range) position_or_range)
               (<= position_or_range (cdr range)))
          range
        nil))
     ((consp position_or_range)
      (if (and (<= (car range) (car position_or_range))
               (<= (cdr position_or_range) (cdr range)))
          range
        nil))
     (t nil))))

(defun buf2html-range-concatenate (ranges)
  "buf2html: 隣接した range を連結"
  (let (return-ranges work-range)
    (unless ranges
      (return-from buf2html-range-concatenate nil))
    (setq work-range (car ranges))
    (dolist (range (cdr ranges))
      (cond
       ((= (cdr work-range) (car range))
        (setq work-range (cons (car work-range) (cdr range))))
       (t
        (push work-range return-ranges)
        (setq work-range range))))
    (push work-range return-ranges)
    (nreverse return-ranges)))

(defun buf2html-unit-concatenate (units)
  "buf2html: 隣接した同じ type の unit を連結"
  (let (return-units work-unit)
    (unless units
      (return-from buf2html-unit-concatenate nil))
    (setq work-unit (car units))
    (dolist (unit (cdr units))
      (cond
       ((and (equal (car work-unit) (car unit))
             (= (cddr work-unit) (cadr unit)))
        (setq work-unit (cons (car work-unit)
                              (cons (cadr work-unit) (cddr unit)))))
       (t
        (push work-unit return-units)
        (setq work-unit unit))))
    (push work-unit return-units)
    (nreverse return-units)))

(defun buf2html-unit-cover (base-units priority-units)
  "buf2html: base-units に priority-units をかぶせる"
  (let (return-units base-type-range priority-type-range base-unit priority-unit start)
    (setq start 0)
    (setq base-unit (car base-units))
    (setq base-units (cdr base-units))
    (setq priority-unit (car priority-units))
    (setq priority-units (cdr priority-units))
    (while (and base-unit priority-unit)
      (cond
       ;; 重ならず base が前
       ((<= (cddr base-unit) (cadr priority-unit))
        (if (< (cadr base-unit) (cddr base-unit))
            (push base-unit return-units))
        (setq start (cddr base-unit)))
       ;; 重ならず priority が前
       ((<= (cddr priority-unit) (cadr base-unit))
        (if (< (cadr priority-unit) (cddr priority-unit))
            (push priority-unit return-units))
        (setq start (cddr priority-unit))
        (setq priority-unit nil))
       ;; priority が base を含む
       ((and (<= (cadr priority-unit) (cadr base-unit))
             (<= (cddr base-unit) (cddr priority-unit)))
        (if (< (cadr priority-unit) (cddr priority-unit))
            (push priority-unit return-units))
        (setq start (cddr priority-unit))
        (setq priority-unit nil))
       ;; base が priority を含む
       ((and (<= (cadr base-unit) (cadr priority-unit))
             (<= (cddr priority-unit) (cddr base-unit)))
        (if (< (cadr base-unit) (cadr priority-unit))
            (push (cons (car base-unit)
                        (cons (cadr base-unit) (cadr priority-unit))) return-units))
        (if (< (cadr priority-unit) (cddr priority-unit))
            (push priority-unit return-units))
        (setq start (cddr priority-unit))
        (setq priority-unit nil))
       ;; 重なり priority が前
       ((<= (cadr priority-unit) (cadr base-unit))
        (if (< (cadr priority-unit) (cddr priority-unit))
            (push priority-unit return-units))
        (setq start (cddr priority-unit))
        (setq priority-unit nil))
       ;; 重なり priority が後
       (t
        (if (< (cadr base-unit) (cadr priority-unit))
            (push (cons (car base-unit)
                        (cons (cadr base-unit) (cadr priority-unit))) return-units))
        (if (< (cadr priority-unit) (cddr priority-unit))
            (push priority-unit return-units))
        (setq start (cddr priority-unit))
        (setq priority-unit nil)))

      (unless priority-unit
        (setq priority-unit (car priority-units))
        (setq priority-units (cdr priority-units)))
      (while (and base-unit (<= (cddr base-unit) start))
        (setq base-unit (car base-units))
        (setq base-units (cdr base-units)))
      (if (and base-unit (< (cadr base-unit) start))
          (setq base-unit (cons (car base-unit) (cons start (cddr base-unit)))))
      )
    (cond
     (base-unit
      (while base-unit
        (if (< (cadr base-unit) (cddr base-unit))
            (push base-unit return-units))
        (setq base-unit (car base-units))
        (setq base-units (cdr base-units))))
     (priority-unit
      (while priority-unit
        (if (< (cadr priority-unit) (cddr priority-unit))
            (push priority-unit return-units))
        (setq priority-unit (car priority-units))
        (setq priority-units (cdr priority-units)))))
    (nreverse return-units)))

(defun buf2html-get-ranges-if-context (units contexts)
  "buf2html: contexts に含まれる context である unit の range のリストを返す"
  (mapcar #'cdr
          (remove contexts units
                  :test #'(lambda (contexts context)
                            (not (position context contexts)))
                  :key #'caar)))

(defun buf2html-get-ranges-if-not-context (units contexts)
  "buf2html: contexts に含まれない context である unit の range のリストを返す"
  (mapcar #'cdr
          (remove contexts units
                  :test #'(lambda (contexts context)
                            (position context contexts))
                  :key #'caar)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 出力関連
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun buf2html-protect-string (body &optional convert-half-space-p)
  "buf2html: 文字参照を変換した文字列を返す"
  (dolist (cell *buf2html-string-encode-alist*)
    (setq body (substitute-string body (car cell) (cdr cell))))
  (if convert-half-space-p
      (setq body (substitute-string body " " "&nbsp;")))
  body)

(defun buf2html-print-header (&optional line-number-p)
  "buf2html: HTML の開始部分を出力"
  (let (lang title charset encoding-display-name)
    (if (setq title (get-buffer-file-name))
        (setq title (concat (pathname-name title)
                            (if (pathname-type title)
                                (concat "." (pathname-type title)) "")))
      (setq title (buffer-name (selected-buffer))))
    (setq encoding-display-name (char-encoding-display-name (buffer-fileio-encoding)))
    (cond
     ((string-match "日本語" encoding-display-name)
      (setq lang "ja"))
     ((string-match "中国語" encoding-display-name)
      nil)
     ((string-match "韓国語" encoding-display-name)
      nil)
     (t
      nil))
    (cond
     ((string-match "Shift_JIS" encoding-display-name)
      (setq charset "Shift_JIS"))
     ((string-match "EUC-JP" encoding-display-name)
      (setq charset "EUC-JP"))
     ((string-match "ISO-2022-JP" encoding-display-name)
      (setq charset "ISO-2022-JP"))
     ((string-match "UTF-8" encoding-display-name)
      (setq charset "UTF-8"))
     (t
      nil))
     
    (format t "~A~%" "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">")
    (if (stringp *buf2html-auto-mode-parameter-string* )
        (format t "~A~A~A~%" "<!-- -*- "
                *buf2html-auto-mode-parameter-string* " -*- -->"))
    (if (and (stringp *buf2html-date-format*)
             (stringp *buf2html-time-stamp-start*)
             (stringp *buf2html-time-stamp-end*))
        (format t "~A~A~A~A~A~%"
                "<!-- " *buf2html-time-stamp-start*
                (format-date-string *buf2html-date-format*)
                *buf2html-time-stamp-end* " -->"))
    (format t "~A~A~A~%" "<!-- Created by buf2html-" *buf2html-version* " -->")
    (if lang
        (format t "~A~A~A~%" "<HTML lang=\"" lang "\">")
      (format t "~A~%" "<HTML>"))
    (format t "~A~%" "  <HEAD>")
    (format t "~A~A~A~%" "    <META name=\"GENERATOR\" content=\"buf2html-"
            *buf2html-version* "\">")
    (if charset
        (format t "~A~A~A~%" "    <META http-equiv=\"Content-Type\" content=\"text/html; charset=" charset "\">"))
    (format t "~A~%" "    <LINK href=\"xyzzy.css\" rel=\"stylesheet\" type=\"text/css\">")
    (format t "~A~A~A~%" "    <TITLE>" (buf2html-protect-string title) "</TITLE>")
    (format t "~A~%" "  </HEAD>")
    (format t "~A~%" "  <BODY class=\"bgcolor\">")
    (if line-number-p
        (if *buf2html-number-link*
            (format t "~A" "<OL>\n<LI><CODE><A name=\"1\">")
          (format t "~A" "<OL>\n<LI><CODE>"))
      (format t "~A~%" "    <PRE>"))
    ))

(defun buf2html-print-footer (&optional line-number-p)
  "buf2html: HTML の終了部分を出力"
  (if line-number-p
      (format t "~A~%" "</OL>")
    (format t "~A~%" "</PRE>"))
  (format t "~A~%" "  </BODY>")
  (format t "~A~%" "</HTML>"))

(defun buf2html-print-body (all-units compiled-color-tag-table text-attribute-units
                            &optional line-number-p)
  "buf2html: HTML のメイン部分を出力"
  (let ((point-max (point-max)) btag etag
        type range tags (line-number 1)
        regexp-keyword-group-units regexp-keyword-group-range)
    (flet ((print-range (range btag etag text-attribute-units)
             (let (text-attribute-unit
                   text-attribute-tags
                   text-attribute-range
                   (convert-half-space-p (or *buf2html-convert-half-space* line-number-p)))
;              ;; 念のため前の部分を除外
;              (while (and text-attribute-units
;                          (<= (cddar text-attribute-units) (car range)))
;                (setq text-attribute-units (cdr text-attribute-units)))

               ;; text-attribute-units の先頭を取得(先頭には残したまま)
               (when text-attribute-units
                 (setq text-attribute-unit (car text-attribute-units))
                 (setq text-attribute-tags (cdar text-attribute-unit))
                 (setq text-attribute-range (cdr text-attribute-unit))
                 (if (< (car text-attribute-range) (car range))
                     (setq text-attribute-range
                           (cons (car range) (cdr text-attribute-range)))))
               
               (while (< (car range) (cdr range))
                 (cond
                  ;; text-attribute-range と関係がない場合
                  ((or (null text-attribute-range)
                       (<= (cdr range) (car text-attribute-range)))
                   (format t "~A~A~A"
                           btag
                           (buf2html-protect-string
                            (buffer-substring (car range) (cdr range))
                            convert-half-space-p)
                           etag)
                   (return))
                  ;; text-attribute-range が range の終端以降まである場合
                  ((< (cdr range) (cdr text-attribute-range))
                   (format t "~A" btag)
                   (if (< (car range) (car text-attribute-range))
                       (format t "~A"
                               (buf2html-protect-string
                                (buffer-substring (car range) (car text-attribute-range))
                                convert-half-space-p)))
                   (format t "~A~A~A~A"
                           (car text-attribute-tags)
                           (buf2html-protect-string
                            (buffer-substring (car text-attribute-range) (cdr range))
                            convert-half-space-p)
                           (cdr text-attribute-tags) etag)
                   (return))
                  ;; text-attribute-range が range に含まれる場合
                  (t
                   (format t "~A" btag)
                   (if (< (car range) (car text-attribute-range))
                       (format t "~A"
                               (buf2html-protect-string
                                (buffer-substring (car range) (car text-attribute-range))
                                convert-half-space-p)))
                   (format t "~A~A~A~A"
                           (car text-attribute-tags)
                           (buf2html-protect-string
                            (buffer-substring (car text-attribute-range)
                                              (cdr text-attribute-range))
                            convert-half-space-p)
                           (cdr text-attribute-tags)
                           etag)
                   (setq range (cons (cdr text-attribute-range) (cdr range)))

                   ;; 使用済みの text-attribute-unit を先頭から除外
                   (setq text-attribute-units (cdr text-attribute-units))
                   (if text-attribute-units
                       (progn
                         (setq text-attribute-unit (car text-attribute-units))
                         (setq text-attribute-tags (cdar text-attribute-unit))
                         (setq text-attribute-range (cdr text-attribute-unit)))
                     (progn
                       (setq text-attribute-unit nil)
                       (setq text-attribute-tags nil)
                       (setq text-attribute-range nil)))))))
             text-attribute-units))
      
      (dolist (all-unit all-units)
        (setq type (car all-unit))
        (setq range (cdr all-unit))
        (message "Output HTML: ~2D%" (floor (* 100 (/ (car range) point-max))))
        (case (car type)
          ((nil)
           (setq text-attribute-units
                 (print-range range "" "" text-attribute-units)))
          (:string
           (setq text-attribute-units
                 (print-range range "<SPAN class=\"string\">" "</SPAN>"
                              text-attribute-units)))
          (:comment
           (setq text-attribute-units
                 (print-range range "<SPAN class=\"comment\">" "</SPAN>"
                              text-attribute-units)))
          (:tag
           (setq text-attribute-units
                 (print-range range "<SPAN class=\"tag\">" "</SPAN>"
                              text-attribute-units)))
          (:buf2html-keyword
           (setq tags (gethash (cdr type) compiled-color-tag-table))
           (setq text-attribute-units
                 (print-range range (car tags) (cdr tags) text-attribute-units)))
          (:buf2html-regexp-keyword
           (setq regexp-keyword-group-units (cdr type))
           (dolist (regexp-keyword-group-unit regexp-keyword-group-units)
             (setq tags (gethash (cdar regexp-keyword-group-unit)
                                 compiled-color-tag-table))
             (setq regexp-keyword-group-range (cdr regexp-keyword-group-unit))
             (if (< (car regexp-keyword-group-range) (car range))
                 (setq regexp-keyword-group-range
                       (cons (car range) (cdr regexp-keyword-group-range))))
             (if (< (cdr range) (cdr regexp-keyword-group-range))
                 (setq regexp-keyword-group-range
                       (cons (car regexp-keyword-group-range) (cdr range))))
             (if (< (car regexp-keyword-group-range) (cdr regexp-keyword-group-range))
                 (setq text-attribute-units
                       (print-range regexp-keyword-group-range (car tags) (cdr tags)
                                    text-attribute-units)))))
          (:buf2html-line-feed
           (cond
            ((not line-number-p)
             (setq text-attribute-units
                   (print-range range "" "" text-attribute-units)))
            ((= (cdr range) point-max)
             (if *buf2html-number-link*
                 (setq text-attribute-units
                       (print-range range "</A></CODE></LI>" ""
                                    text-attribute-units))
               (setq text-attribute-units
                     (print-range range "</CODE></LI>" ""
                                  text-attribute-units))))
            (t
             (incf line-number)
             (if *buf2html-number-link*
                 (setq text-attribute-units
                       (print-range range "</A></CODE></LI>"
                                    (format nil "<LI><CODE><A name=\"~D\">"
                                            line-number)
                                    text-attribute-units))
               (setq text-attribute-units
                     (print-range range "</CODE></LI>" "<LI><CODE>"
                                  text-attribute-units))))))

          (t
           (setq text-attribute-units
                 (print-range range "" "" text-attribute-units))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syntax-table 関連
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 使用していない
(defun buf2html-syntax-table-check ()
  "buf2html: syntax-table を調べる"
  (let ((percent -1) pre-percent c
        open-tag-characters close-tag-characters
        start-comment-characters end-comment-characters
        start-multi-comment-1-characters start-multi-comment-2-characters
        end-multi-comment-1-characters end-multi-comment-2-characters)
    (dotimes (i *buf2html-char-code-limit*)
      (setq pre-percent percent)
      (setq percent (floor (* 100 (/ i *buf2html-char-code-limit*))))
      (if (/= pre-percent percent) (message "Check syntax table: ~2D%" percent))
      (setq c (code-char i))
      (if (syntax-open-tag-p c) (push c open-tag-characters))
      (if (syntax-close-tag-p c) (push c close-tag-characters))
      (if (syntax-start-comment-p c) (push c start-comment-characters))
      (if (syntax-end-comment-p c) (push c end-comment-characters))
      (if (syntax-start-multi-comment-1-p c) (push c start-multi-comment-1-characters))
      (if (syntax-start-multi-comment-2-p c) (push c start-multi-comment-2-characters))
      (if (syntax-end-multi-comment-1-p c) (push c end-multi-comment-1-characters))
      (if (syntax-end-multi-comment-2-p c) (push c end-multi-comment-2-characters))
      )
    (values open-tag-characters close-tag-characters
            start-comment-characters end-comment-characters
            start-multi-comment-1-characters start-multi-comment-2-characters
            end-multi-comment-1-characters end-multi-comment-2-characters)
    ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ini2css-file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ini2css-file (ini-path)
  "buf2html: xyzzy の設定ファイルからスタイルシートを生成"
  (interactive "fFind ini file: "
    :title0 "Find ini file"
    :default0 (let ((path (concat (si:system-root) "usr/" (user-name) "/"
                                  (case (os-platform)
                                    ('windows-95 "w95")
                                    ('windows-98 "w98")
                                    ('windows-wme "wme")
                                    ('windows-nt "wnt")
                                    ('windows-w2k "w2k"))
                                  "/xyzzy.ini")))
                (if (file-exist-p path) path "")))
  (if (file-exist-p ini-path)
      (progn
        (save-excursion
          (buf2html-set-buffer *buf2html-buffer-tmp*)
          (with-output-to-buffer (*buf2html-buffer-tmp*)
            (with-open-file (fp ini-path)
              (let ((line nil))
                (while (setq line (read-line fp nil nil nil))
                  (format t "~A~%" line)))))
          (set-buffer *buf2html-buffer-tmp*)
          (goto-char (point-min))
          (ini2css-buffer)
          (delete-buffer (find-buffer *buf2html-buffer-tmp*)))
        (pop-to-buffer *buf2html-buffer-css*))
    (message "ファイルが存在しません")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ini2css-buffer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ini2css-buffer ()
  "buf2html: 現在のバッファからスタイルシートを生成"
  (interactive)
  (let (start-point end-point colors-alist)
    (save-excursion
      (goto-char (point-min))
      (when (scan-buffer "^\\[Colors\\]" :regexp t :case-fold t)
        (setq start-point (point))
        (setq end-point
              (if (scan-buffer "^\\[.+\\]" :regexp t :no-dup t) (point) (point-max)))
        (save-restriction
          (narrow-to-region start-point end-point)
          (goto-char (point-min))
          (while (scan-buffer "^\\([^=]+\\)=#\\([0-9a-f]+\\)"
                              :regexp t :case-fold t :no-dup t)
            (push (cons (match-string 1)
                        (buf2html-bgr2rgb (parse-integer (match-string 2) :radix 16)))
                  colors-alist)))))
    (buf2html-set-buffer *buf2html-buffer-css*)
    (with-output-to-buffer (*buf2html-buffer-css*)
      (flet ((format-selector (colors-alist selector fg-item &optional bg-item single-line)
               (let (fgcolor bgcolor)
                 (if (stringp fg-item)
                     (setq fgcolor (find fg-item colors-alist :key 'car :test 'string-equal)))
                 (if (stringp bg-item)
                     (setq bgcolor (find bg-item colors-alist :key 'car :test 'string-equal)))
                 (when (or fgcolor bgcolor)
                   (format t "~A {" selector)
                   (unless single-line (format t "~%"))
                   (when fgcolor
                     (format t "~A" (if single-line " " "\t"))
                     (format t "~A: #~6,'0x;" "color" (cdr fgcolor))
                     (unless single-line (format t "~%")))
                   (when bgcolor
                     (format t "~A" (if single-line " " "\t"))
                     (format t "~A: #~6,'0x;" "background-color" (cdr bgcolor))
                     (unless single-line (format t "~%")))
                   (if single-line (format t " "))
                   (cond
                    ((and fgcolor bgcolor)
                     (format t "} /* ~A, ~A */~%" fg-item bg-item))
                    (fgcolor
                     (format t "} /* ~A */~%" fg-item))
                    (bgcolor
                     (format t "} /* ~A */~%" bg-item))))
                 )))
        (format-selector colors-alist ".bgcolor" "textColor" "backColor")
        (format-selector colors-alist "SPAN.keyword1" "kwdColor1")
        (format-selector colors-alist "SPAN.keyword2" "kwdColor2")
        (format-selector colors-alist "SPAN.keyword3" "kwdColor3")
        (format-selector colors-alist "SPAN.keyword1inverse" "backColor" "kwdColor1")
        (format-selector colors-alist "SPAN.keyword2inverse" "backColor" "kwdColor2")
        (format-selector colors-alist "SPAN.keyword3inverse" "backColor" "kwdColor3")
        (format-selector colors-alist "SPAN.string" "stringColor")
        (format-selector colors-alist "SPAN.comment" "commentColor")
        (format-selector colors-alist "SPAN.tag" "tagColor")
        (format-selector colors-alist ".fg0" "textColor")
        (format-selector colors-alist ".bg0" nil "backColor")
        (do ((i 1 (1+ i)))
            ((> i 15))
          (format-selector colors-alist (format nil ".fg~D" i) (format nil "fg~D" i) nil t)
          (format-selector colors-alist (format nil ".bg~D" i) nil (format nil "bg~D" i) t))
        )
      ;; bold
      (format t "~A { ~A; }~%" ".bold" "font-weight: bold")
      ;; underline
      (format t "~A { ~A; }~%" ".underline" "text-decoration: underline")
      ;; strike-out
      (format t "~A { ~A; }~%" ".strike-out" "text-decoration: line-through")

      )
    (pop-to-buffer *buf2html-buffer-css*)
    (if (fboundp 'css-mode)
        (css-mode))
    (set-buffer-modified-p nil)
    ))

;; #ffffff 以上の値はどんなフォーマット?
(defun buf2html-bgr2rgb (bgr)
  "buf2html: bgr の数値を rgb の数値に変換"
  (let ((b (floor (mod bgr #x1000000) #x10000))
        (g (floor (mod bgr #x10000) #x100))
        (r (mod bgr #x100)))
    (+ (* r #x10000) (* g #x100) b)))

(defun buf2html-set-buffer (buffer-name)
  "buf2html: 出力用バッファの準備"
  (save-excursion
    (get-buffer-create buffer-name)
    (erase-buffer buffer-name)
    (set-buffer buffer-name)
    (make-local-variable 'need-not-save)
    (setq need-not-save t)
    (make-local-variable 'need-not-save)
    (setq need-not-save t)))