Mercurial > urweb

annotate src/elisp/urweb-mode.el @ 1882:77cde56d41b6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Change Pthread thread creation logic to avoid Cygwin limitations with setting stack size
author Adam Chlipala <adam@chlipala.net>
date Mon, 14 Oct 2013 08:08:57 -0400
parents 9b54fbe1efdb
children 403f0cc65b9c
rev   line source
adamc@350 1 ;;; urweb-mode.el --- Major mode for editing (Standard) ML
adamc@350 2
adamc@350 3 ;; Based on sml-mode:
adamc@350 4 ;; Copyright (C) 1999,2000,2004 Stefan Monnier
adamc@350 5 ;; Copyright (C) 1994-1997 Matthew J. Morley
adamc@350 6 ;; Copyright (C) 1989 Lars Bo Nielsen
adamc@350 7 ;;
adamc@350 8 ;; Modified for urweb-mode:
adamc@350 9 ;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net>
adamc@350 10
adamc@350 11 ;; Author: Lars Bo Nielsen
adamc@350 12 ;; Olin Shivers
adamc@350 13 ;; Fritz Knabe (?)
adamc@350 14 ;; Steven Gilmore (?)
adamc@350 15 ;; Matthew Morley <mjm@scs.leeds.ac.uk> (aka <matthew@verisity.com>)
adamc@350 16 ;; Matthias Blume <blume@cs.princeton.edu> (aka <blume@kurims.kyoto-u.ac.jp>)
adamc@350 17 ;; (Stefan Monnier) monnier@cs.yale.edu
adamc@350 18 ;; Adam Chlipala
adamc@350 19
adamc@350 20 ;; This file is not part of GNU Emacs, but it is distributed under the
adamc@350 21 ;; same conditions.
adamc@350 22
adamc@350 23 ;; This program is free software; you can redistribute it and/or
adamc@350 24 ;; modify it under the terms of the GNU General Public License as
adamc@350 25 ;; published by the Free Software Foundation; either version 2, or (at
adamc@350 26 ;; your option) any later version.
adamc@350 27
adamc@350 28 ;; This program is distributed in the hope that it will be useful, but
adamc@350 29 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
adamc@350 30 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
adamc@350 31 ;; General Public License for more details.
adamc@350 32
adamc@350 33 ;; You should have received a copy of the GNU General Public License
adamc@350 34 ;; along with GNU Emacs; see the file COPYING. If not, write to the
adamc@350 35 ;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
adamc@350 36
adamc@350 37 ;;; Commentary:
adamc@350 38
adamc@350 39 ;;; HISTORY
adamc@350 40
adamc@350 41 ;; Still under construction: History obscure, needs a biographer as
adamc@350 42 ;; well as a M-x doctor. Change Log on request.
adamc@350 43
adamc@358 44 ;; Hacked by Olin Shivers for comint from Lars Bo Nielsen's sml.el.
adamc@350 45
adamc@350 46 ;; Hacked by Matthew Morley to incorporate Fritz Knabe's hilite and
adamc@350 47 ;; font-lock patterns, some of Steven Gilmore's (reduced) easy-menus,
adamc@350 48 ;; and numerous bugs and bug-fixes.
adamc@350 49
adamc@350 50 ;;; DESCRIPTION
adamc@350 51
adamc@350 52 ;; See accompanying info file: urweb-mode.info
adamc@350 53
adamc@350 54 ;;; FOR YOUR .EMACS FILE
adamc@350 55
adamc@350 56 ;; If urweb-mode.el lives in some non-standard directory, you must tell
adamc@350 57 ;; emacs where to get it. This may or may not be necessary:
adamc@350 58
adamc@350 59 ;; (add-to-list 'load-path "~jones/lib/emacs/")
adamc@350 60
adamc@350 61 ;; Then to access the commands autoload urweb-mode with that command:
adamc@350 62
adamc@350 63 ;; (load "urweb-mode-startup")
adamc@350 64
adamc@350 65 ;; urweb-mode-hook is run whenever a new urweb-mode buffer is created.
adamc@350 66
adamc@350 67 ;;; Code:
adamc@350 68
adamc@350 69 (eval-when-compile (require 'cl))
adam@1747 70 (require 'compile)
adamc@350 71 (require 'urweb-util)
adamc@350 72 (require 'urweb-move)
adamc@350 73 (require 'urweb-defs)
adamc@350 74 (condition-case nil (require 'skeleton) (error nil))
adamc@350 75
adamc@350 76 ;;; VARIABLES CONTROLLING INDENTATION
adamc@350 77
adamc@350 78 (defcustom urweb-indent-level 4
adamc@350 79 "*Indentation of blocks in Ur/Web (see also `urweb-structure-indent')."
adamc@350 80 :group 'urweb
adamc@350 81 :type '(integer))
adamc@350 82
adamc@350 83 (defcustom urweb-indent-args urweb-indent-level
adamc@350 84 "*Indentation of args placed on a separate line."
adamc@350 85 :group 'urweb
adamc@350 86 :type '(integer))
adamc@350 87
adamc@350 88 (defcustom urweb-electric-semi-mode nil
adamc@350 89 "*If non-nil, `\;' will self insert, reindent the line, and do a newline.
adamc@350 90 If nil, just insert a `\;'. (To insert while t, do: \\[quoted-insert] \;)."
adamc@350 91 :group 'urweb
adamc@350 92 :type 'boolean)
adamc@350 93
adamc@350 94 (defcustom urweb-rightalign-and t
adamc@350 95 "If non-nil, right-align `and' with its leader.
adamc@350 96 If nil: If t:
adamc@350 97 datatype a = A datatype a = A
adamc@350 98 and b = B and b = B"
adamc@350 99 :group 'urweb
adamc@350 100 :type 'boolean)
adamc@350 101
adamc@350 102 ;;; OTHER GENERIC MODE VARIABLES
adamc@350 103
adamc@350 104 (defvar urweb-mode-info "urweb-mode"
adamc@350 105 "*Where to find Info file for `urweb-mode'.
adamc@350 106 The default assumes the info file \"urweb-mode.info\" is on Emacs' info
adamc@350 107 directory path. If it is not, either put the file on the standard path
adamc@350 108 or set the variable `urweb-mode-info' to the exact location of this file
adamc@350 109
adamc@350 110 (setq urweb-mode-info \"/usr/me/lib/info/urweb-mode\")
adamc@350 111
adamc@350 112 in your .emacs file. You can always set it interactively with the
adamc@350 113 set-variable command.")
adamc@350 114
adamc@350 115 (defvar urweb-mode-hook nil
adamc@350 116 "*Run upon entering `urweb-mode'.
adamc@350 117 This is a good place to put your preferred key bindings.")
adamc@350 118
adamc@350 119 ;;; CODE FOR Ur/Web-MODE
adamc@350 120
adamc@350 121 (defun urweb-mode-info ()
adamc@350 122 "Command to access the TeXinfo documentation for `urweb-mode'.
adamc@350 123 See doc for the variable `urweb-mode-info'."
adamc@350 124 (interactive)
adamc@350 125 (require 'info)
adamc@350 126 (condition-case nil
adamc@350 127 (info urweb-mode-info)
adamc@350 128 (error (progn
adamc@350 129 (describe-variable 'urweb-mode-info)
adamc@350 130 (message "Can't find it... set this variable first!")))))
adamc@350 131
adamc@350 132
adamc@350 133 ;; font-lock setup
adamc@350 134
adamc@350 135 (defconst urweb-keywords-regexp
adamc@350 136 (urweb-syms-re "and" "case" "class" "con" "constraint" "constraints"
adamc@621 137 "datatype" "else" "end" "extern" "fn" "map"
adamc@350 138 "fun" "functor" "if" "include"
adamc@446 139 "of" "open" "let" "in"
adamc@1199 140 "rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy"
adamc@754 141 "struct" "structure" "table" "view" "then" "type" "val" "where"
adamc@350 142 "with"
adamc@350 143
adamc@350 144 "Name" "Type" "Unit")
adamc@350 145 "A regexp that matches any non-SQL keywords of Ur/Web.")
adamc@350 146
adamc@350 147 (defconst urweb-sql-keywords-regexp
adamc@993 148 (urweb-syms-re "SELECT" "DISTINCT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY"
adamc@350 149 "HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT"
adamc@350 150 "TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX"
adamc@708 151 "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE"
adamc@714 152 "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK"
adamc@749 153 "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL"
kkallio@1572 154 "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS" "SELECT1"
adam@1682 155 "IF" "THEN" "ELSE" "COALESCE" "LIKE" "RANDOM")
adamc@350 156 "A regexp that matches SQL keywords.")
adamc@350 157
adamc@351 158 (defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>"
adamc@351 159 "A regexp that matches lowercase Ur/Web identifiers.")
adamc@351 160
adamc@351 161 (defconst urweb-cident-regexp "\\<[A-Z][A-Za-z0-9_']*\\>"
adamc@351 162 "A regexp that matches uppercase Ur/Web identifiers.")
adamc@351 163
adamc@350 164 ;;; Font-lock settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
adamc@350 165
adamc@350 166 ;; The font lock regular expressions.
adamc@350 167
adamc@363 168 (defun urweb-in-xml ()
adamc@360 169 (save-excursion
adamc@360 170 (let (
adamc@360 171 (depth 0)
adamc@360 172 (finished nil)
adamc@360 173 (answer nil)
adamc@360 174 )
vshabanoff@1566 175 (while (and (not finished) (re-search-backward "[-<{}]" nil t))
adamc@360 176 (cond
adamc@360 177 ((looking-at "{")
adamc@360 178 (if (> depth 0)
adamc@363 179 (decf depth)
adamc@360 180 (setq finished t)))
adamc@360 181 ((looking-at "}")
adamc@363 182 (incf depth))
adam@1525 183 ((looking-at "<xml>")
adam@1525 184 (if (> depth 0)
adam@1525 185 (decf depth)
adam@1525 186 (progn
adam@1525 187 (setq answer t)
adam@1525 188 (setq finished t))))
adam@1525 189 ((looking-at "</xml>")
vshabanoff@1565 190 (incf depth))
vshabanoff@1565 191
vshabanoff@1566 192 ((looking-at "-")
vshabanoff@1566 193 (if (looking-at "->")
vshabanoff@1566 194 (setq finished (= depth 0))))
vshabanoff@1566 195
vshabanoff@1565 196 ((and (= depth 0)
vshabanoff@1565 197 (not (looking-at "<xml")) ;; ignore <xml/>
vshabanoff@1565 198 (eq font-lock-tag-face
vshabanoff@1565 199 (get-text-property (point) 'face)))
vshabanoff@1565 200 ;; previous code was highlighted as tag, seems we are in xml
vshabanoff@1565 201 (progn
vshabanoff@1565 202 (setq answer t)
vshabanoff@1565 203 (setq finished t)))
vshabanoff@1565 204
vshabanoff@1565 205 ((= depth 0)
vshabanoff@1565 206 ;; previous thing was a tag like, but not tag
vshabanoff@1565 207 ;; seems we are in usual code or comment
vshabanoff@1565 208 (setq finished t))
vshabanoff@1565 209 ))
adamc@360 210 answer)))
adamc@360 211
adamc@360 212 (defun amAttribute (face)
adamc@360 213 (if (ignore-errors (save-excursion (backward-word 2) (backward-char 1) (looking-at "<")))
adamc@360 214 nil
adamc@360 215 face))
adamc@358 216
adamc@350 217 (defconst urweb-font-lock-keywords
adamc@350 218 `(;;(urweb-font-comments-and-strings)
adamc@362 219 ("\\(<\\sw+\\)\\(\\s-\\|\\sw\\|=\\|\"[^\"]*\"\\|{[^}]*}\\)*\\(/?>\\)"
adamc@359 220 (1 font-lock-tag-face)
adamc@359 221 (3 font-lock-tag-face))
adamc@359 222 ("\\(</\\sw+>\\)"
adamc@359 223 (1 font-lock-tag-face))
adamc@359 224 ("\\([^<>{}]+\\)"
adamc@363 225 (1 (if (urweb-in-xml)
adamc@359 226 font-lock-string-face
adamc@359 227 nil)))
adamc@359 228
adamc@357 229 ("\\<\\(fun\\|and\\)\\s-+\\(\\sw+\\)\\s-+[^ \t\n=]"
adamc@350 230 (1 font-lock-keyword-face)
adamc@360 231 (2 (amAttribute font-lock-function-name-face)))
adamc@357 232 ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)"
adamc@350 233 (1 font-lock-keyword-face)
adamc@360 234 (3 (amAttribute font-lock-type-def-face)))
adamc@1199 235 ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\|policy\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
adamc@350 236 (1 font-lock-keyword-face)
adamc@360 237 (3 (amAttribute font-lock-variable-name-face)))
adamc@350 238 ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)"
adamc@350 239 (1 font-lock-keyword-face)
adamc@360 240 (2 (amAttribute font-lock-module-def-face)))
adamc@350 241 ("\\<\\(signature\\)\\s-+\\(\\sw+\\)"
adamc@350 242 (1 font-lock-keyword-face)
adamc@360 243 (2 (amAttribute font-lock-interface-def-face)))
adamc@350 244
adamc@350 245 (,urweb-keywords-regexp . font-lock-keyword-face)
adamc@351 246 (,urweb-sql-keywords-regexp . font-lock-sql-face)
adamc@351 247 (,urweb-cident-regexp . font-lock-cvariable-face))
adamc@350 248 "Regexps matching standard Ur/Web keywords.")
adamc@350 249
adamc@350 250 (defface font-lock-type-def-face
adamc@350 251 '((t (:bold t)))
adamc@350 252 "Font Lock mode face used to highlight type definitions."
adamc@350 253 :group 'font-lock-highlighting-faces)
adamc@350 254 (defvar font-lock-type-def-face 'font-lock-type-def-face
adamc@350 255 "Face name to use for type definitions.")
adamc@350 256
adamc@350 257 (defface font-lock-module-def-face
adamc@350 258 '((t (:bold t)))
adamc@350 259 "Font Lock mode face used to highlight module definitions."
adamc@350 260 :group 'font-lock-highlighting-faces)
adamc@350 261 (defvar font-lock-module-def-face 'font-lock-module-def-face
adamc@350 262 "Face name to use for module definitions.")
adamc@350 263
adamc@350 264 (defface font-lock-interface-def-face
adamc@350 265 '((t (:bold t)))
adamc@350 266 "Font Lock mode face used to highlight interface definitions."
adamc@350 267 :group 'font-lock-highlighting-faces)
adamc@350 268 (defvar font-lock-interface-def-face 'font-lock-interface-def-face
adamc@350 269 "Face name to use for interface definitions.")
adamc@350 270
adamc@350 271 (defface font-lock-sql-face
adamc@350 272 '((t (:bold t)))
adamc@350 273 "Font Lock mode face used to highlight SQL keywords."
adamc@350 274 :group 'font-lock-highlighting-faces)
adamc@350 275 (defvar font-lock-sql-face 'font-lock-sql-face
adamc@350 276 "Face name to use for SQL keywords.")
adamc@350 277
adamc@351 278 (defface font-lock-cvariable-face
adamc@351 279 '((t (:foreground "dark blue")))
adamc@351 280 "Font Lock mode face used to highlight capitalized identifiers."
adamc@351 281 :group 'font-lock-highlighting-faces)
adamc@351 282 (defvar font-lock-cvariable-face 'font-lock-cvariable-face
adamc@351 283 "Face name to use for capitalized identifiers.")
adamc@351 284
adamc@357 285 (defface font-lock-tag-face
adamc@357 286 '((t (:bold t)))
adamc@357 287 "Font Lock mode face used to highlight XML tags."
adamc@357 288 :group 'font-lock-highlighting-faces)
adamc@357 289 (defvar font-lock-tag-face 'font-lock-tag-face
adamc@357 290 "Face name to use for XML tags.")
adamc@357 291
adamc@358 292 (defface font-lock-attr-face
adamc@358 293 '((t (:bold t)))
adamc@358 294 "Font Lock mode face used to highlight XML attributes."
adamc@358 295 :group 'font-lock-highlighting-faces)
adamc@358 296 (defvar font-lock-attr-face 'font-lock-attr-face
adamc@358 297 "Face name to use for XML attributes.")
adamc@358 298
adamc@350 299 ;;
adamc@350 300 ;; Code to handle nested comments and unusual string escape sequences
adamc@350 301 ;;
adamc@350 302
adamc@350 303 (defsyntax urweb-syntax-prop-table
adamc@350 304 '((?\\ . ".") (?* . "."))
adamc@350 305 "Syntax table for text-properties")
adamc@350 306
adamc@350 307 ;; For Emacsen that have no built-in support for nested comments
adamc@350 308 (defun urweb-get-depth-st ()
adamc@350 309 (save-excursion
adamc@350 310 (let* ((disp (if (eq (char-before) ?\)) (progn (backward-char) -1) nil))
adamc@350 311 (_ (backward-char))
adamc@350 312 (disp (if (eq (char-before) ?\() (progn (backward-char) 0) disp))
adamc@350 313 (pt (point)))
adamc@350 314 (when disp
adamc@350 315 (let* ((depth
adamc@350 316 (save-match-data
adamc@350 317 (if (re-search-backward "\\*)\\|(\\*" nil t)
adamc@350 318 (+ (or (get-char-property (point) 'comment-depth) 0)
adamc@350 319 (case (char-after) (?\( 1) (?* 0))
adamc@350 320 disp)
adamc@350 321 0)))
adamc@350 322 (depth (if (> depth 0) depth)))
adamc@350 323 (put-text-property pt (1+ pt) 'comment-depth depth)
adamc@350 324 (when depth urweb-syntax-prop-table))))))
adamc@350 325
adamc@350 326 (defconst urweb-font-lock-syntactic-keywords
adamc@350 327 `(("^\\s-*\\(\\\\\\)" (1 ',urweb-syntax-prop-table))
adamc@350 328 ,@(unless urweb-builtin-nested-comments-flag
adamc@350 329 '(("(?\\(\\*\\))?" (1 (urweb-get-depth-st)))))))
adamc@350 330
adamc@350 331 (defconst urweb-font-lock-defaults
adamc@350 332 '(urweb-font-lock-keywords nil nil ((?_ . "w") (?' . "w")) nil
adamc@350 333 (font-lock-syntactic-keywords . urweb-font-lock-syntactic-keywords)))
adamc@350 334
adamc@350 335 ;;;;
adamc@350 336 ;;;; Imenu support
adamc@350 337 ;;;;
adamc@350 338
adamc@350 339 (defvar urweb-imenu-regexp
adamc@350 340 (concat "^[ \t]*\\(let[ \t]+\\)?"
adamc@350 341 (regexp-opt (append urweb-module-head-syms
adamc@350 342 '("and" "fun" "datatype" "type")) t)
adamc@350 343 "\\>"))
adamc@350 344
adamc@350 345 (defun urweb-imenu-create-index ()
adamc@350 346 (let (alist)
adamc@350 347 (goto-char (point-max))
adamc@350 348 (while (re-search-backward urweb-imenu-regexp nil t)
adamc@350 349 (save-excursion
adamc@350 350 (let ((kind (match-string 2))
adamc@350 351 (column (progn (goto-char (match-beginning 2)) (current-column)))
adamc@350 352 (location
adamc@350 353 (progn (goto-char (match-end 0))
adamc@350 354 (urweb-forward-spaces)
adamc@350 355 (when (looking-at urweb-tyvarseq-re)
adamc@350 356 (goto-char (match-end 0)))
adamc@350 357 (point)))
adamc@350 358 (name (urweb-forward-sym)))
adamc@350 359 ;; Eliminate trivial renamings.
adamc@350 360 (when (or (not (member kind '("structure" "signature")))
adamc@350 361 (progn (search-forward "=")
adamc@350 362 (urweb-forward-spaces)
adamc@350 363 (looking-at "sig\\|struct")))
adamc@350 364 (push (cons (concat (make-string (/ column 2) ?\ ) name) location)
adamc@350 365 alist)))))
adamc@350 366 alist))
adamc@350 367
adamc@350 368 ;;; MORE CODE FOR URWEB-MODE
adamc@350 369
adamc@350 370 ;;;###autoload (add-to-list 'load-path (file-name-directory load-file-name))
adamc@350 371 ;;;###autoload
adamc@362 372 (add-to-list 'auto-mode-alist '("\\.urs?\\'" . urweb-mode))
adamc@350 373
adamc@350 374 ;;;###autoload
adamc@350 375 (define-derived-mode urweb-mode fundamental-mode "Ur/Web"
adamc@350 376 "\\<urweb-mode-map>Major mode for editing Ur/Web code.
adamc@350 377 This mode runs `urweb-mode-hook' just before exiting.
adamc@350 378 \\{urweb-mode-map}"
adamc@350 379 (set (make-local-variable 'font-lock-defaults) urweb-font-lock-defaults)
adamc@358 380 (set (make-local-variable 'font-lock-multiline) 'undecided)
adamc@350 381 (set (make-local-variable 'outline-regexp) urweb-outline-regexp)
adamc@350 382 (set (make-local-variable 'imenu-create-index-function)
adamc@350 383 'urweb-imenu-create-index)
adamc@350 384 (set (make-local-variable 'add-log-current-defun-function)
adamc@350 385 'urweb-current-fun-name)
adamc@350 386 ;; Treat paragraph-separators in comments as paragraph-separators.
adamc@350 387 (set (make-local-variable 'paragraph-separate)
adamc@350 388 (concat "\\([ \t]*\\*)?\\)?\\(" paragraph-separate "\\)"))
adamc@350 389 (set (make-local-variable 'require-final-newline) t)
adamc@350 390 ;; forward-sexp-function is an experimental variable in my hacked Emacs.
adamc@350 391 (set (make-local-variable 'forward-sexp-function) 'urweb-user-forward-sexp)
adamc@350 392 ;; For XEmacs
adamc@350 393 (easy-menu-add urweb-mode-menu)
adamc@358 394
adamc@350 395 ;; Compatibility. FIXME: we should use `-' in Emacs-CVS.
adamc@350 396 (unless (boundp 'skeleton-positions) (set (make-local-variable '@) nil))
adamc@358 397
adam@1747 398 (local-set-key (kbd "C-c C-c") 'compile)
adam@1747 399
adamc@360 400 (urweb-mode-variables))
adamc@350 401
adamc@350 402 (defun urweb-mode-variables ()
adamc@350 403 (set-syntax-table urweb-mode-syntax-table)
adamc@350 404 (setq local-abbrev-table urweb-mode-abbrev-table)
adamc@350 405 ;; A paragraph is separated by blank lines or ^L only.
adamc@350 406
adamc@350 407 (set (make-local-variable 'indent-line-function) 'urweb-indent-line)
adamc@350 408 (set (make-local-variable 'comment-start) "(* ")
adamc@350 409 (set (make-local-variable 'comment-end) " *)")
adamc@350 410 (set (make-local-variable 'comment-nested) t)
adamc@350 411 ;;(set (make-local-variable 'block-comment-start) "* ")
adamc@350 412 ;;(set (make-local-variable 'block-comment-end) "")
adamc@350 413 ;; (set (make-local-variable 'comment-column) 40)
adamc@350 414 (set (make-local-variable 'comment-start-skip) "(\\*+\\s-*"))
adamc@350 415
adamc@350 416 (defun urweb-funname-of-and ()
adamc@350 417 "Name of the function this `and' defines, or nil if not a function.
adamc@350 418 Point has to be right after the `and' symbol and is not preserved."
adamc@350 419 (urweb-forward-spaces)
adamc@350 420 (if (looking-at urweb-tyvarseq-re) (goto-char (match-end 0)))
adamc@350 421 (let ((sym (urweb-forward-sym)))
adamc@350 422 (urweb-forward-spaces)
adamc@350 423 (unless (or (member sym '(nil "d="))
adamc@350 424 (member (urweb-forward-sym) '("d=")))
adamc@350 425 sym)))
adamc@350 426
adamc@350 427 ;;; INDENTATION !!!
adamc@350 428
adamc@350 429 (defun urweb-mark-function ()
adamc@350 430 "Synonym for `mark-paragraph' -- sorry.
adamc@350 431 If anyone has a good algorithm for this..."
adamc@350 432 (interactive)
adamc@350 433 (mark-paragraph))
adamc@350 434
adamc@350 435 (defun urweb-indent-line ()
adamc@350 436 "Indent current line of Ur/Web code."
adamc@350 437 (interactive)
adamc@350 438 (let ((savep (> (current-column) (current-indentation)))
adamc@350 439 (indent (max (or (ignore-errors (urweb-calculate-indentation)) 0) 0)))
adamc@350 440 (if savep
adamc@350 441 (save-excursion (indent-line-to indent))
adamc@350 442 (indent-line-to indent))))
adamc@350 443
adamc@350 444 (defun urweb-back-to-outer-indent ()
adamc@350 445 "Unindents to the next outer level of indentation."
adamc@350 446 (interactive)
adamc@350 447 (save-excursion
adamc@350 448 (beginning-of-line)
adamc@350 449 (skip-chars-forward "\t ")
adamc@350 450 (let ((start-column (current-column))
adamc@350 451 (indent (current-column)))
adamc@350 452 (if (> start-column 0)
adamc@350 453 (progn
adamc@350 454 (save-excursion
adamc@350 455 (while (>= indent start-column)
adamc@350 456 (if (re-search-backward "^[^\n]" nil t)
adamc@350 457 (setq indent (current-indentation))
adamc@350 458 (setq indent 0))))
adamc@350 459 (backward-delete-char-untabify (- start-column indent)))))))
adamc@350 460
adamc@350 461 (defun urweb-find-comment-indent ()
adamc@350 462 (save-excursion
adamc@350 463 (let ((depth 1))
adamc@350 464 (while (> depth 0)
adamc@350 465 (if (re-search-backward "(\\*\\|\\*)" nil t)
adamc@350 466 (cond
adamc@350 467 ;; FIXME: That's just a stop-gap.
adamc@350 468 ((eq (get-text-property (point) 'face) 'font-lock-string-face))
adamc@350 469 ((looking-at "*)") (incf depth))
adamc@350 470 ((looking-at comment-start-skip) (decf depth)))
adamc@350 471 (setq depth -1)))
adamc@350 472 (if (= depth 0)
adamc@350 473 (1+ (current-column))
adamc@350 474 nil))))
adamc@350 475
adamc@369 476 (defun urweb-empty-line ()
adamc@365 477 (save-excursion
adamc@369 478 (beginning-of-line)
adamc@365 479 (let ((start-pos (point)))
adamc@369 480 (end-of-line)
adamc@369 481 (not (re-search-backward "[^\n \t]" start-pos t)))))
adamc@365 482
adamc@369 483 (defun urweb-seek-back ()
adamc@369 484 (while (urweb-empty-line) (previous-line 1)))
adamc@363 485
adamc@369 486 (defun urweb-skip-matching-braces ()
adamc@367 487 "Skip backwards past matching brace pairs, to calculate XML indentation after quoted Ur code"
adamc@367 488 (beginning-of-line)
adamc@367 489 (let ((start-pos (point))
adamc@367 490 (depth 0))
adamc@367 491 (end-of-line)
adamc@367 492 (while (re-search-backward "[{}]" start-pos t)
adamc@367 493 (cond
adamc@367 494 ((looking-at "}")
adamc@367 495 (incf depth))
adamc@367 496 ((looking-at "{")
adamc@367 497 (decf depth))))
adamc@367 498 (while (and (> depth 0) (re-search-backward "[{}]" nil t)
adamc@367 499 (cond
adamc@367 500 ((looking-at "}")
adamc@367 501 (incf depth))
adamc@367 502 ((looking-at "{")
adamc@367 503 (decf depth)))))))
adamc@367 504
adamc@369 505 (defun urweb-new-tags ()
adamc@369 506 "Decide if the previous line of XML introduced unclosed tags"
adamc@369 507 (save-excursion
adamc@369 508 (let ((start-pos (point))
adamc@369 509 (depth 0)
adamc@369 510 (done nil))
adamc@369 511 (previous-line 1)
adamc@369 512 (urweb-seek-back)
adamc@369 513 (urweb-skip-matching-braces)
adamc@369 514 (urweb-seek-back)
adamc@369 515 (beginning-of-line)
adamc@369 516 (while (and (not done) (search-forward "<" start-pos t))
adamc@396 517 (cond
adamc@396 518 ((or (looking-at " ") (looking-at "="))
adamc@396 519 nil)
adamc@396 520 ((looking-at "/")
adamc@396 521 (if (re-search-forward "[^\\sw]>" start-pos t)
adamc@369 522 (when (> depth 0) (decf depth))
adamc@396 523 (setq done t)))
adamc@396 524 (t
adamc@396 525 (if (re-search-forward "[^\\sw]>" start-pos t)
adamc@369 526 (if (not (save-excursion (backward-char 2) (looking-at "/")))
adamc@369 527 (incf depth))
adamc@396 528 (setq done t)))))
adamc@369 529 (and (not done) (> depth 0)))))
adamc@369 530
adamc@363 531 (defun urweb-tag-matching-indent ()
adamc@363 532 "Seek back to a matching opener tag and get its line's indent"
adamc@363 533 (save-excursion
adamc@369 534 (end-of-line)
adamc@369 535 (search-backward "</" nil t)
adamc@368 536 (urweb-tag-matcher)
adamc@369 537 (beginning-of-line)
adamc@369 538 (current-indentation)))
adamc@363 539
adamc@373 540 (defconst urweb-sql-main-starters
adamc@1071 541 '("SQL" "SELECT" "INSERT" "UPDATE" "DELETE" "FROM" "SELECT1" "WHERE"))
adamc@373 542
adamc@372 543 (defconst urweb-sql-starters
adamc@373 544 (append urweb-sql-main-starters
adamc@373 545 '("^\\s-+FROM" "WHERE" "GROUP" "ORDER" "HAVING" "LIMIT" "OFFSET"
adamc@373 546 "VALUES" "SET")))
adamc@372 547
adamc@373 548 (defconst urweb-sql-main-starters-re
adamc@373 549 (urweb-syms-re urweb-sql-main-starters))
adamc@372 550 (defconst urweb-sql-starters-re
adamc@372 551 (urweb-syms-re urweb-sql-starters))
adamc@372 552
adamc@374 553 (defconst urweb-sql-main-starters-paren-re
adamc@374 554 (concat "(" urweb-sql-main-starters-re))
adamc@374 555
adamc@374 556 (defun urweb-in-sql ()
adamc@374 557 "Check if the point is in a block of SQL syntax."
adamc@374 558 (save-excursion
adamc@375 559 (let ((start-pos (point))
adamc@375 560 (depth 0)
adamc@375 561 done
adamc@375 562 (good t))
adamc@375 563 (when (re-search-backward urweb-sql-main-starters-paren-re nil t)
adamc@375 564 (forward-char)
adamc@375 565 (while (and (not done) (re-search-forward "[()]" start-pos t))
adamc@375 566 (save-excursion
adamc@375 567 (backward-char)
adamc@375 568 (cond
adamc@375 569 ((looking-at ")")
adamc@375 570 (cond
adamc@375 571 ((= depth 0) (setq done t) (setq good nil))
adamc@375 572 (t (decf depth))))
adamc@375 573 ((looking-at "(")
adamc@375 574 (incf depth)))))
adamc@375 575 good))))
adamc@374 576
adamc@374 577 (defun urweb-sql-depth ()
adamc@374 578 "Check if the point is in a block of SQL syntax.
adamc@374 579 Returns the paren nesting depth if so, and nil otherwise."
adamc@374 580 (save-excursion
adamc@374 581 (let ((depth 0)
adamc@374 582 done)
adamc@374 583 (while (and (not done)
adamc@374 584 (re-search-backward "[()]" nil t))
adamc@374 585 (cond
adamc@374 586 ((looking-at ")")
adamc@374 587 (decf depth))
adamc@374 588 ((looking-at "(")
adamc@374 589 (if (looking-at urweb-sql-main-starters-paren-re)
adamc@374 590 (setq done t)
adamc@374 591 (incf depth)))))
adamc@374 592 (max 0 depth))))
adamc@374 593
adamc@350 594 (defun urweb-calculate-indentation ()
adamc@350 595 (save-excursion
adamc@350 596 (beginning-of-line) (skip-chars-forward "\t ")
adamc@350 597 (urweb-with-ist
adamc@350 598 ;; Indentation for comments alone on a line, matches the
adamc@350 599 ;; proper indentation of the next line.
adamc@350 600 (when (looking-at "(\\*") (urweb-forward-spaces))
adamc@350 601 (let (data
adamc@350 602 (sym (save-excursion (urweb-forward-sym))))
adamc@350 603 (or
adamc@350 604 ;; Allow the user to override the indentation.
adamc@350 605 (when (looking-at (concat ".*" (regexp-quote comment-start)
adamc@350 606 "[ \t]*fixindent[ \t]*"
adamc@350 607 (regexp-quote comment-end)))
adamc@350 608 (current-indentation))
adamc@350 609
adamc@350 610 ;; Continued comment.
adamc@350 611 (and (looking-at "\\*") (urweb-find-comment-indent))
adamc@350 612
adamc@363 613 (and (urweb-in-xml)
adamc@363 614 (let ((prev-indent (save-excursion
adamc@363 615 (previous-line 1)
adamc@369 616 (urweb-seek-back)
adamc@369 617 (urweb-skip-matching-braces)
adamc@369 618 (urweb-seek-back)
adamc@363 619 (current-indentation))))
adamc@363 620 (cond
adamc@363 621 ((looking-at "</")
adamc@363 622 (urweb-tag-matching-indent))
adamc@363 623 ((urweb-new-tags)
adamc@363 624 (+ prev-indent 2))
adamc@363 625 (t
adamc@363 626 prev-indent))))
adamc@363 627
adamc@350 628 ;; Continued string ? (Added 890113 lbn)
adamc@350 629 (and (looking-at "\\\\")
adamc@350 630 (save-excursion
adamc@350 631 (if (save-excursion (previous-line 1)
adamc@350 632 (beginning-of-line)
adamc@350 633 (looking-at "[\t ]*\\\\"))
adamc@350 634 (progn (previous-line 1) (current-indentation))
adamc@350 635 (if (re-search-backward "[^\\\\]\"" nil t)
adamc@350 636 (1+ (current-column))
adamc@350 637 0))))
adamc@350 638
adamc@350 639 ;; Closing parens. Could be handled below with `urweb-indent-relative'?
adamc@350 640 (and (looking-at "\\s)")
adamc@350 641 (save-excursion
adamc@350 642 (skip-syntax-forward ")")
adamc@350 643 (backward-sexp 1)
adamc@350 644 (if (urweb-dangling-sym)
adamc@350 645 (urweb-indent-default 'noindent)
adamc@350 646 (current-column))))
adamc@350 647
adamc@374 648 (and (or (looking-at "FROM") (looking-at urweb-sql-starters-re))
adamc@386 649
adamc@372 650 (save-excursion
adamc@372 651 (and (re-search-backward urweb-sql-starters-re nil t)
adamc@373 652 (if (looking-at urweb-sql-main-starters-re)
adamc@373 653 (current-column)
adamc@373 654 (current-indentation)))))
adamc@372 655
adamc@374 656 (and (urweb-in-sql)
adamc@374 657 (setq data (urweb-sql-depth))
adamc@374 658 (save-excursion
adamc@374 659 (re-search-backward urweb-sql-starters-re nil t)
adamc@374 660 (+ (current-column) 2 (* 2 data))))
adamc@374 661
adamc@350 662 (and (setq data (assoc sym urweb-close-paren))
adamc@350 663 (urweb-indent-relative sym data))
adamc@350 664
adamc@350 665 (and (member sym urweb-starters-syms)
adamc@350 666 (urweb-indent-starter sym))
adamc@350 667
adamc@350 668 (and (string= sym "|") (urweb-indent-pipe))
adamc@350 669
adamc@350 670 (urweb-indent-arg)
adamc@350 671 (urweb-indent-default))))))
adamc@350 672
adamc@350 673 (defsubst urweb-bolp ()
adamc@350 674 (save-excursion (skip-chars-backward " \t|") (bolp)))
adamc@350 675
adamc@350 676 (defun urweb-indent-starter (orig-sym)
adamc@350 677 "Return the indentation to use for a symbol in `urweb-starters-syms'.
adamc@350 678 Point should be just before the symbol ORIG-SYM and is not preserved."
adamc@350 679 (let ((sym (unless (save-excursion (urweb-backward-arg))
adamc@350 680 (urweb-backward-spaces)
adamc@350 681 (urweb-backward-sym))))
adamc@350 682 (if (member sym '(";" "d=")) (setq sym nil))
adamc@350 683 (if sym (urweb-get-sym-indent sym)
adamc@350 684 ;; FIXME: this can take a *long* time !!
adamc@350 685 (setq sym (urweb-find-matching-starter urweb-starters-syms))
adamc@350 686 ;; Don't align with `and' because it might be specially indented.
adamc@350 687 (if (and (or (equal orig-sym "and") (not (equal sym "and")))
adamc@350 688 (urweb-bolp))
adamc@350 689 (+ (current-column)
adamc@350 690 (if (and urweb-rightalign-and (equal orig-sym "and"))
adamc@350 691 (- (length sym) 3) 0))
adamc@350 692 (urweb-indent-starter orig-sym)))))
adamc@350 693
adamc@350 694 (defun urweb-indent-relative (sym data)
adamc@350 695 (save-excursion
adamc@350 696 (urweb-forward-sym) (urweb-backward-sexp nil)
adamc@350 697 (unless (second data) (urweb-backward-spaces) (urweb-backward-sym))
adamc@350 698 (+ (or (cdr (assoc sym urweb-symbol-indent)) 0)
adamc@350 699 (urweb-delegated-indent))))
adamc@350 700
adamc@350 701 (defun urweb-indent-pipe ()
adamc@350 702 (let ((sym (urweb-find-matching-starter urweb-pipeheads
adamc@350 703 (urweb-op-prec "|" 'back))))
adamc@350 704 (when sym
adamc@350 705 (if (string= sym "|")
adamc@350 706 (if (urweb-bolp) (current-column) (urweb-indent-pipe))
adamc@350 707 (let ((pipe-indent (or (cdr (assoc "|" urweb-symbol-indent)) -2)))
adamc@350 708 (when (or (member sym '("datatype"))
adamc@350 709 (and (equal sym "and")
adamc@350 710 (save-excursion
adamc@350 711 (forward-word 1)
adamc@350 712 (not (urweb-funname-of-and)))))
adamc@350 713 (re-search-forward "="))
adamc@350 714 (urweb-forward-sym)
adamc@350 715 (urweb-forward-spaces)
adamc@350 716 (+ pipe-indent (current-column)))))))
adamc@350 717
adamc@350 718 (defun urweb-find-forward (re)
adamc@350 719 (urweb-forward-spaces)
adamc@350 720 (while (and (not (looking-at re))
adamc@350 721 (progn
adamc@350 722 (or (ignore-errors (forward-sexp 1) t) (forward-char 1))
adamc@350 723 (urweb-forward-spaces)
adamc@350 724 (not (looking-at re))))))
adamc@350 725
adamc@350 726 (defun urweb-indent-arg ()
adamc@350 727 (and (save-excursion (ignore-errors (urweb-forward-arg)))
adamc@350 728 ;;(not (looking-at urweb-not-arg-re))
adamc@350 729 ;; looks like a function or an argument
adamc@350 730 (urweb-move-if (urweb-backward-arg))
adamc@350 731 ;; an argument
adamc@350 732 (if (save-excursion (not (urweb-backward-arg)))
adamc@350 733 ;; a first argument
adamc@350 734 (+ (current-column) urweb-indent-args)
adamc@350 735 ;; not a first arg
adamc@350 736 (while (and (/= (current-column) (current-indentation))
adamc@350 737 (urweb-move-if (urweb-backward-arg))))
adamc@350 738 (unless (save-excursion (urweb-backward-arg))
adamc@350 739 ;; all earlier args are on the same line
adamc@350 740 (urweb-forward-arg) (urweb-forward-spaces))
adamc@350 741 (current-column))))
adamc@350 742
adamc@350 743 (defun urweb-get-indent (data sym)
adamc@350 744 (let (d)
adamc@350 745 (cond
adamc@350 746 ((not (listp data)) data)
adamc@350 747 ((setq d (member sym data)) (cadr d))
adamc@350 748 ((and (consp data) (not (stringp (car data)))) (car data))
adamc@350 749 (t urweb-indent-level))))
adamc@350 750
adamc@350 751 (defun urweb-dangling-sym ()
adamc@350 752 "Non-nil if the symbol after point is dangling.
adamc@350 753 The symbol can be an Ur/Web symbol or an open-paren. \"Dangling\" means that
adamc@350 754 it is not on its own line but is the last element on that line."
adamc@350 755 (save-excursion
adamc@350 756 (and (not (urweb-bolp))
adamc@350 757 (< (urweb-point-after (end-of-line))
adamc@350 758 (urweb-point-after (or (urweb-forward-sym) (skip-syntax-forward "("))
adamc@350 759 (urweb-forward-spaces))))))
adamc@350 760
adamc@350 761 (defun urweb-delegated-indent ()
adamc@350 762 (if (urweb-dangling-sym)
adamc@350 763 (urweb-indent-default 'noindent)
adamc@350 764 (urweb-move-if (backward-word 1)
adamc@350 765 (looking-at urweb-agglomerate-re))
adamc@350 766 (current-column)))
adamc@350 767
adamc@350 768 (defun urweb-get-sym-indent (sym &optional style)
adamc@350 769 "Find the indentation for the SYM we're `looking-at'.
adamc@350 770 If indentation is delegated, point will move to the start of the parent.
adamc@350 771 Optional argument STYLE is currently ignored."
adamc@371 772 ;;(assert (equal sym (save-excursion (urweb-forward-sym))))
adamc@350 773 (save-excursion
adamc@350 774 (let ((delegate (and (not (equal sym "end")) (assoc sym urweb-close-paren)))
adamc@350 775 (head-sym sym))
adamc@350 776 (when (and delegate (not (eval (third delegate))))
adamc@350 777 ;;(urweb-find-match-backward sym delegate)
adamc@350 778 (urweb-forward-sym) (urweb-backward-sexp nil)
adamc@350 779 (setq head-sym
adamc@350 780 (if (second delegate)
adamc@350 781 (save-excursion (urweb-forward-sym))
adamc@350 782 (urweb-backward-spaces) (urweb-backward-sym))))
adamc@350 783 (let ((idata (assoc head-sym urweb-indent-rule)))
adamc@350 784 (when idata
adamc@350 785 ;;(if (or style (not delegate))
adamc@350 786 ;; normal indentation
adamc@350 787 (let ((indent (urweb-get-indent (cdr idata) sym)))
adamc@350 788 (when indent (+ (urweb-delegated-indent) indent)))
adamc@350 789 ;; delgate indentation to the parent
adamc@350 790 ;;(urweb-forward-sym) (urweb-backward-sexp nil)
adamc@350 791 ;;(let* ((parent-sym (save-excursion (urweb-forward-sym)))
adamc@350 792 ;; (parent-indent (cdr (assoc parent-sym urweb-indent-starters))))
adamc@350 793 ;; check the special rules
adamc@350 794 ;;(+ (urweb-delegated-indent)
adamc@350 795 ;; (or (urweb-get-indent (cdr indent-data) 1 'strict)
adamc@350 796 ;; (urweb-get-indent (cdr parent-indent) 1 'strict)
adamc@350 797 ;; (urweb-get-indent (cdr indent-data) 0)
adamc@350 798 ;; (urweb-get-indent (cdr parent-indent) 0))))))))
adamc@350 799 )))))
adamc@350 800
adamc@350 801 (defun urweb-indent-default (&optional noindent)
adamc@386 802 (condition-case nil
adamc@386 803 (progn
adamc@386 804 (let* ((sym-after (save-excursion (urweb-forward-sym)))
adamc@386 805 (_ (urweb-backward-spaces))
adamc@386 806 (sym-before (urweb-backward-sym))
adamc@386 807 (sym-indent (and sym-before (urweb-get-sym-indent sym-before)))
adamc@386 808 (indent-after (or (cdr (assoc sym-after urweb-symbol-indent)) 0)))
adamc@386 809 (when (equal sym-before "end")
adamc@386 810 ;; I don't understand what's really happening here, but when
adamc@386 811 ;; it's `end' clearly, we need to do something special.
adamc@386 812 (forward-word 1)
adamc@386 813 (setq sym-before nil sym-indent nil))
adamc@386 814 (cond
adamc@386 815 (sym-indent
adamc@386 816 ;; the previous sym is an indentation introducer: follow the rule
adamc@386 817 (if noindent
adamc@386 818 ;;(current-column)
adamc@386 819 sym-indent
adamc@386 820 (+ sym-indent indent-after)))
adamc@386 821 ;; If we're just after a hanging open paren.
adamc@386 822 ((and (eq (char-syntax (preceding-char)) ?\()
adamc@386 823 (save-excursion (backward-char) (urweb-dangling-sym)))
adamc@386 824 (backward-char)
adamc@386 825 (urweb-indent-default))
adamc@386 826 (t
adamc@386 827 ;; default-default
adamc@386 828 (let* ((prec-after (urweb-op-prec sym-after 'back))
adamc@386 829 (prec (or (urweb-op-prec sym-before 'back) prec-after 100)))
adamc@386 830 ;; go back until you hit a symbol that has a lower prec than the
adamc@386 831 ;; "current one", or until you backed over a sym that has the same prec
adamc@386 832 ;; but is at the beginning of a line.
adamc@386 833 (while (and (not (urweb-bolp))
adamc@386 834 (while (urweb-move-if (urweb-backward-sexp (1- prec))))
adamc@386 835 (not (urweb-bolp)))
adamc@386 836 (while (urweb-move-if (urweb-backward-sexp prec))))
adamc@386 837 (if noindent
adamc@386 838 ;; the `noindent' case does back over an introductory symbol
adamc@386 839 ;; such as `fun', ...
adamc@386 840 (progn
adamc@386 841 (urweb-move-if
adamc@386 842 (urweb-backward-spaces)
adamc@386 843 (member (urweb-backward-sym) urweb-starters-syms))
adamc@386 844 (current-column))
adamc@386 845 ;; Use `indent-after' for cases such as when , or ; should be
adamc@386 846 ;; outdented so that their following terms are aligned.
adamc@386 847 (+ (if (progn
adamc@386 848 (if (equal sym-after ";")
adamc@386 849 (urweb-move-if
adamc@386 850 (urweb-backward-spaces)
adamc@386 851 (member (urweb-backward-sym) urweb-starters-syms)))
adamc@386 852 (and sym-after (not (looking-at sym-after))))
adamc@386 853 indent-after 0)
adamc@386 854 (current-column))))))))
adamc@386 855 (error 0)))
adamc@350 856
adamc@350 857
adamc@350 858 ;; maybe `|' should be set to word-syntax in our temp syntax table ?
adamc@350 859 (defun urweb-current-indentation ()
adamc@350 860 (save-excursion
adamc@350 861 (beginning-of-line)
adamc@350 862 (skip-chars-forward " \t|")
adamc@350 863 (current-column)))
adamc@350 864
adamc@350 865
adamc@350 866 (defun urweb-find-matching-starter (syms &optional prec)
adamc@350 867 (let (sym)
adamc@350 868 (ignore-errors
adamc@350 869 (while
adamc@350 870 (progn (urweb-backward-sexp prec)
adamc@350 871 (setq sym (save-excursion (urweb-forward-sym)))
adamc@350 872 (not (or (member sym syms) (bobp)))))
adamc@350 873 (if (member sym syms) sym))))
adamc@350 874
adamc@350 875 (defun urweb-skip-siblings ()
adamc@350 876 (while (and (not (bobp)) (urweb-backward-arg))
adamc@350 877 (urweb-find-matching-starter urweb-starters-syms)))
adamc@350 878
adamc@350 879 (defun urweb-beginning-of-defun ()
adamc@350 880 (let ((sym (urweb-find-matching-starter urweb-starters-syms)))
adamc@350 881 (if (member sym '("fun" "and" "functor" "signature" "structure"
adamc@350 882 "datatype"))
adamc@350 883 (save-excursion (urweb-forward-sym) (urweb-forward-spaces)
adamc@350 884 (urweb-forward-sym))
adamc@350 885 ;; We're inside a "non function declaration": let's skip all other
adamc@350 886 ;; declarations that we find at the same level and try again.
adamc@350 887 (urweb-skip-siblings)
adamc@350 888 ;; Obviously, let's not try again if we're at bobp.
adamc@350 889 (unless (bobp) (urweb-beginning-of-defun)))))
adamc@350 890
adamc@350 891 (defcustom urweb-max-name-components 3
adamc@350 892 "Maximum number of components to use for the current function name."
adamc@350 893 :group 'urweb
adamc@350 894 :type 'integer)
adamc@350 895
adamc@350 896 (defun urweb-current-fun-name ()
adamc@350 897 (save-excursion
adamc@350 898 (let ((count urweb-max-name-components)
adamc@350 899 fullname name)
adamc@350 900 (end-of-line)
adamc@350 901 (while (and (> count 0)
adamc@350 902 (setq name (urweb-beginning-of-defun)))
adamc@350 903 (decf count)
adamc@350 904 (setq fullname (if fullname (concat name "." fullname) name))
adamc@350 905 ;; Skip all other declarations that we find at the same level.
adamc@350 906 (urweb-skip-siblings))
adamc@350 907 fullname)))
adamc@350 908
adamc@350 909 (provide 'urweb-mode)
adamc@350 910
adamc@350 911 ;;; urweb-mode.el ends here