Salut,
Voilà un gros patch contre 1.44.3.
- string-as-multibyte n'est plus utilisé.
- Emacs-21 offre l'héritage entre faces.
- n'utilise pas tuareg-cache si syntax-ppss peut s'utiliser à la place.
- tuareg-font-lock-symbols (un sym-lock pour Emacs).
- correction de tuareg-mode-syntax-table pour que "?i?n" ne soit pas
considéré comme un identificateur.
- execute tuareg-mode-hook plus tard (idéalement ca devrait s'exécuter
en dernier, pour donner le dernier mot à l'utilisateur).
- simplifie la set/restore de case-fold-search.
un changement similaire est possible avec tuareg-restore-syntax
en utilisant une nouvelle syntax-table tuareg-syntax-internal-table
et un (with-syntax-table ...).
- enlève un test de XEmacs qui semble aussi applicable à Emacs. S'il ne
l'est pas, il serait bon d'ajouter un commentaire expliquant pourquoi.
Il y a quelques "rough edges" (principalement les warnings a la
compilation), mais j'ai pas le temps de faire mieux pour le moment.
Stefan
Index: tuareg.el
===================================================================
RCS file: /u/monnier/cvsroot/elisp/tuareg-mode/tuareg.el,v
retrieving revision 1.1.1.10
diff -u -u -b -r1.1.1.10 tuareg.el
--- tuareg.el 18 Feb 2005 19:26:07 -0000 1.1.1.10
+++ tuareg.el 18 Feb 2005 23:46:12 -0000
@@ -53,12 +53,6 @@
(read-from-minibuffer prompt initial-input nil nil
(or history 'shell-command-history))))
-(if (not (fboundp 'string-as-multibyte))
- (defun string-as-multibyte (str)
- "Return same string for not multibyte emacs'en"
- str))
-
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Import types and help features
@@ -117,7 +111,7 @@
(*
...
*)
-(without leading `*'), set `tuareg-comment-end-extra-indent' to 1."
+\(without leading `*'), set `tuareg-comment-end-extra-indent' to 1."
:group 'tuareg :type 'boolean)
(defcustom tuareg-leading-star-in-doc nil
@@ -311,7 +305,7 @@
:group 'tuareg :type 'boolean)
(defcustom tuareg-interactive-read-only-input nil
- "*Non-nil means input send to the Caml toplevel is read-only."
+ "*Non-nil means input sent to the Caml toplevel is read-only."
:group 'tuareg :type 'boolean)
(defcustom tuareg-interactive-echo-phrase t
@@ -387,10 +381,15 @@
"Special faces for the Tuareg mode."
:group 'tuareg)
+(defconst tuareg-faces-inherit-p
+ (if (boundp 'face-attribute-name-alist)
+ (assq :inherit face-attribute-name-alist)))
+
(defface tuareg-font-lock-governing-face
- '((((background light))
- (:foreground "darkorange3" :bold t))
- (t (:foreground "orange" :bold t)))
+ (if tuareg-faces-inherit-p
+ '((t :inherit font-lock-keywords-face))
+ '((((background light)) (:foreground "darkorange3" :bold t))
+ (t (:foreground "orange" :bold t))))
"Face description for governing/leading keywords."
:group 'tuareg-faces)
(defvar tuareg-font-lock-governing-face
@@ -406,16 +405,19 @@
'tuareg-font-lock-multistage-face)
(defface tuareg-font-lock-operator-face
- '((((background light))
- (:foreground "brown4"))
- (t (:foreground "salmon")))
+ (if tuareg-faces-inherit-p
+ '((t :inherit font-lock-keywords-face))
+ '((((background light)) (:foreground "brown"))
+ (t (:foreground "khaki"))))
"Face description for all operators."
:group 'tuareg-faces)
(defvar tuareg-font-lock-operator-face
'tuareg-font-lock-operator-face)
(defface tuareg-font-lock-error-face
- '((t (:foreground "yellow" :background "red")))
+ (if tuareg-faces-inherit-p
+ '((t :inherit font-lock-warning-face))
+ '((t (:foreground "yellow" :background "red"))))
"Face description for all errors reported to the source."
:group 'tuareg-faces)
(defvar tuareg-font-lock-error-face
@@ -442,16 +444,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Support definitions
-(defvar tuareg-cache-stop (point-min))
-(make-variable-buffer-local 'tuareg-cache-stop)
-(defvar tuareg-cache nil)
-(make-variable-buffer-local 'tuareg-cache)
-(defvar tuareg-cache-local nil)
-(make-variable-buffer-local 'tuareg-cache-local)
-(defvar tuareg-cache-last-local nil)
-(make-variable-buffer-local 'tuareg-cache-last-local)
-(defvar tuareg-last-loc (cons nil nil))
-
(defun tuareg-leading-star-p ()
(and tuareg-support-leading-star-comments
(save-excursion ; this function does not make sense outside of a comment
@@ -505,6 +497,39 @@
(skip-chars-backward " \t")
(bolp)))
+(defconst tuareg-use-syntax-ppss (fboundp 'syntax-ppss)
+ "If nil, use our own parsing and caching.")
+
+(if tuareg-use-syntax-ppss
+ (progn
+ (defun tuareg-in-literal-p ()
+ "Returns non-nil if point is inside a Caml literal."
+ (nth 3 (syntax-ppss)))
+ (defun tuareg-in-comment-p ()
+ "Returns non-nil if point is inside a Caml comment."
+ (nth 4 (syntax-ppss)))
+ (defun tuareg-in-literal-or-comment-p ()
+ "Returns non-nil if point is inside a Caml literal or comment."
+ (nth 8 (syntax-ppss)))
+ (defun tuareg-beginning-of-literal-or-comment ()
+ "Skips to the beginning of the current literal or comment (or buffer)."
+ (interactive)
+ (goto-char (or (nth 8 (syntax-ppss)) (point))))
+ (defun tuareg-beginning-of-literal-or-comment-fast ()
+ (goto-char (or (nth 8 (syntax-ppss)) (point-min))))
+ ;; FIXME: not clear if moving out of a string/comment counts as 1 or no.
+ (defalias 'tuareg-backward-up-list 'backward-up-list)
+ )
+(defvar tuareg-cache-stop (point-min))
+(make-variable-buffer-local 'tuareg-cache-stop)
+(defvar tuareg-cache nil)
+(make-variable-buffer-local 'tuareg-cache)
+(defvar tuareg-cache-local nil)
+(make-variable-buffer-local 'tuareg-cache-local)
+(defvar tuareg-cache-last-local nil)
+(make-variable-buffer-local 'tuareg-cache-last-local)
+(defvar tuareg-last-loc (cons nil nil))
+
(defun tuareg-before-change-function (begin end)
(setq tuareg-cache-stop (min tuareg-cache-stop (1- begin))))
@@ -622,18 +647,6 @@
(goto-char (point-min)))
(if (eq 'b (cadar tuareg-cache-last-local)) (tuareg-backward-char)))
-(defun tuareg-false-=-p ()
- "Is the underlying `=' the first/second letter of an operator?"
- (or (memq (preceding-char) '(?: ?> ?< ?=))
- (char-equal ?= (char-after (1+ (point))))))
-
-(defun tuareg-at-phrase-break-p ()
- "Is the underlying `;' a phrase break?"
- (and (char-equal ?\; (following-char))
- (or (and (not (eobp))
- (char-equal ?\; (char-after (1+ (point)))))
- (char-equal ?\; (preceding-char)))))
-
(defun tuareg-backward-up-list ()
"Safe up-list regarding comments, literals and errors."
(let ((balance 1) (op (point)) (oc nil))
@@ -653,6 +666,21 @@
(tuareg-beginning-of-literal-or-comment-fast)))
(setq op (point)))))
+) ;; End of (if tuareg-use-syntax-ppss
+
+
+(defun tuareg-false-=-p ()
+ "Is the underlying `=' the first/second letter of an operator?"
+ (or (memq (preceding-char) '(?: ?> ?< ?=))
+ (char-equal ?= (char-after (1+ (point))))))
+
+(defun tuareg-at-phrase-break-p ()
+ "Is the underlying `;' a phrase break?"
+ (and (char-equal ?\; (following-char))
+ (or (and (not (eobp))
+ (char-equal ?\; (char-after (1+ (point)))))
+ (char-equal ?\; (preceding-char)))))
+
(defun tuareg-assoc-indent (kwop &optional look-for-let-or-and)
"Return relative indentation of the keyword given in argument."
(let ((ind (symbol-value (cdr (assoc kwop tuareg-keyword-alist))))
@@ -666,8 +694,100 @@
ind)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Sym-lock in Emacs
+
+(defcustom tuareg-font-lock-symbols t
+ "Display \\ and -> and such using symbols in fonts.
+This may sound like a neat trick, but note that it can change the
+alignment and can thus lead to surprises."
+ :type 'bool)
+
+(defvar tuareg-font-lock-symbols-alist
+ (append
+ ;; The symbols can come from a JIS0208 font.
+ (and (fboundp 'make-char) (charsetp 'japanese-jisx0208)
+ (list (cons "fun" (make-char 'japanese-jisx0208 38 75))
+ (cons "sqrt" (make-char 'japanese-jisx0208 34 101))
+ (cons "not" (make-char 'japanese-jisx0208 34 76))
+ (cons "or" (make-char 'japanese-jisx0208 34 75))
+ (cons "||" (make-char 'japanese-jisx0208 34 75))
+ (cons "&&" (make-char 'japanese-jisx0208 34 74))
+ ;; (cons "*." (make-char 'japanese-jisx0208 33 95))
+ ;; (cons "/." (make-char 'japanese-jisx0208 33 96))
+ (cons "->" (make-char 'japanese-jisx0208 34 42))
+ (cons "=>" (make-char 'japanese-jisx0208 34 77))
+ (cons "<-" (make-char 'japanese-jisx0208 34 43))
+ (cons "<>" (make-char 'japanese-jisx0208 33 98))
+ (cons "==" (make-char 'japanese-jisx0208 34 97))
+ (cons ">=" (make-char 'japanese-jisx0208 33 102))
+ (cons "<=" (make-char 'japanese-jisx0208 33 101))
+ ;; Some greek letters for type parameters.
+ (cons "'a" (make-char 'japanese-jisx0208 38 65))
+ (cons "'b" (make-char 'japanese-jisx0208 38 66))
+ (cons "'c" (make-char 'japanese-jisx0208 38 67))
+ (cons "'d" (make-char 'japanese-jisx0208 38 68))))
+ ;; Or a unicode font.
+ (and (fboundp 'decode-char)
+ (list (cons "fun" (decode-char 'ucs 955))
+ (cons "sqrt" (decode-char 'ucs 8730))
+ (cons "not" (decode-char 'ucs 172))
+ (cons "or" (decode-char 'ucs 8897))
+ (cons "&&" (decode-char 'ucs 8896))
+ (cons "||" (decode-char 'ucs 8897))
+ ;; (cons "*." (decode-char 'ucs 215))
+ ;; (cons "/." (decode-char 'ucs 247))
+ (cons "->" (decode-char 'ucs 8594))
+ (cons "<-" (decode-char 'ucs 8592))
+ (cons "<=" (decode-char 'ucs 8804))
+ (cons ">=" (decode-char 'ucs 8805))
+ (cons "<>" (decode-char 'ucs 8800))
+ (cons "==" (decode-char 'ucs 8801))
+ ;; Some greek letters for type parameters.
+ (cons "'a" (decode-char 'ucs 945))
+ (cons "'b" (decode-char 'ucs 946))
+ (cons "'c" (decode-char 'ucs 947))
+ (cons "'d" (decode-char 'ucs 948))
+ ))))
+
+(defun tuareg-font-lock-compose-symbol (alist)
+ "Compose a sequence of ascii chars into a symbol.
+Regexp match data 0 points to the chars."
+ ;; Check that the chars should really be composed into a symbol.
+ (let* ((start (match-beginning 0))
+ (end (match-end 0))
+ (syntaxes (if (eq (char-syntax (char-after start)) ?w)
+ '(?w) '(?. ?\\))))
+ (if (or (memq (char-syntax (or (char-before start) ?\ )) syntaxes)
+ (memq (char-syntax (or (char-after end) ?\ )) syntaxes)
+ (memq (get-text-property start 'face)
+ '(font-lock-doc-face font-lock-string-face
+ font-lock-comment-face)))
+ ;; No composition for you. Let's actually remove any composition
+ ;; we may have added earlier and which is now incorrect.
+ (remove-text-properties start end '(composition))
+ ;; That's a symbol alright, so add the composition.
+ (compose-region start end (cdr (assoc (match-string 0) alist)))))
+ ;; Return nil because we're not adding any face property.
+ nil)
+
+(defun tuareg-font-lock-symbols-keywords ()
+ (when (fboundp 'compose-region)
+ (let ((alist nil))
+ (dolist (x tuareg-font-lock-symbols-alist)
+ (when (and (if (fboundp 'char-displayable-p)
+ (char-displayable-p (cdr x))
+ t)
+ (not (assoc (car x) alist))) ;Not yet in alist.
+ (push x alist)))
+ (when alist
+ `((,(regexp-opt (mapcar 'car alist) t)
+ (0 (tuareg-font-lock-compose-symbol ',alist))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Font-Lock
+(unless tuareg-use-syntax-ppss
+
(defun tuareg-fontify-buffer ()
(font-lock-default-fontify-buffer)
(tuareg-fontify (point-min) (point-max)))
@@ -719,6 +839,8 @@
'font-lock-doc-face
'font-lock-doc-string-face))
+) ;; End of (unless tuareg-use-syntax-ppss
+
;; Patch by Stefan Monnier: redesigned font-lock installation
;; and use char classes
@@ -751,6 +873,7 @@
(copy-face font-lock-keyword-face 'font-lock-preprocessor-face))
(defvar tuareg-font-lock-keywords
+ (append
(list
(list
"\\<\\(external\\|open\\|include\\|rule\\|s\\(ig\\|truct\\)\\|module\\|functor\\|with[
\t\n]+\\(type\\|module\\)\\|val\\|type\\|method\\|virtual\\|constraint\\|class\\|in\\|inherit\\|initializer\\|let\\|rec\\|and\\|begin\\|object\\|end\\)\\>"
0 'tuareg-font-lock-governing-face nil nil)
@@ -784,6 +907,7 @@
1 'font-lock-variable-name-face 'keep nil)
(list "^#\\w+\\>"
0 'font-lock-preprocessor-face t nil))
+ (tuareg-font-lock-symbols-keywords))
"Font-Lock patterns for Tuareg mode.")
(when (featurep 'sym-lock)
@@ -873,8 +997,8 @@
(defvar tuareg-mode-syntax-table
(let ((st (make-syntax-table)))
(modify-syntax-entry ?_ "_" st)
- (modify-syntax-entry ?? "w" st)
- (modify-syntax-entry ?~ "w" st)
+ (modify-syntax-entry ?? ". p" st)
+ (modify-syntax-entry ?~ ". p" st)
(modify-syntax-entry ?: "." st)
(modify-syntax-entry ?' "w" st) ; ' is part of words (for primes).
(modify-syntax-entry
@@ -894,8 +1018,9 @@
"Syntax table in use in Tuareg mode buffers.")
(defconst tuareg-font-lock-syntax
- '((?_ . "w") (?` . ".") (?\" . ".") (?\( . ".") (?\) . ".") (?* . ".")
- (?~ . ".") (?? . "."))
+ `((?_ . "w") (?` . ".")
+ ,@(unless tuareg-use-syntax-ppss
+ '((?\" . ".") (?\( . ".") (?\) . ".") (?* . "."))))
"Syntax changes for Font-Lock.")
(defvar tuareg-mode-abbrev-table ()
@@ -1017,14 +1142,15 @@
(setq parse-sexp-ignore-comments nil)
(make-local-variable 'indent-line-function)
(setq indent-line-function 'tuareg-indent-command)
+ (unless tuareg-use-syntax-ppss
(make-local-hook 'before-change-functions)
- (add-hook 'before-change-functions 'tuareg-before-change-function nil t)
+ (add-hook 'before-change-functions 'tuareg-before-change-function nil t))
(make-local-variable 'normal-auto-fill-function)
(setq normal-auto-fill-function 'tuareg-auto-fill-function)
;; Hooks for tuareg-mode, use them for tuareg-mode configuration
- (run-hooks 'tuareg-mode-hook)
(tuareg-install-font-lock)
+ (run-hooks 'tuareg-mode-hook)
(if tuareg-use-abbrev-mode (abbrev-mode 1))
(message (concat "Major mode for Caml programs, "
tuareg-mode-version ".")))
@@ -1038,8 +1164,8 @@
(if (not sym-lock-keywords)
(sym-lock tuareg-sym-lock-keywords))))
(setq font-lock-defaults
- (list
- 'tuareg-font-lock-keywords t nil
+ (list*
+ 'tuareg-font-lock-keywords (not tuareg-use-syntax-ppss) nil
tuareg-font-lock-syntax nil
'(font-lock-syntactic-keywords
. tuareg-font-lock-syntactic-keywords)
@@ -1047,10 +1173,12 @@
. t)
'(font-lock-syntactic-face-function
. tuareg-font-lock-syntactic-face-function)
- '(font-lock-fontify-region-function
- . tuareg-fontify-region)))
+ (unless tuareg-use-syntax-ppss
+ '((font-lock-fontify-region-function
+ . tuareg-fontify-region)))))
+ (when (and (boundp 'font-lock-fontify-region-function)
+ (not tuareg-use-syntax-ppss))
(make-local-variable 'font-lock-fontify-region-function)
- (if (boundp 'font-lock-fontify-region-function)
(setq font-lock-fontify-region-function 'tuareg-fontify-region)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1879,16 +2007,14 @@
Compute new indentation based on Caml syntax."
(interactive "*")
- (let ((old-cfs case-fold-search))
(if (not from-leading-star)
(tuareg-auto-fill-insert-leading-star))
- (setq case-fold-search nil)
+ (let ((case-fold-search nil))
(tuareg-modify-syntax)
(save-excursion
(back-to-indentation)
(indent-line-to (tuareg-compute-indent)))
(if (tuareg-in-indentation-p) (back-to-indentation))
- (setq case-fold-search old-cfs)
(tuareg-restore-syntax)))
(defun tuareg-compute-indent ()
@@ -2284,8 +2410,7 @@
(defun tuareg-discover-phrase (&optional quiet)
(end-of-line)
- (let ((end (point)) (old-cfs case-fold-search))
- (setq case-fold-search nil)
+ (let ((end (point)) (case-fold-search nil))
(tuareg-modify-syntax)
(tuareg-find-phrase-beginning)
(if (> (point) end) (setq end (point)))
@@ -2324,7 +2449,6 @@
(if (>= cpt 8) (message "Looking for enclosing phrase... done."))
(save-excursion (tuareg-skip-blank-and-comments) (setq end (point)))
(tuareg-skip-back-blank-and-comments)
- (setq case-fold-search old-cfs)
(tuareg-restore-syntax)
(list begin (point) end)))))
@@ -2568,7 +2692,7 @@
(when (eq major-mode 'tuareg-interactive-mode)
(save-excursion
(when (>= comint-last-input-end comint-last-input-start)
- (if (and tuareg-with-xemacs tuareg-interactive-read-only-input)
+ (if tuareg-interactive-read-only-input
(add-text-properties
comint-last-input-start comint-last-input-end
(list 'read-only t)))
@@ -2721,7 +2845,7 @@
(goto-char (point-max))
(comint-send-input))
(insert "\n")
- (tuareg-indent-command)
+ (indent-according-to-mode)
(message tuareg-interactive-send-warning)))
(defun tuareg-eval-region (start end)
_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-devel
