cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/semantic-lex.el

   1 ;;; semantic-lex.el --- Lexical Analyzer builder
   2
   3 ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Eric M. Ludlam
   4
   5 ;; X-CVS: $Id: semantic-lex.el,v 1.1 2007-11-26 15:10:40 michaels Exp $
   6
   7 ;; This file is not part of GNU Emacs.
   8
   9 ;; Semantic is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; This software is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  22 ;; Boston, MA 02110-1301, USA.
  23
  24 ;;; Commentary:
  25 ;;
  26 ;; In semantic 1.x, the lexical analyzer was an all purpose routine.
  27 ;; To boost efficiency, the analyzer is now a series of routines that
  28 ;; are constructed at build time into a single routine.  This will
  29 ;; eliminate unneeded if statements to speed the lexer.
  30
  31 (require 'semantic-fw)
  32 ;;; Code:
  33
  34 ;;; Compatibility
  35 ;;
  36 (eval-and-compile
  37   (if (not (fboundp 'with-syntax-table))
  38
  39 ;; Copied from Emacs 21 for compatibility with released Emacses.
  40 (defmacro with-syntax-table (table &rest body)
  41   "With syntax table of current buffer set to a copy of TABLE, evaluate BODY.
  42 The syntax table of the current buffer is saved, BODY is evaluated, and the
  43 saved table is restored, even in case of an abnormal exit.
  44 Value is what BODY returns."
  45   (let ((old-table (make-symbol "table"))
  46         (old-buffer (make-symbol "buffer")))
  47     `(let ((,old-table (syntax-table))
  48            (,old-buffer (current-buffer)))
  49        (unwind-protect
  50            (progn
  51              (set-syntax-table (copy-syntax-table ,table))
  52              ,@body)
  53          (save-current-buffer
  54            (set-buffer ,old-buffer)
  55            (set-syntax-table ,old-table))))))
  56
  57 ))
  58 \f
  59 ;;; Semantic 2.x lexical analysis
  60 ;;
  61 (defun semantic-lex-map-symbols (fun table &optional property)
  62   "Call function FUN on every symbol in TABLE.
  63 If optional PROPERTY is non-nil, call FUN only on every symbol which
  64 as a PROPERTY value.  FUN receives a symbol as argument."
  65   (if (arrayp table)
  66       (mapatoms
  67        #'(lambda (symbol)
  68            (if (or (null property) (get symbol property))
  69                (funcall fun symbol)))
  70        table)))
  71
  72 ;;; Keyword table handling.
  73 ;;
  74 (defvar semantic-flex-keywords-obarray nil
  75   "Buffer local keyword obarray for the lexical analyzer.
  76 These keywords are matched explicitly, and converted into special symbols.")
  77 (make-variable-buffer-local 'semantic-flex-keywords-obarray)
  78
  79 (defmacro semantic-lex-keyword-invalid (name)
  80   "Signal that NAME is an invalid keyword name."
  81   `(signal 'wrong-type-argument '(semantic-lex-keyword-p ,name)))
  82
  83 (defsubst semantic-lex-keyword-symbol (name)
  84   "Return keyword symbol with NAME or nil if not found."
  85   (and (arrayp semantic-flex-keywords-obarray)
  86        (stringp name)
  87        (intern-soft name semantic-flex-keywords-obarray)))
  88
  89 (defsubst semantic-lex-keyword-p (name)
  90   "Return non-nil if a keyword with NAME exists in the keyword table.
  91 Return nil otherwise."
  92   (and (setq name (semantic-lex-keyword-symbol name))
  93        (symbol-value name)))
  94
  95 (defsubst semantic-lex-keyword-set (name value)
  96   "Set value of keyword with NAME to VALUE and return VALUE."
  97   (set (intern name semantic-flex-keywords-obarray) value))
  98
  99 (defsubst semantic-lex-keyword-value (name)
 100   "Return value of keyword with NAME.
 101 Signal an error if a keyword with NAME does not exist."
 102   (let ((keyword (semantic-lex-keyword-symbol name)))
 103     (if keyword
 104         (symbol-value keyword)
 105       (semantic-lex-keyword-invalid name))))
 106
 107 (defsubst semantic-lex-keyword-put (name property value)
 108   "For keyword with NAME, set its PROPERTY to VALUE."
 109   (let ((keyword (semantic-lex-keyword-symbol name)))
 110     (if keyword
 111         (put keyword property value)
 112       (semantic-lex-keyword-invalid name))))
 113
 114 (defsubst semantic-lex-keyword-get (name property)
 115   "For keyword with NAME, return its PROPERTY value."
 116   (let ((keyword (semantic-lex-keyword-symbol name)))
 117     (if keyword
 118         (get keyword property)
 119       (semantic-lex-keyword-invalid name))))
 120
 121 (defun semantic-lex-make-keyword-table (specs &optional propspecs)
 122   "Convert keyword SPECS into an obarray and return it.
 123 SPECS must be a list of (NAME . TOKSYM) elements, where:
 124
 125   NAME is the name of the keyword symbol to define.
 126   TOKSYM is the lexical token symbol of that keyword.
 127
 128 If optional argument PROPSPECS is non nil, then interpret it, and
 129 apply those properties.
 130 PROPSPECS must be a list of (NAME PROPERTY VALUE) elements."
 131   ;; Create the symbol hash table
 132   (let ((semantic-flex-keywords-obarray (make-vector 13 0))
 133         spec)
 134     ;; fill it with stuff
 135     (while specs
 136       (setq spec  (car specs)
 137             specs (cdr specs))
 138       (semantic-lex-keyword-set (car spec) (cdr spec)))
 139     ;; Apply all properties
 140     (while propspecs
 141       (setq spec (car propspecs)
 142             propspecs (cdr propspecs))
 143       (semantic-lex-keyword-put (car spec) (nth 1 spec) (nth 2 spec)))
 144     semantic-flex-keywords-obarray))
 145
 146 (defsubst semantic-lex-map-keywords (fun &optional property)
 147   "Call function FUN on every semantic keyword.
 148 If optional PROPERTY is non-nil, call FUN only on every keyword which
 149 as a PROPERTY value.  FUN receives a semantic keyword as argument."
 150   (semantic-lex-map-symbols
 151    fun semantic-flex-keywords-obarray property))
 152
 153 (defun semantic-lex-keywords (&optional property)
 154   "Return a list of semantic keywords.
 155 If optional PROPERTY is non-nil, return only keywords which have a
 156 PROPERTY set."
 157   (let (keywords)
 158     (semantic-lex-map-keywords
 159      #'(lambda (symbol) (setq keywords (cons symbol keywords)))
 160      property)
 161     keywords))
 162 \f
 163 ;;; Type table handling.
 164 ;;
 165 (defvar semantic-lex-types-obarray nil
 166   "Buffer local types obarray for the lexical analyzer.")
 167 (make-variable-buffer-local 'semantic-lex-types-obarray)
 168
 169 (defmacro semantic-lex-type-invalid (type)
 170   "Signal that TYPE is an invalid lexical type name."
 171   `(signal 'wrong-type-argument '(semantic-lex-type-p ,type)))
 172
 173 (defsubst semantic-lex-type-symbol (type)
 174   "Return symbol with TYPE or nil if not found."
 175   (and (arrayp semantic-lex-types-obarray)
 176        (stringp type)
 177        (intern-soft type semantic-lex-types-obarray)))
 178
 179 (defsubst semantic-lex-type-p (type)
 180   "Return non-nil if a symbol with TYPE name exists."
 181   (and (setq type (semantic-lex-type-symbol type))
 182        (symbol-value type)))
 183
 184 (defsubst semantic-lex-type-set (type value)
 185   "Set value of symbol with TYPE name to VALUE and return VALUE."
 186   (set (intern type semantic-lex-types-obarray) value))
 187
 188 (defsubst semantic-lex-type-value (type &optional noerror)
 189   "Return value of symbol with TYPE name.
 190 If optional argument NOERROR is non-nil return nil if a symbol with
 191 TYPE name does not exist.  Otherwise signal an error."
 192   (let ((sym (semantic-lex-type-symbol type)))
 193     (if sym
 194         (symbol-value sym)
 195       (unless noerror
 196         (semantic-lex-type-invalid type)))))
 197
 198 (defsubst semantic-lex-type-put (type property value &optional add)
 199   "For symbol with TYPE name, set its PROPERTY to VALUE.
 200 If optional argument ADD is non-nil, create a new symbol with TYPE
 201 name if it does not already exist.  Otherwise signal an error."
 202   (let ((sym (semantic-lex-type-symbol type)))
 203     (unless sym
 204       (or add (semantic-lex-type-invalid type))
 205       (semantic-lex-type-set type nil)
 206       (setq sym (semantic-lex-type-symbol type)))
 207     (put sym property value)))
 208
 209 (defsubst semantic-lex-type-get (type property &optional noerror)
 210   "For symbol with TYPE name, return its PROPERTY value.
 211 If optional argument NOERROR is non-nil return nil if a symbol with
 212 TYPE name does not exist.  Otherwise signal an error."
 213   (let ((sym (semantic-lex-type-symbol type)))
 214     (if sym
 215         (get sym property)
 216       (unless noerror
 217         (semantic-lex-type-invalid type)))))
 218
 219 (defun semantic-lex-preset-default-types ()
 220   "Install useful default properties for well known types."
 221   (semantic-lex-type-put "punctuation" 'matchdatatype 'string t)
 222   (semantic-lex-type-put "punctuation" 'syntax "\\(\\s.\\|\\s$\\|\\s'\\)+")
 223   (semantic-lex-type-put "keyword" 'matchdatatype 'keyword t)
 224   (semantic-lex-type-put "keyword" 'syntax "\\(\\sw\\|\\s_\\)+")
 225   (semantic-lex-type-put "symbol"  'matchdatatype 'regexp t)
 226   (semantic-lex-type-put "symbol"  'syntax "\\(\\sw\\|\\s_\\)+")
 227   (semantic-lex-type-put "string"  'matchdatatype 'sexp t)
 228   (semantic-lex-type-put "string"  'syntax "\\s\"")
 229   (semantic-lex-type-put "number"  'matchdatatype 'regexp t)
 230   (semantic-lex-type-put "number"  'syntax 'semantic-lex-number-expression)
 231   (semantic-lex-type-put "block"   'matchdatatype 'block t)
 232   (semantic-lex-type-put "block"   'syntax "\\s(\\|\\s)")
 233   )
 234
 235 (defun semantic-lex-make-type-table (specs &optional propspecs)
 236   "Convert type SPECS into an obarray and return it.
 237 SPECS must be a list of (TYPE . TOKENS) elements, where:
 238
 239   TYPE is the name of the type symbol to define.
 240   TOKENS is an list of (TOKSYM . MATCHER) elements, where:
 241
 242     TOKSYM is any lexical token symbol.
 243     MATCHER is a string or regexp a text must match to be a such
 244     lexical token.
 245
 246 If optional argument PROPSPECS is non nil, then interpret it, and
 247 apply those properties.
 248 PROPSPECS must be a list of (TYPE PROPERTY VALUE)."
 249   ;; Create the symbol hash table
 250   (let* ((semantic-lex-types-obarray (make-vector 13 0))
 251          spec type tokens token alist default)
 252     ;; fill it with stuff
 253     (while specs
 254       (setq spec   (car specs)
 255             specs  (cdr specs)
 256             type   (car spec)
 257             tokens (cdr spec)
 258             default nil
 259             alist   nil)
 260       (while tokens
 261         (setq token  (car tokens)
 262               tokens (cdr tokens))
 263         (if (cdr token)
 264             (setq alist (cons token alist))
 265           (setq token (car token))
 266           (if default
 267               (message
 268                "*Warning* default value of <%s> tokens changed to %S, was %S"
 269                type default token))
 270           (setq default token)))
 271       ;; Ensure the default matching spec is the first one.
 272       (semantic-lex-type-set type (cons default (nreverse alist))))
 273     ;; Install useful default types & properties
 274     (semantic-lex-preset-default-types)
 275     ;; Apply all properties
 276     (while propspecs
 277       (setq spec (car propspecs)
 278             propspecs (cdr propspecs))
 279       ;; Create the type if necessary.
 280       (semantic-lex-type-put (car spec) (nth 1 spec) (nth 2 spec) t))
 281     semantic-lex-types-obarray))
 282
 283 (defsubst semantic-lex-map-types (fun &optional property)
 284   "Call function FUN on every lexical type.
 285 If optional PROPERTY is non-nil, call FUN only on every type symbol
 286 which as a PROPERTY value.  FUN receives a type symbol as argument."
 287   (semantic-lex-map-symbols
 288    fun semantic-lex-types-obarray property))
 289
 290 (defun semantic-lex-types (&optional property)
 291   "Return a list of lexical type symbols.
 292 If optional PROPERTY is non-nil, return only type symbols which have
 293 PROPERTY set."
 294   (let (types)
 295     (semantic-lex-map-types
 296      #'(lambda (symbol) (setq types (cons symbol types)))
 297      property)
 298     types))
 299 \f
 300 ;;;###autoload
 301 (defvar semantic-lex-analyzer 'semantic-flex
 302   "The lexical analyzer used for a given buffer.
 303 See `semantic-lex' for documentation.
 304 For compatibility with Semantic 1.x it defaults to `semantic-flex'.")
 305 (make-variable-buffer-local 'semantic-lex-analyzer)
 306
 307 (defvar semantic-lex-tokens
 308   '(
 309     (bol)
 310     (charquote)
 311     (close-paren)
 312     (comment)
 313     (newline)
 314     (open-paren)
 315     (punctuation)
 316     (semantic-list)
 317     (string)
 318     (symbol)
 319     (whitespace)
 320     )
 321   "An alist of of semantic token types.
 322 As of December 2001 (semantic 1.4beta13), this variable is not used in
 323 any code.  The only use is to refer to the doc-string from elsewhere.
 324
 325 The key to this alist is the symbol representing token type that
 326 \\[semantic-flex] returns.  These are
 327
 328   - bol:           Empty string matching a beginning of line.
 329                    This token is produced with
 330                    `semantic-lex-beginning-of-line'.
 331
 332   - charquote:     String sequences that match `\\s\\+' regexp.
 333                    This token is produced with `semantic-lex-charquote'.
 334
 335   - close-paren:   Characters that match `\\s)' regexp.
 336                    These are typically `)', `}', `]', etc.
 337                    This token is produced with
 338                    `semantic-lex-close-paren'.
 339
 340   - comment:       A comment chunk.  These token types are not
 341                    produced by default.
 342                    This token is produced with `semantic-lex-comments'.
 343                    Comments are ignored with `semantic-lex-ignore-comments'.
 344                    Comments are treated as whitespace with
 345                    `semantic-lex-comments-as-whitespace'.
 346
 347   - newline        Characters matching `\\s-*\\(\n\\|\\s>\\)' regexp.
 348                    This token is produced with `semantic-lex-newline'.
 349
 350   - open-paren:    Characters that match `\\s(' regexp.
 351                    These are typically `(', `{', `[', etc.
 352                    If `semantic-lex-paren-or-list' is used,
 353                    then `open-paren' is not usually generated unless
 354                    the `depth' argument to \\[semantic-lex] is
 355                    greater than 0.
 356                    This token is always produced if the analyzer
 357                    `semantic-lex-open-paren' is used.
 358
 359   - punctuation:   Characters matching `{\\(\\s.\\|\\s$\\|\\s'\\)'
 360                    regexp.
 361                    This token is produced with `semantic-lex-punctuation'.
 362                    Always specify this analyzer after the comment
 363                    analyzer.
 364
 365   - semantic-list: String delimited by matching parenthesis, braces,
 366                    etc.  that the lexer skipped over, because the
 367                    `depth' parameter to \\[semantic-flex] was not high
 368                    enough.
 369                    This token is produced with `semantic-lex-paren-or-list'.
 370
 371   - string:        Quoted strings, i.e., string sequences that start
 372                    and end with characters matching `\\s\"'
 373                    regexp.  The lexer relies on @code{forward-sexp} to
 374                    find the matching end.
 375                    This token is produced with `semantic-lex-string'.
 376
 377   - symbol:        String sequences that match `\\(\\sw\\|\\s_\\)+'
 378                    regexp.
 379                    This token is produced with
 380                    `semantic-lex-symbol-or-keyword'.  Always add this analyzer
 381                    after `semantic-lex-number', or other analyzers that
 382                    match its regular expression.
 383
 384   - whitespace:    Characters that match `\\s-+' regexp.
 385                    This token is produced with `semantic-lex-whitespace'.")
 386
 387 (defvar semantic-lex-syntax-modifications nil
 388   "Changes to the syntax table for this buffer.
 389 These changes are active only while the buffer is being flexed.
 390 This is a list where each element has the form:
 391   (CHAR CLASS)
 392 CHAR is the char passed to `modify-syntax-entry',
 393 and CLASS is the string also passed to `modify-syntax-entry' to define
 394 what syntax class CHAR has.")
 395 (make-variable-buffer-local 'semantic-lex-syntax-modifications)
 396
 397 (defvar semantic-lex-syntax-table nil
 398   "Syntax table used by lexical analysis.
 399 See also `semantic-lex-syntax-modifications'.")
 400 (make-variable-buffer-local 'semantic-lex-syntax-table)
 401
 402 (defvar semantic-lex-comment-regex nil
 403   "Regular expression for identifying comment start during lexical analysis.
 404 This may be automatically set when semantic initializes in a mode, but
 405 may need to be overriden for some special languages.")
 406 (make-variable-buffer-local 'semantic-lex-comment-regex)
 407
 408 (defvar semantic-lex-number-expression
 409   ;; This expression was written by David Ponce for Java, and copied
 410   ;; here for C and any other similar language.
 411   (eval-when-compile
 412     (concat "\\("
 413             "\\<[0-9]+[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>"
 414             "\\|"
 415             "\\<[0-9]+[.][eE][-+]?[0-9]+[fFdD]?\\>"
 416             "\\|"
 417             "\\<[0-9]+[.][fFdD]\\>"
 418             "\\|"
 419             "\\<[0-9]+[.]"
 420             "\\|"
 421             "[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>"
 422             "\\|"
 423             "\\<[0-9]+[eE][-+]?[0-9]+[fFdD]?\\>"
 424             "\\|"
 425             "\\<0[xX][0-9a-fA-F]+[lL]?\\>"
 426             "\\|"
 427             "\\<[0-9]+[lLfFdD]?\\>"
 428             "\\)"
 429             ))
 430   "Regular expression for matching a number.
 431 If this value is nil, no number extraction is done during lex.
 432 This expression tries to match C and Java like numbers.
 433
 434 DECIMAL_LITERAL:
 435     [1-9][0-9]*
 436   ;
 437 HEX_LITERAL:
 438     0[xX][0-9a-fA-F]+
 439   ;
 440 OCTAL_LITERAL:
 441     0[0-7]*
 442   ;
 443 INTEGER_LITERAL:
 444     <DECIMAL_LITERAL>[lL]?
 445   | <HEX_LITERAL>[lL]?
 446   | <OCTAL_LITERAL>[lL]?
 447   ;
 448 EXPONENT:
 449     [eE][+-]?[09]+
 450   ;
 451 FLOATING_POINT_LITERAL:
 452     [0-9]+[.][0-9]*<EXPONENT>?[fFdD]?
 453   | [.][0-9]+<EXPONENT>?[fFdD]?
 454   | [0-9]+<EXPONENT>[fFdD]?
 455   | [0-9]+<EXPONENT>?[fFdD]
 456   ;")
 457 (make-variable-buffer-local 'semantic-lex-number-expression)
 458
 459 (defvar semantic-lex-depth 0
 460   "Default lexing depth.
 461 This specifies how many lists to create tokens in.")
 462 (make-variable-buffer-local 'semantic-lex-depth)
 463
 464 (defvar semantic-lex-unterminated-syntax-end-function
 465   (lambda (syntax syntax-start lex-end) lex-end)
 466   "Function called when unterminated syntax is encountered.
 467 This should be set to one function.  That function should take three
 468 parameters.  The SYNTAX, or type of syntax which is unterminated.
 469 SYNTAX-START where the broken syntax begins.
 470 LEX-END is where the lexical analysis was asked to end.
 471 This function can be used for languages that can intelligently fix up
 472 broken syntax, or the exit lexical analysis via `throw' or `signal'
 473 when finding unterminated syntax.")
 474
 475 ;;; Interactive testing commands
 476
 477 (defun semantic-lex-test (arg)
 478   "Test the semantic lexer in the current buffer.
 479 If universal argument ARG, then try the whole buffer."
 480   (interactive "P")
 481   (let* ((start (current-time))
 482          (result (semantic-lex
 483                   (if arg (point-min) (point))
 484                   (point-max)))
 485          (end (current-time)))
 486     (message "Elapsed Time: %.2f seconds."
 487              (semantic-elapsed-time start end)))
 488   )
 489
 490 (defun semantic-lex-test-region (beg end)
 491   "Test the semantic lexer in the current buffer.
 492 Analyze the area between BEG and END."
 493   (interactive "r")
 494   (let ((result (semantic-lex beg end)))
 495     (message "%s: %S" semantic-lex-analyzer result))
 496   )
 497
 498 (defvar semantic-lex-debug nil
 499   "When non-nil, debug the local lexical analyzer.")
 500
 501 (defun semantic-lex-debug (arg)
 502   "Debug the semantic lexer in the current buffer.
 503 Argument ARG specifies of the analyze the whole buffer, or start at point.
 504 While engaged, each token identified by the lexer will be highlighted
 505 in the target buffer   A description of the current token will be
 506 displayed in the minibuffer.  Press SPC to move to the next lexical token."
 507   (interactive "P")
 508   (require 'semantic-debug)
 509   (let ((semantic-lex-debug t))
 510     (semantic-lex-test arg)))
 511
 512 (defun semantic-lex-highlight-token (token)
 513   "Highlight the lexical TOKEN.
 514 Return the overlay."
 515   (let ((o (semantic-make-overlay (semantic-lex-token-start token)
 516                                   (semantic-lex-token-end token))))
 517     (semantic-overlay-put o 'face 'highlight)
 518     o))
 519
 520 (defsubst semantic-lex-debug-break (token)
 521   "Break during lexical analysis at TOKEN."
 522   (when semantic-lex-debug
 523     (let ((o nil))
 524       (unwind-protect
 525           (progn
 526             (when token
 527               (setq o (semantic-lex-highlight-token token)))
 528             (semantic-read-event
 529              (format "%S :: SPC - continue" token))
 530             )
 531         (when o
 532           (semantic-overlay-delete o))))))
 533
 534 ;;; Lexical analyzer creation
 535 (defmacro semantic-lex-one-token (analyzers)
 536   "Calculate one token from the current buffer at point.
 537 Uses locally bound variables from `define-lex'.
 538 Argument ANALYZERS is the list of analyzers being used."
 539   (cons 'cond (mapcar #'symbol-value analyzers)))
 540
 541 (defvar semantic-lex-end-point nil
 542   "The end point as tracked through lexical functions.")
 543
 544 (defvar semantic-lex-current-depth nil
 545   "The current depth as tracked through lexical functions.")
 546
 547 (defvar semantic-lex-maximum-depth nil
 548   "The maximum depth of parenthisis as tracked through lexical functions.")
 549
 550 (defvar semantic-lex-token-stream nil
 551   "The current token stream we are collecting.")
 552
 553 (defvar semantic-lex-analysis-bounds nil
 554   "The bounds of the current analysis.")
 555
 556 (defvar semantic-lex-block-streams nil
 557   "Streams of tokens inside collapsed blocks.
 558 This is an alist of (ANCHOR . STREAM) elements where ANCHOR is the
 559 start position of the block, and STREAM is the list of tokens in that
 560 block.")
 561
 562 (defvar semantic-lex-reset-hooks nil
 563   "List of hooks major-modes use to reset lexical analyzers.
 564 Hooks are called with START and END values for the current lexical pass.
 565 Should be set with `add-hook'specifying a LOCAL option.")
 566
 567 ;; Stack of nested blocks.
 568 (defvar semantic-lex-block-stack nil)
 569
 570 ;;;###autoload
 571 (defmacro define-lex (name doc &rest analyzers)
 572   "Create a new lexical analyzer with NAME.
 573 DOC is a documentation string describing this analyzer.
 574 ANALYZERS are small code snippets of analyzers to use when
 575 building the new NAMED analyzer.  Only use analyzers which
 576 are written to be used in `define-lex'.
 577 Each analyzer should be an analyzer created with `define-lex-analyzer'.
 578 Note: The order in which analyzers are listed is important.
 579 If two analyzers can match the same text, it is important to order the
 580 analyzers so that the one you want to match first occurs first.  For
 581 example, it is good to put a numbe analyzer in front of a symbol
 582 analyzer which might mistake a number for as a symbol."
 583   `(defun ,name  (start end &optional depth length)
 584      ,(concat doc "\nSee `semantic-lex' for more information.")
 585      ;; Make sure the state of block parsing starts over.
 586      (setq semantic-lex-block-streams nil)
 587      ;; Allow specialty reset items.
 588      (run-hook-with-args 'semantic-lex-reset-hooks start end)
 589      ;; Lexing state.
 590      (let* ((starting-position (point))
 591             (semantic-lex-token-stream nil)
 592             (semantic-lex-block-stack nil)
 593             (tmp-start start)
 594             (semantic-lex-end-point start)
 595             (semantic-lex-current-depth 0)
 596             ;; Use the default depth when not specified.
 597             (semantic-lex-maximum-depth
 598              (or depth semantic-lex-depth))
 599             ;; Bounds needed for unterminated syntax
 600             (semantic-lex-analysis-bounds (cons start end))
 601             ;; This entry prevents text properties from
 602             ;; confusing our lexical analysis.  See Emacs 22 (CVS)
 603             ;; version of C++ mode with template hack text properties.
 604             (parse-sexp-lookup-properties nil)
 605             )
 606        ;; Maybe REMOVE THIS LATER.
 607        ;; Trying to find incremental parser bug.
 608        (when (> end (point-max))
 609          (error ,(format "%s: end (%%d) > point-max (%%d)" name)
 610                 end (point-max)))
 611        (with-syntax-table semantic-lex-syntax-table
 612          (goto-char start)
 613          (while (and (< (point) end)
 614                      (or (not length)
 615                          (<= (length semantic-lex-token-stream) length)))
 616            (semantic-lex-one-token ,analyzers)
 617            (when (eq semantic-lex-end-point tmp-start)
 618              (error ,(format "%s: endless loop at %%d, after %%S" name)
 619                     tmp-start (car semantic-lex-token-stream)))
 620            (setq tmp-start semantic-lex-end-point)
 621            (goto-char semantic-lex-end-point)
 622            (semantic-lex-debug-break (car semantic-lex-token-stream))
 623            ))
 624        ;; Check that there is no unterminated block.
 625        (when semantic-lex-block-stack
 626          (let* ((last (pop semantic-lex-block-stack))
 627                 (blk last))
 628            (while blk
 629              (message
 630               ,(format "%s: `%%s' block from %%S is unterminated" name)
 631               (car blk) (cadr blk))
 632              (setq blk (pop semantic-lex-block-stack)))
 633            (semantic-lex-unterminated-syntax-detected (car last))))
 634        ;; Return to where we started.
 635        ;; Do not wrap in protective stuff so that if there is an error
 636        ;; thrown, the user knows where.
 637        (goto-char starting-position)
 638        ;; Return the token stream
 639        (nreverse semantic-lex-token-stream))))
 640 \f
 641 ;;; Collapsed block tokens delimited by any tokens.
 642 ;;
 643 (defun semantic-lex-start-block (syntax)
 644   "Mark the last read token as the beginning of a SYNTAX block."
 645   (if (or (not semantic-lex-maximum-depth)
 646           (< semantic-lex-current-depth semantic-lex-maximum-depth))
 647       (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
 648     (push (list syntax (car semantic-lex-token-stream))
 649           semantic-lex-block-stack)))
 650
 651 (defun semantic-lex-end-block (syntax)
 652   "Process the end of a previously marked SYNTAX block.
 653 That is, collapse the tokens inside that block, including the
 654 beginning and end of block tokens, into a high level block token of
 655 class SYNTAX.
 656 The token at beginning of block is the one marked by a previous call
 657 to `semantic-lex-start-block'.  The current token is the end of block.
 658 The collapsed tokens are saved in `semantic-lex-block-streams'."
 659   (if (null semantic-lex-block-stack)
 660       (setq semantic-lex-current-depth (1- semantic-lex-current-depth))
 661     (let* ((stream semantic-lex-token-stream)
 662            (blk (pop semantic-lex-block-stack))
 663            (bstream (cdr blk))
 664            (first (car bstream))
 665            (last (pop stream)) ;; The current token mark the EOBLK
 666            tok)
 667       (if (not (eq (car blk) syntax))
 668           ;; SYNTAX doesn't match the syntax of the current block in
 669           ;; the stack. So we encountered the end of the SYNTAX block
 670           ;; before the end of the current one in the stack which is
 671           ;; signaled unterminated.
 672           (semantic-lex-unterminated-syntax-detected (car blk))
 673         ;; Move tokens found inside the block from the main stream
 674         ;; into a separate block stream.
 675         (while (and stream (not (eq (setq tok (pop stream)) first)))
 676           (push tok bstream))
 677         ;; The token marked as beginning of block was not encountered.
 678         ;; This should not happen!
 679         (or (eq tok first)
 680             (error "Token %S not found at beginning of block `%s'"
 681                    first syntax))
 682         ;; Save the block stream for future reuse, to avoid to redo
 683         ;; the lexical analysis of the block content!
 684         ;; Anchor the block stream with its start position, so we can
 685         ;; use: (cdr (assq start semantic-lex-block-streams)) to
 686         ;; quickly retrieve the lexical stream associated to a block.
 687         (setcar blk (semantic-lex-token-start first))
 688         (setcdr blk (nreverse bstream))
 689         (push blk semantic-lex-block-streams)
 690         ;; In the main stream, replace the tokens inside the block by
 691         ;; a high level block token of class SYNTAX.
 692         (setq semantic-lex-token-stream stream)
 693         (semantic-lex-push-token
 694          (semantic-lex-token
 695           syntax (car blk) (semantic-lex-token-end last)))
 696         ))))
 697 \f
 698 ;;; Lexical token API
 699 ;;
 700 (defmacro semantic-lex-token (symbol start end &optional str)
 701   "Create a lexical token.
 702 SYMBOL is a symbol representing the class of syntax found.
 703 START and END define the bounds of the token in the current buffer.
 704 Optional STR is the string for the token iff the the bounds
 705 in the buffer do not cover the string they represent.  (As from
 706 macro expansion.)"
 707   ;; This if statement checks the existance of a STR argument at
 708   ;; compile time, where STR is some symbol or constant.  If the
 709   ;; variable STr (runtime) is nil, this will make an incorrect decision.
 710   ;;
 711   ;; It is like this to maintain the original speed of the compiled
 712   ;; code.
 713   (if str
 714       `(cons ,symbol (cons ,str (cons ,start ,end)))
 715     `(cons ,symbol (cons ,start ,end))))
 716
 717 (defun semantic-lex-expand-block-specs (specs)
 718   "Expand block specifications SPECS into a Lisp form.
 719 SPECS is a list of (BLOCK BEGIN END) elements where BLOCK, BEGIN, and
 720 END are token class symbols that indicate to produce one collapsed
 721 BLOCK token from tokens found between BEGIN and END ones.
 722 BLOCK must be a non-nil symbol, and at least one of the BEGIN or END
 723 symbols must be non-nil too.
 724 When BEGIN is non-nil, generate a call to `semantic-lex-start-block'
 725 when a BEGIN token class is encountered.
 726 When END is non-nil, generate a call to `semantic-lex-end-block' when
 727 an END token class is encountered."
 728   (let ((class (make-symbol "class"))
 729         (form nil))
 730     (dolist (spec specs)
 731       (when (car spec)
 732         (when (nth 1 spec)
 733           (push `((eq ',(nth 1 spec) ,class)
 734                   (semantic-lex-start-block ',(car spec)))
 735                 form))
 736         (when (nth 2 spec)
 737           (push `((eq ',(nth 2 spec) ,class)
 738                   (semantic-lex-end-block ',(car spec)))
 739                 form))))
 740     (when form
 741       `((let ((,class (semantic-lex-token-class
 742                        (car semantic-lex-token-stream))))
 743           (cond ,@(nreverse form))))
 744       )))
 745
 746 (defmacro semantic-lex-push-token (token &rest blockspecs)
 747   "Push TOKEN in the lexical analyzer token stream.
 748 Return the lexical analysis current end point.
 749 If optional arguments BLOCKSPECS is non-nil, it specifies to process
 750 collapsed block tokens.  See `semantic-lex-expand-block-specs' for
 751 more details.
 752 This macro should only be called within the bounds of
 753 `define-lex-analyzer'.  It changes the values of the lexical analyzer
 754 variables `token-stream' and `semantic-lex-end-point'.  If you need to
 755 move `semantic-lex-end-point' somewhere else, just modify this
 756 variable after calling `semantic-lex-push-token'."
 757   `(progn
 758      (push ,token semantic-lex-token-stream)
 759      ,@(semantic-lex-expand-block-specs blockspecs)
 760      (setq semantic-lex-end-point
 761            (semantic-lex-token-end (car semantic-lex-token-stream)))
 762      ))
 763
 764 (defsubst semantic-lex-token-class (token)
 765   "Fetch the class of the lexical token TOKEN.
 766 See also the function `semantic-lex-token'."
 767   (car token))
 768
 769 (defsubst semantic-lex-token-bounds (token)
 770   "Fetch the start and end locations of the lexical token TOKEN.
 771 Return a pair (START . END)."
 772   (if (stringp (car (cdr token)))
 773       (cdr (cdr token))
 774     (cdr token)))
 775
 776 (defsubst semantic-lex-token-start (token)
 777   "Fetch the start position of the lexical token TOKEN.
 778 See also the function `semantic-lex-token'."
 779   (car (semantic-lex-token-bounds token)))
 780
 781 (defsubst semantic-lex-token-end (token)
 782   "Fetch the end position of the lexical token TOKEN.
 783 See also the function `semantic-lex-token'."
 784   (cdr (semantic-lex-token-bounds token)))
 785
 786 (defsubst semantic-lex-token-text (token)
 787   "Fetch the text associated with the lexical token TOKEN.
 788 See also the function `semantic-lex-token'."
 789   (if (stringp (car (cdr token)))
 790       (car (cdr token))
 791     (buffer-substring-no-properties
 792      (semantic-lex-token-start token)
 793      (semantic-lex-token-end   token))))
 794
 795 ;;;###autoload
 796 (defun semantic-lex-init ()
 797   "Initialize any lexical state for this buffer."
 798   (unless semantic-lex-comment-regex
 799     (setq semantic-lex-comment-regex
 800           (if comment-start-skip
 801               (concat "\\(\\s<\\|" comment-start-skip "\\)")
 802             "\\(\\s<\\)")))
 803   ;; Setup the lexer syntax-table
 804   (setq semantic-lex-syntax-table (copy-syntax-table (syntax-table)))
 805   (dolist (mod semantic-lex-syntax-modifications)
 806     (modify-syntax-entry
 807      (car mod) (nth 1 mod) semantic-lex-syntax-table)))
 808
 809 ;;;###autoload
 810 (define-overload semantic-lex (start end &optional depth length)
 811   "Lexically analyze text in the current buffer between START and END.
 812 Optional argument DEPTH indicates at what level to scan over entire
 813 lists.  The last argument, LENGTH specifies that `semantic-lex'
 814 should only return LENGTH tokens.  The return value is a token stream.
 815 Each element is a list, such of the form
 816   (symbol start-expression .  end-expression)
 817 where SYMBOL denotes the token type.
 818 See `semantic-lex-tokens' variable for details on token types.  END
 819 does not mark the end of the text scanned, only the end of the
 820 beginning of text scanned.  Thus, if a string extends past END, the
 821 end of the return token will be larger than END.  To truly restrict
 822 scanning, use `narrow-to-region'."
 823   (funcall semantic-lex-analyzer start end depth length))
 824
 825 (defsubst semantic-lex-buffer (&optional depth)
 826   "Lex the current buffer.
 827 Optional argument DEPTH is the depth to scan into lists."
 828   (semantic-lex (point-min) (point-max) depth))
 829
 830 (defsubst semantic-lex-list (semlist depth)
 831   "Lex the body of SEMLIST to DEPTH."
 832   (semantic-lex (semantic-lex-token-start semlist)
 833                 (semantic-lex-token-end   semlist)
 834                 depth))
 835 \f
 836 ;;; Analyzer creation macros
 837 ;;
 838 (defsubst semantic-lex-unterminated-syntax-detected (syntax)
 839   "Inside a lexical analyzer, use this when unterminated syntax was found.
 840 Argument SYNTAX indicates the type of syntax that is unterminated.
 841 The job of this function is to move (point) to a new logical location
 842 so that analysis can continue, if possible."
 843   (goto-char
 844    (funcall semantic-lex-unterminated-syntax-end-function
 845             syntax
 846             (car semantic-lex-analysis-bounds)
 847             (cdr semantic-lex-analysis-bounds)
 848             ))
 849   (setq semantic-lex-end-point (point)))
 850
 851 (defcustom semantic-lex-debug-analyzers nil
 852   "Non nil means to debug analyzers with syntax protection.
 853 Only in effect if `debug-on-error' is also non-nil."
 854   :group 'semantic
 855   :type 'boolean)
 856
 857 (defmacro semantic-lex-unterminated-syntax-protection (syntax &rest forms)
 858   "For SYNTAX, execute FORMS with protection for unterminated syntax.
 859 If FORMS throws an error, treat this as a syntax problem, and
 860 execute the unterminated syntax code.  FORMS should return a position.
 861 Irreguardless of an error, the cursor should be moved to the end of
 862 the desired syntax, and a position returned.
 863 If `debug-on-error' is set, errors are not caught, so that you can
 864 debug them.
 865 Avoid using a large FORMS since it is duplicated."
 866   `(if (and debug-on-error semantic-lex-debug-analyzers)
 867        (progn ,@forms)
 868      (condition-case nil
 869          (progn ,@forms)
 870        (error
 871         (semantic-lex-unterminated-syntax-detected ,syntax)))))
 872 (put 'semantic-lex-unterminated-syntax-protection
 873      'lisp-indent-function 1)
 874
 875 ;;;###autoload
 876 (defmacro define-lex-analyzer (name doc condition &rest forms)
 877   "Create a single lexical analyzer NAME with DOC.
 878 When an analyzer is called, the current buffer and point are
 879 positioned in a buffer at the location to be analyzed.
 880 CONDITION is an expression which returns t if FORMS should be run.
 881 Within the bounds of CONDITION and FORMS, the use of backquote
 882 can be used to evaluate expressions at compile time.
 883 While forms are running, the following variables will be locally bound:
 884   `semantic-lex-analysis-bounds' - The bounds of the current analysis.
 885                   of the form (START . END)
 886   `semantic-lex-maximum-depth' - The maximum depth of semantic-list
 887                   for the current analysis.
 888   `semantic-lex-current-depth' - The current depth of `semantic-list' that has
 889                   been decended.
 890   `semantic-lex-end-point' - End Point after match.
 891                    Analyzers should set this to a buffer location if their
 892                    match string does not represent the end of the matched text.
 893   `semantic-lex-token-stream' - The token list being collected.
 894                    Add new lexical tokens to this list.
 895 Proper action in FORMS is to move the value of `semantic-lex-end-point' to
 896 after the location of the analyzed entry, and to add any discovered tokens
 897 at the beginning of `semantic-lex-token-stream'.
 898 This can be done by using `semantic-lex-push-token'."
 899   `(eval-and-compile
 900      (defvar ,name nil ,doc)
 901      (defun ,name nil)
 902      ;; Do this part separately so that re-evaluation rebuilds this code.
 903      (setq ,name '(,condition ,@forms))
 904      ;; Build a single lexical analyzer function, so the doc for
 905      ;; function help is automatically provided, and perhaps the
 906      ;; function could be useful for testing and debugging one
 907      ;; analyzer.
 908      (fset ',name (lambda () ,doc
 909                     (let ((semantic-lex-token-stream nil)
 910                           (semantic-lex-end-point (point))
 911                           (semantic-lex-analysis-bounds
 912                            (cons (point) (point-max)))
 913                           (semantic-lex-current-depth 0)
 914                           (semantic-lex-maximum-depth
 915                            semantic-lex-depth)
 916                           )
 917                       (when ,condition ,@forms)
 918                       semantic-lex-token-stream)))
 919      ))
 920
 921 ;;;###autoload
 922 (defmacro define-lex-regex-analyzer (name doc regexp &rest forms)
 923   "Create a lexical analyzer with NAME and DOC that will match REGEXP.
 924 FORMS are evaluated upon a successful match.
 925 See `define-lex-analyzer' for more about analyzers."
 926   `(define-lex-analyzer ,name
 927      ,doc
 928      (looking-at ,regexp)
 929      ,@forms
 930      ))
 931
 932 ;;;###autoload
 933 (defmacro define-lex-simple-regex-analyzer (name doc regexp toksym
 934                                                  &optional index
 935                                                  &rest forms)
 936   "Create a lexical analyzer with NAME and DOC that match REGEXP.
 937 TOKSYM is the symbol to use when creating a semantic lexical token.
 938 INDEX is the index into the match that defines the bounds of the token.
 939 Index should be a plain integer, and not specified in the macro as an
 940 expression.
 941 FORMS are evaluated upon a successful match BEFORE the new token is
 942 created.  It is valid to ignore FORMS.
 943 See `define-lex-analyzer' for more about analyzers."
 944   `(define-lex-analyzer ,name
 945      ,doc
 946      (looking-at ,regexp)
 947      ,@forms
 948      (semantic-lex-push-token
 949       (semantic-lex-token ,toksym
 950                           (match-beginning ,(or index 0))
 951                           (match-end ,(or index 0))))
 952      ))
 953
 954 ;;;###autoload
 955 (defmacro define-lex-block-analyzer (name doc spec1 &rest specs)
 956   "Create a lexical analyzer NAME for paired delimiters blocks.
 957 It detects a paired delimiters block or the corresponding open or
 958 close delimiter depending on the value of the variable
 959 `semantic-lex-current-depth'.  DOC is the documentation string of the lexical
 960 analyzer.  SPEC1 and SPECS specify the token symbols and open, close
 961 delimiters used.  Each SPEC has the form:
 962
 963 \(BLOCK-SYM (OPEN-DELIM OPEN-SYM) (CLOSE-DELIM CLOSE-SYM))
 964
 965 where BLOCK-SYM is the symbol returned in a block token.  OPEN-DELIM
 966 and CLOSE-DELIM are respectively the open and close delimiters
 967 identifying a block.  OPEN-SYM and CLOSE-SYM are respectively the
 968 symbols returned in open and close tokens."
 969   (let ((specs (cons spec1 specs))
 970         spec open olist clist)
 971     (while specs
 972       (setq spec  (car specs)
 973             specs (cdr specs)
 974             open  (nth 1 spec)
 975             ;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...)
 976             olist (cons (list (car open) (cadr open) (car spec)) olist)
 977             ;; build alist ((CLOSE-DELIM CLOSE-SYM) ...)
 978             clist (cons (nth 2 spec) clist)))
 979     `(define-lex-analyzer ,name
 980        ,doc
 981        (and
 982         (looking-at "\\(\\s(\\|\\s)\\)")
 983         (let ((text (match-string 0)) match)
 984           (cond
 985            ((setq match (assoc text ',olist))
 986             (if (or (not semantic-lex-maximum-depth)
 987                     (< semantic-lex-current-depth semantic-lex-maximum-depth))
 988                 (progn
 989                   (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
 990                   (semantic-lex-push-token
 991                    (semantic-lex-token
 992                     (nth 1 match)
 993                     (match-beginning 0) (match-end 0))))
 994               (semantic-lex-push-token
 995                (semantic-lex-token
 996                 (nth 2 match)
 997                 (match-beginning 0)
 998                 (save-excursion
 999                   (semantic-lex-unterminated-syntax-protection (nth 2 match)
1000                     (forward-list 1)
1001                     (point)))
1002                 ))
1003               ))
1004            ((setq match (assoc text ',clist))
1005             (setq semantic-lex-current-depth (1- semantic-lex-current-depth))
1006             (semantic-lex-push-token
1007              (semantic-lex-token
1008               (nth 1 match)
1009               (match-beginning 0) (match-end 0)))))))
1010        )))
1011 \f
1012 ;;; Analyzers
1013 ;;
1014 (define-lex-analyzer semantic-lex-default-action
1015   "The default action when no other lexical actions match text.
1016 This action will just throw an error."
1017   t
1018   (error "Unmatched Text during Lexical Analysis"))
1019
1020 (define-lex-analyzer semantic-lex-beginning-of-line
1021   "Detect and create a beginning of line token (BOL)."
1022   (and (bolp)
1023        ;; Just insert a (bol N . N) token in the token stream,
1024        ;; without moving the point.  N is the point at the
1025        ;; beginning of line.
1026        (semantic-lex-push-token (semantic-lex-token 'bol (point) (point)))
1027        nil) ;; CONTINUE
1028   ;; We identify and add the BOL token onto the stream, but since
1029   ;; semantic-lex-end-point doesn't move, we always fail CONDITION, and have no
1030   ;; FORMS body.
1031   nil)
1032
1033 (define-lex-simple-regex-analyzer semantic-lex-newline
1034   "Detect and create newline tokens."
1035   "\\s-*\\(\n\\|\\s>\\)"  'newline 1)
1036
1037 (define-lex-regex-analyzer semantic-lex-newline-as-whitespace
1038   "Detect and create newline tokens.
1039 Use this ONLY if newlines are not whitespace characters (such as when
1040 they are comment end characters) AND when you want whitespace tokens."
1041   "\\s-*\\(\n\\|\\s>\\)"
1042   ;; Language wants whitespaces, link them together.
1043   (if (eq (semantic-lex-token-class (car semantic-lex-token-stream))
1044           'whitespace)
1045       (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
1046               (match-end 0))
1047     (semantic-lex-push-token
1048      (semantic-lex-token
1049       'whitespace (match-beginning 0) (match-end 0)))))
1050
1051 (define-lex-regex-analyzer semantic-lex-ignore-newline
1052   "Detect and create newline tokens.
1053 Use this ONLY if newlines are not whitespace characters (such as when
1054 they are comment end characters)."
1055   "\\s-*\\(\n\\|\\s>\\)"
1056   (setq semantic-lex-end-point (match-end 0)))
1057
1058 (define-lex-regex-analyzer semantic-lex-whitespace
1059   "Detect and create whitespace tokens."
1060   ;; catch whitespace when needed
1061   "\\s-+"
1062   ;; Language wants whitespaces, link them together.
1063   (if (eq (semantic-lex-token-class (car semantic-lex-token-stream))
1064           'whitespace)
1065       (progn
1066         (setq semantic-lex-end-point (match-end 0))
1067         (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
1068                 semantic-lex-end-point))
1069     (semantic-lex-push-token
1070      (semantic-lex-token
1071       'whitespace (match-beginning 0) (match-end 0)))))
1072
1073 (define-lex-regex-analyzer semantic-lex-ignore-whitespace
1074   "Detect and skip over whitespace tokens."
1075   ;; catch whitespace when needed
1076   "\\s-+"
1077   ;; Skip over the detected whitespace.
1078   (setq semantic-lex-end-point (match-end 0)))
1079
1080 (define-lex-simple-regex-analyzer semantic-lex-number
1081   "Detect and create number tokens.
1082 See `semantic-lex-number-expression' for details on matching numbers,
1083 and number formats."
1084   semantic-lex-number-expression 'number)
1085
1086 (define-lex-regex-analyzer semantic-lex-symbol-or-keyword
1087   "Detect and create symbol and keyword tokens."
1088   "\\(\\sw\\|\\s_\\)+"
1089   (semantic-lex-push-token
1090    (semantic-lex-token
1091     (or (semantic-lex-keyword-p (match-string 0)) 'symbol)
1092     (match-beginning 0) (match-end 0))))
1093
1094 (define-lex-simple-regex-analyzer semantic-lex-charquote
1095   "Detect and create charquote tokens."
1096   ;; Character quoting characters (ie, \n as newline)
1097   "\\s\\+" 'charquote)
1098
1099 (define-lex-simple-regex-analyzer semantic-lex-punctuation
1100   "Detect and create punctuation tokens."
1101   "\\(\\s.\\|\\s$\\|\\s'\\)" 'punctuation)
1102
1103 (define-lex-analyzer semantic-lex-punctuation-type
1104   "Detect and create a punctuation type token.
1105 Recognized punctuations are defined in the current table of lexical
1106 types, as the value of the `punctuation' token type."
1107   (and (looking-at "\\(\\s.\\|\\s$\\|\\s'\\)+")
1108        (let* ((key (match-string 0))
1109               (pos (match-beginning 0))
1110               (end (match-end 0))
1111               (len (- end pos))
1112               (lst (semantic-lex-type-value "punctuation" t))
1113               (def (car lst)) ;; default lexical symbol or nil
1114               (lst (cdr lst)) ;; alist of (LEX-SYM . PUNCT-STRING)
1115               (elt nil))
1116          (if lst
1117              ;; Starting with the longest one, search if the
1118              ;; punctuation string is defined for this language.
1119              (while (and (> len 0) (not (setq elt (rassoc key lst))))
1120                (setq len (1- len)
1121                      key (substring key 0 len))))
1122          (if elt ;; Return the punctuation token found
1123              (semantic-lex-push-token
1124               (semantic-lex-token (car elt) pos (+ pos len)))
1125            (if def ;; Return a default generic token
1126                (semantic-lex-push-token
1127                 (semantic-lex-token def pos end))
1128              ;; Nothing match
1129              )))))
1130
1131 (define-lex-regex-analyzer semantic-lex-paren-or-list
1132   "Detect open parenthesis.
1133 Return either a paren token or a semantic list token depending on
1134 `semantic-lex-current-depth'."
1135   "\\s("
1136   (if (or (not semantic-lex-maximum-depth)
1137           (< semantic-lex-current-depth semantic-lex-maximum-depth))
1138       (progn
1139         (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
1140         (semantic-lex-push-token
1141          (semantic-lex-token
1142           'open-paren (match-beginning 0) (match-end 0))))
1143     (semantic-lex-push-token
1144      (semantic-lex-token
1145       'semantic-list (match-beginning 0)
1146       (save-excursion
1147         (semantic-lex-unterminated-syntax-protection 'semantic-list
1148           (forward-list 1)
1149           (point))
1150         )))
1151     ))
1152
1153 (define-lex-simple-regex-analyzer semantic-lex-open-paren
1154   "Detect and create an open parenthisis token."
1155   "\\s(" 'open-paren 0  (setq semantic-lex-current-depth (1+ semantic-lex-current-depth)))
1156
1157 (define-lex-simple-regex-analyzer semantic-lex-close-paren
1158   "Detect and create a close paren token."
1159   "\\s)" 'close-paren 0 (setq semantic-lex-current-depth (1- semantic-lex-current-depth)))
1160
1161 (define-lex-regex-analyzer semantic-lex-string
1162   "Detect and create a string token."
1163   "\\s\""
1164   ;; Zing to the end of this string.
1165   (semantic-lex-push-token
1166    (semantic-lex-token
1167     'string (point)
1168     (save-excursion
1169       (semantic-lex-unterminated-syntax-protection 'string
1170         (forward-sexp 1)
1171         (point))
1172       ))))
1173
1174 (define-lex-regex-analyzer semantic-lex-comments
1175   "Detect and create a comment token."
1176   semantic-lex-comment-regex
1177   (save-excursion
1178     (forward-comment 1)
1179     ;; Generate newline token if enabled
1180     (if (bolp) (backward-char 1))
1181     (setq semantic-lex-end-point (point))
1182     ;; Language wants comments or want them as whitespaces,
1183     ;; link them together.
1184     (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) 'comment)
1185         (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
1186                 semantic-lex-end-point)
1187       (semantic-lex-push-token
1188        (semantic-lex-token
1189         'comment (match-beginning 0) semantic-lex-end-point)))))
1190
1191 (define-lex-regex-analyzer semantic-lex-comments-as-whitespace
1192   "Detect comments and create a whitespace token."
1193   semantic-lex-comment-regex
1194   (save-excursion
1195     (forward-comment 1)
1196     ;; Generate newline token if enabled
1197     (if (bolp) (backward-char 1))
1198     (setq semantic-lex-end-point (point))
1199     ;; Language wants comments or want them as whitespaces,
1200     ;; link them together.
1201     (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) 'whitespace)
1202         (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
1203                 semantic-lex-end-point)
1204       (semantic-lex-push-token
1205        (semantic-lex-token
1206         'whitespace (match-beginning 0) semantic-lex-end-point)))))
1207
1208 (define-lex-regex-analyzer semantic-lex-ignore-comments
1209   "Detect and create a comment token."
1210   semantic-lex-comment-regex
1211   (let ((comment-start-point (point)))
1212     (forward-comment 1)
1213     (if (eq (point) comment-start-point)
1214         ;; In this case our start-skip string failed
1215         ;; to work properly.  Lets try and move over
1216         ;; whatever white space we matched to begin
1217         ;; with.
1218         (skip-syntax-forward "-.'"
1219                              (save-excursion
1220                                (end-of-line)
1221                                (point)))
1222       ;; We may need to back up so newlines or whitespace is generated.
1223       (if (bolp)
1224           (backward-char 1)))
1225     (if (eq (point) comment-start-point)
1226         (error "Strange comment syntax prevents lexical analysis"))
1227     (setq semantic-lex-end-point (point))))
1228 \f
1229 ;;; Comment lexer
1230 ;;
1231 (define-lex semantic-comment-lexer
1232   "A simple lexical analyzer that handles comments.
1233 This lexer will only return comment tokens.  It is the default lexer
1234 used by `semantic-find-doc-snarf-comment' to snarf up the comment at
1235 point."
1236   semantic-lex-ignore-whitespace
1237   semantic-lex-ignore-newline
1238   semantic-lex-comments
1239   semantic-lex-default-action)
1240
1241 ;;; Test Lexer
1242 ;;
1243 (define-lex semantic-simple-lexer
1244   "A simple lexical analyzer that handles simple buffers.
1245 This lexer ignores comments and whitespace, and will return
1246 syntax as specified by the syntax table."
1247   semantic-lex-ignore-whitespace
1248   semantic-lex-ignore-newline
1249   semantic-lex-number
1250   semantic-lex-symbol-or-keyword
1251   semantic-lex-charquote
1252   semantic-lex-paren-or-list
1253   semantic-lex-close-paren
1254   semantic-lex-string
1255   semantic-lex-ignore-comments
1256   semantic-lex-punctuation
1257   semantic-lex-default-action)
1258 \f
1259 ;;; Analyzers generated from grammar.
1260 ;;
1261 (defmacro define-lex-keyword-type-analyzer (name doc syntax)
1262   "Define a keyword type analyzer NAME with DOC string.
1263 SYNTAX is the regexp that matches a keyword syntactic expression."
1264   (let ((key (make-symbol "key")))
1265     `(define-lex-analyzer ,name
1266        ,doc
1267        (and (looking-at ,syntax)
1268             (let ((,key (semantic-lex-keyword-p (match-string 0))))
1269               (when ,key
1270                 (semantic-lex-push-token
1271                  (semantic-lex-token
1272                   ,key (match-beginning 0) (match-end 0)))))))
1273     ))
1274
1275 (defmacro define-lex-sexp-type-analyzer (name doc syntax token)
1276   "Define a sexp type analyzer NAME with DOC string.
1277 SYNTAX is the regexp that matches the beginning of the s-expression.
1278 TOKEN is the lexical token returned when SYNTAX matches."
1279   `(define-lex-regex-analyzer ,name
1280      ,doc
1281      ,syntax
1282      (semantic-lex-push-token
1283       (semantic-lex-token
1284        ,token (point)
1285        (save-excursion
1286          (semantic-lex-unterminated-syntax-protection ,token
1287            (forward-sexp 1)
1288            (point))))))
1289   )
1290
1291 (defmacro define-lex-regex-type-analyzer (name doc syntax matches default)
1292   "Define a regexp type analyzer NAME with DOC string.
1293 SYNTAX is the regexp that matches a syntactic expression.
1294 MATCHES is an alist of lexical elements used to refine the syntactic
1295 expression.
1296 DEFAULT is the default lexical token returned when no MATCHES."
1297   (if matches
1298       (let* ((val (make-symbol "val"))
1299              (lst (make-symbol "lst"))
1300              (elt (make-symbol "elt"))
1301              (pos (make-symbol "pos"))
1302              (end (make-symbol "end")))
1303         `(define-lex-analyzer ,name
1304            ,doc
1305            (and (looking-at ,syntax)
1306                 (let* ((,val (match-string 0))
1307                        (,pos (match-beginning 0))
1308                        (,end (match-end 0))
1309                        (,lst ,matches)
1310                        ,elt)
1311                   (while (and ,lst (not ,elt))
1312                     (if (string-match (cdar ,lst) ,val)
1313                         (setq ,elt (caar ,lst))
1314                       (setq ,lst (cdr ,lst))))
1315                   (semantic-lex-push-token
1316                    (semantic-lex-token (or ,elt ,default) ,pos ,end))))
1317            ))
1318     `(define-lex-simple-regex-analyzer ,name
1319        ,doc
1320        ,syntax ,default)
1321     ))
1322
1323 (defmacro define-lex-string-type-analyzer (name doc syntax matches default)
1324   "Define a string type analyzer NAME with DOC string.
1325 SYNTAX is the regexp that matches a syntactic expression.
1326 MATCHES is an alist of lexical elements used to refine the syntactic
1327 expression.
1328 DEFAULT is the default lexical token returned when no MATCHES."
1329   (if matches
1330       (let* ((val (make-symbol "val"))
1331              (lst (make-symbol "lst"))
1332              (elt (make-symbol "elt"))
1333              (pos (make-symbol "pos"))
1334              (end (make-symbol "end"))
1335              (len (make-symbol "len")))
1336         `(define-lex-analyzer ,name
1337            ,doc
1338            (and (looking-at ,syntax)
1339                 (let* ((,val (match-string 0))
1340                        (,pos (match-beginning 0))
1341                        (,end (match-end 0))
1342                        (,len (- ,end ,pos))
1343                        (,lst ,matches)
1344                        ,elt)
1345                ;; Starting with the longest one, search if a lexical
1346                ;; value match a token defined for this language.
1347                (while (and (> ,len 0) (not (setq ,elt (rassoc ,val ,lst))))
1348                  (setq ,len (1- ,len)
1349                        ,val (substring ,val 0 ,len)))
1350                (when ,elt ;; Adjust token end position.
1351                  (setq ,elt (car ,elt)
1352                        ,end (+ ,pos ,len)))
1353                (semantic-lex-push-token
1354                 (semantic-lex-token (or ,elt ,default) ,pos ,end))))
1355            ))
1356     `(define-lex-simple-regex-analyzer ,name
1357        ,doc
1358        ,syntax ,default)
1359     ))
1360
1361 (defmacro define-lex-block-type-analyzer (name doc syntax matches)
1362   "Define a block type analyzer NAME with DOC string.
1363
1364 SYNTAX is the regexp that matches block delimiters,  typically the
1365 open (`\\\\s(') and close (`\\\\s)') parenthesis syntax classes.
1366
1367 MATCHES is a pair (OPEN-SPECS . CLOSE-SPECS) that defines blocks.
1368
1369   OPEN-SPECS is a list of (OPEN-DELIM OPEN-TOKEN BLOCK-TOKEN) elements
1370   where:
1371
1372     OPEN-DELIM is a string: the block open delimiter character.
1373
1374     OPEN-TOKEN is the lexical token class associated to the OPEN-DELIM
1375     delimiter.
1376
1377     BLOCK-TOKEN is the lexical token class associated to the block
1378     that starts at the OPEN-DELIM delimiter.
1379
1380   CLOSE-SPECS is a list of (CLOSE-DELIM CLOSE-TOKEN) elements where:
1381
1382     CLOSE-DELIM is a string: the block end delimiter character.
1383
1384     CLOSE-TOKEN is the lexical token class associated to the
1385     CLOSE-DELIM delimiter.
1386
1387 Each element in OPEN-SPECS must have a corresponding element in
1388 CLOSE-SPECS.
1389
1390 The lexer will return a BLOCK-TOKEN token when the value of
1391 `semantic-lex-current-depth' is greater than or equal to the maximum
1392 depth of parenthesis tracking (see also the function `semantic-lex').
1393 Otherwise it will return OPEN-TOKEN and CLOSE-TOKEN tokens.
1394
1395 TO DO: Put the following in the developer's guide and just put a
1396 reference here.
1397
1398 In the grammar:
1399
1400 The value of a block token must be a string that contains a readable
1401 sexp of the form:
1402
1403   \"(OPEN-TOKEN CLOSE-TOKEN)\"
1404
1405 OPEN-TOKEN and CLOSE-TOKEN represent the block delimiters, and must be
1406 lexical tokens of respectively `open-paren' and `close-paren' types.
1407 Their value is the corresponding delimiter character as a string.
1408
1409 Here is a small example to analyze a parenthesis block:
1410
1411   %token <block>       PAREN_BLOCK \"(LPAREN RPAREN)\"
1412   %token <open-paren>  LPAREN      \"(\"
1413   %token <close-paren> RPAREN      \")\"
1414
1415 When the lexer encounters the open-paren delimiter \"(\":
1416
1417  - If the maximum depth of parenthesis tracking is not reached (that
1418    is, current depth < max depth), it returns a (LPAREN start .  end)
1419    token, then continue analysis inside the block.  Later, when the
1420    corresponding close-paren delimiter \")\" will be encountered, it
1421    will return a (RPAREN start . end) token.
1422
1423  - If the maximum depth of parenthesis tracking is reached (current
1424    depth >= max depth), it returns the whole parenthesis block as
1425    a (PAREN_BLOCK start . end) token."
1426   (let* ((val (make-symbol "val"))
1427          (lst (make-symbol "lst"))
1428          (elt (make-symbol "elt")))
1429     `(define-lex-analyzer ,name
1430        ,doc
1431        (and
1432         (looking-at ,syntax) ;; "\\(\\s(\\|\\s)\\)"
1433         (let ((,val (match-string 0))
1434               (,lst ,matches)
1435               ,elt)
1436           (cond
1437            ((setq ,elt (assoc ,val (car ,lst)))
1438             (if (or (not semantic-lex-maximum-depth)
1439                     (< semantic-lex-current-depth semantic-lex-maximum-depth))
1440                 (progn
1441                   (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
1442                   (semantic-lex-push-token
1443                    (semantic-lex-token
1444                     (nth 1 ,elt)
1445                     (match-beginning 0) (match-end 0))))
1446               (semantic-lex-push-token
1447                (semantic-lex-token
1448                 (nth 2 ,elt)
1449                 (match-beginning 0)
1450                 (save-excursion
1451                   (semantic-lex-unterminated-syntax-protection (nth 2 ,elt)
1452                     (forward-list 1)
1453                     (point)))))))
1454            ((setq ,elt (assoc ,val (cdr ,lst)))
1455             (setq semantic-lex-current-depth (1- semantic-lex-current-depth))
1456             (semantic-lex-push-token
1457              (semantic-lex-token
1458               (nth 1 ,elt)
1459               (match-beginning 0) (match-end 0))))
1460            ))))
1461     ))
1462 \f
1463 ;;; Lexical Safety
1464 ;;
1465 ;; The semantic lexers, unlike other lexers, can throw errors on
1466 ;; unbalanced syntax.  Since editing is all about changeging test
1467 ;; we need to provide a convenient way to protect against syntactic
1468 ;; inequalities.
1469
1470 (defmacro semantic-lex-catch-errors (symbol &rest forms)
1471   "Using SYMBOL, execute FORMS catching lexical errors.
1472 If FORMS results in a call to the parser that throws a lexical error,
1473 the error will be caught here without the buffer's cache being thrown
1474 out of date.
1475 If there is an error, the syntax that failed is returned.
1476 If there is no error, then the last value of FORMS is returned."
1477   (let ((ret (make-symbol "ret"))
1478         (syntax (make-symbol "syntax"))
1479         (start (make-symbol "start"))
1480         (end (make-symbol "end")))
1481     `(let* ((semantic-lex-unterminated-syntax-end-function
1482              (lambda (,syntax ,start ,end)
1483                (throw ',symbol ,syntax)))
1484             ;; Delete the below when semantic-flex is fully retired.
1485             (semantic-flex-unterminated-syntax-end-function
1486              semantic-lex-unterminated-syntax-end-function)
1487             (,ret (catch ',symbol
1488                     (save-excursion
1489                       ,@forms
1490                       nil))))
1491        ;; Great Sadness.  Assume that FORMS execute within the
1492        ;; confines of the current buffer only!  Mark this thing
1493        ;; unparseable iff the special symbol was thrown.  This
1494        ;; will prevent future calls from parsing, but will allow
1495        ;; then to still return the cache.
1496        (when ,ret
1497          (message "Buffer not currently parsable (%S)." ,ret)
1498          (semantic-parse-tree-unparseable))
1499        ,ret)))
1500 (put 'semantic-lex-catch-errors 'lisp-indent-function 1)
1501
1502 \f
1503 ;;; Interfacing with edebug
1504 ;;
1505 (add-hook
1506  'edebug-setup-hook
1507  #'(lambda ()
1508
1509      (def-edebug-spec define-lex
1510        (&define name stringp (&rest symbolp))
1511        )
1512      (def-edebug-spec define-lex-analyzer
1513        (&define name stringp form def-body)
1514        )
1515      (def-edebug-spec define-lex-regex-analyzer
1516        (&define name stringp form def-body)
1517        )
1518      (def-edebug-spec define-lex-simple-regex-analyzer
1519        (&define name stringp form symbolp [ &optional form ] def-body)
1520        )
1521      (def-edebug-spec define-lex-block-analyzer
1522        (&define name stringp form (&rest form))
1523        )
1524      (def-edebug-spec semantic-lex-catch-errors
1525        (symbolp def-body)
1526        )
1527
1528      ))
1529 \f
1530 ;;; Compatibility with Semantic 1.x lexical analysis
1531 ;;
1532
1533 (semantic-alias-obsolete 'semantic-flex-start 'semantic-lex-token-start)
1534 (semantic-alias-obsolete 'semantic-flex-end 'semantic-lex-token-end)
1535 (semantic-alias-obsolete 'semantic-flex-text 'semantic-lex-token-text)
1536 (semantic-alias-obsolete 'semantic-flex-make-keyword-table 'semantic-lex-make-keyword-table)
1537 (semantic-alias-obsolete 'semantic-flex-keyword-p 'semantic-lex-keyword-p)
1538 (semantic-alias-obsolete 'semantic-flex-keyword-put 'semantic-lex-keyword-put)
1539 (semantic-alias-obsolete 'semantic-flex-keyword-get 'semantic-lex-keyword-get)
1540 (semantic-alias-obsolete 'semantic-flex-map-keywords 'semantic-lex-map-keywords)
1541 (semantic-alias-obsolete 'semantic-flex-keywords 'semantic-lex-keywords)
1542 (semantic-alias-obsolete 'semantic-flex-buffer 'semantic-lex-buffer)
1543 (semantic-alias-obsolete 'semantic-flex-list   'semantic-lex-list)
1544
1545 ;; This simple scanner uses the syntax table to generate a stream of
1546 ;; simple tokens of the form:
1547 ;;
1548 ;;  (SYMBOL START . END)
1549 ;;
1550 ;; Where symbol is the type of thing it is.  START and END mark that
1551 ;; objects boundary.
1552
1553 (defvar semantic-flex-tokens semantic-lex-tokens
1554   "An alist of of semantic token types.
1555 See variable `semantic-lex-tokens'.")
1556
1557 (defvar semantic-flex-unterminated-syntax-end-function
1558   (lambda (syntax syntax-start flex-end) flex-end)
1559   "Function called when unterminated syntax is encountered.
1560 This should be set to one function.  That function should take three
1561 parameters.  The SYNTAX, or type of syntax which is unterminated.
1562 SYNTAX-START where the broken syntax begins.
1563 FLEX-END is where the lexical analysis was asked to end.
1564 This function can be used for languages that can intelligently fix up
1565 broken syntax, or the exit lexical analysis via `throw' or `signal'
1566 when finding unterminated syntax.")
1567
1568 (defvar semantic-flex-extensions nil
1569   "Buffer local extensions to the lexical analyzer.
1570 This should contain an alist with a key of a regex and a data element of
1571 a function.  The function should both move point, and return a lexical
1572 token of the form:
1573   ( TYPE START .  END)
1574 nil is also a valid return value.
1575 TYPE can be any type of symbol, as long as it doesn't occur as a
1576 nonterminal in the language definition.")
1577 (make-variable-buffer-local 'semantic-flex-extensions)
1578
1579 (defvar semantic-flex-syntax-modifications nil
1580   "Changes to the syntax table for this buffer.
1581 These changes are active only while the buffer is being flexed.
1582 This is a list where each element has the form:
1583   (CHAR CLASS)
1584 CHAR is the char passed to `modify-syntax-entry',
1585 and CLASS is the string also passed to `modify-syntax-entry' to define
1586 what syntax class CHAR has.")
1587 (make-variable-buffer-local 'semantic-flex-syntax-modifications)
1588
1589 (defvar semantic-ignore-comments t
1590   "Default comment handling.
1591 t means to strip comments when flexing.  Nil means to keep comments
1592 as part of the token stream.")
1593 (make-variable-buffer-local 'semantic-ignore-comments)
1594
1595 (defvar semantic-flex-enable-newlines nil
1596   "When flexing, report 'newlines as syntactic elements.
1597 Useful for languages where the newline is a special case terminator.
1598 Only set this on a per mode basis, not globally.")
1599 (make-variable-buffer-local 'semantic-flex-enable-newlines)
1600
1601 (defvar semantic-flex-enable-whitespace nil
1602   "When flexing, report 'whitespace as syntactic elements.
1603 Useful for languages where the syntax is whitespace dependent.
1604 Only set this on a per mode basis, not globally.")
1605 (make-variable-buffer-local 'semantic-flex-enable-whitespace)
1606
1607 (defvar semantic-flex-enable-bol nil
1608   "When flexing, report beginning of lines as syntactic elements.
1609 Useful for languages like python which are indentation sensitive.
1610 Only set this on a per mode basis, not globally.")
1611 (make-variable-buffer-local 'semantic-flex-enable-bol)
1612
1613 (defvar semantic-number-expression semantic-lex-number-expression
1614   "See variable `semantic-lex-number-expression'.")
1615 (make-variable-buffer-local 'semantic-number-expression)
1616
1617 (defvar semantic-flex-depth 0
1618   "Default flexing depth.
1619 This specifies how many lists to create tokens in.")
1620 (make-variable-buffer-local 'semantic-flex-depth)
1621
1622 (defun semantic-flex (start end &optional depth length)
1623   "Using the syntax table, do something roughly equivalent to flex.
1624 Semantically check between START and END.  Optional argument DEPTH
1625 indicates at what level to scan over entire lists.
1626 The return value is a token stream.  Each element is a list, such of
1627 the form (symbol start-expression .  end-expression) where SYMBOL
1628 denotes the token type.
1629 See `semantic-flex-tokens' variable for details on token types.
1630 END does not mark the end of the text scanned, only the end of the
1631 beginning of text scanned.  Thus, if a string extends past END, the
1632 end of the return token will be larger than END.  To truly restrict
1633 scanning, use `narrow-to-region'.
1634 The last argument, LENGTH specifies that `semantic-flex' should only
1635 return LENGTH tokens."
1636   (message "`semantic-flex' is an obsolete function.  Use `define-lex' to create lexers.")
1637   (if (not semantic-flex-keywords-obarray)
1638       (setq semantic-flex-keywords-obarray [ nil ]))
1639   (let ((ts nil)
1640         (pos (point))
1641         (ep nil)
1642         (curdepth 0)
1643         (cs (if comment-start-skip
1644                 (concat "\\(\\s<\\|" comment-start-skip "\\)")
1645               (concat "\\(\\s<\\)")))
1646         (newsyntax (copy-syntax-table (syntax-table)))
1647         (mods semantic-flex-syntax-modifications)
1648         ;; Use the default depth if it is not specified.
1649         (depth (or depth semantic-flex-depth)))
1650     ;; Update the syntax table
1651     (while mods
1652       (modify-syntax-entry (car (car mods)) (car (cdr (car mods))) newsyntax)
1653       (setq mods (cdr mods)))
1654     (with-syntax-table newsyntax
1655       (goto-char start)
1656       (while (and (< (point) end) (or (not length) (<= (length ts) length)))
1657         (cond
1658          ;; catch beginning of lines when needed.
1659          ;; Must be done before catching any other tokens!
1660          ((and semantic-flex-enable-bol
1661                (bolp)
1662                ;; Just insert a (bol N . N) token in the token stream,
1663                ;; without moving the point.  N is the point at the
1664                ;; beginning of line.
1665                (setq ts (cons (cons 'bol (cons (point) (point))) ts))
1666                nil)) ;; CONTINUE
1667          ;; special extensions, includes whitespace, nl, etc.
1668          ((and semantic-flex-extensions
1669                (let ((fe semantic-flex-extensions)
1670                      (r nil))
1671                  (while fe
1672                    (if (looking-at (car (car fe)))
1673                        (setq ts (cons (funcall (cdr (car fe))) ts)
1674                              r t
1675                              fe nil
1676                              ep (point)))
1677                    (setq fe (cdr fe)))
1678                  (if (and r (not (car ts))) (setq ts (cdr ts)))
1679                  r)))
1680          ;; catch newlines when needed
1681          ((looking-at "\\s-*\\(\n\\|\\s>\\)")
1682           (if semantic-flex-enable-newlines
1683               (setq ep (match-end 1)
1684                     ts (cons (cons 'newline
1685                                    (cons (match-beginning 1) ep))
1686                              ts))))
1687          ;; catch whitespace when needed
1688          ((looking-at "\\s-+")
1689           (if semantic-flex-enable-whitespace
1690               ;; Language wants whitespaces, link them together.
1691               (if (eq (car (car ts)) 'whitespace)
1692                   (setcdr (cdr (car ts)) (match-end 0))
1693                 (setq ts (cons (cons 'whitespace
1694                                      (cons (match-beginning 0)
1695                                            (match-end 0)))
1696                                ts)))))
1697          ;; numbers
1698          ((and semantic-number-expression
1699                (looking-at semantic-number-expression))
1700           (setq ts (cons (cons 'number
1701                                (cons (match-beginning 0)
1702                                      (match-end 0)))
1703                          ts)))
1704          ;; symbols
1705          ((looking-at "\\(\\sw\\|\\s_\\)+")
1706           (setq ts (cons (cons
1707                           ;; Get info on if this is a keyword or not
1708                           (or (semantic-flex-keyword-p (match-string 0))
1709                               'symbol)
1710                           (cons (match-beginning 0) (match-end 0)))
1711                          ts)))
1712          ;; Character quoting characters (ie, \n as newline)
1713          ((looking-at "\\s\\+")
1714           (setq ts (cons (cons 'charquote
1715                                (cons (match-beginning 0) (match-end 0)))
1716                          ts)))
1717          ;; Open parens, or semantic-lists.
1718          ((looking-at "\\s(")
1719           (if (or (not depth) (< curdepth depth))
1720               (progn
1721                 (setq curdepth (1+ curdepth))
1722                 (setq ts (cons (cons 'open-paren
1723                                      (cons (match-beginning 0) (match-end 0)))
1724                                ts)))
1725             (setq ts (cons
1726                       (cons 'semantic-list
1727                             (cons (match-beginning 0)
1728                                   (save-excursion
1729                                     (condition-case nil
1730                                         (forward-list 1)
1731                                       ;; This case makes flex robust
1732                                       ;; to broken lists.
1733                                       (error
1734                                        (goto-char
1735                                         (funcall
1736                                          semantic-flex-unterminated-syntax-end-function
1737                                          'semantic-list
1738                                          start end))))
1739                                     (setq ep (point)))))
1740                       ts))))
1741          ;; Close parens
1742          ((looking-at "\\s)")
1743           (setq ts (cons (cons 'close-paren
1744                                (cons (match-beginning 0) (match-end 0)))
1745                          ts))
1746           (setq curdepth (1- curdepth)))
1747          ;; String initiators
1748          ((looking-at "\\s\"")
1749           ;; Zing to the end of this string.
1750           (setq ts (cons (cons 'string
1751                                (cons (match-beginning 0)
1752                                      (save-excursion
1753                                        (condition-case nil
1754                                            (forward-sexp 1)
1755                                          ;; This case makes flex
1756                                          ;; robust to broken strings.
1757                                          (error
1758                                           (goto-char
1759                                            (funcall
1760                                             semantic-flex-unterminated-syntax-end-function
1761                                             'string
1762                                             start end))))
1763                                        (setq ep (point)))))
1764                          ts)))
1765          ;; comments
1766          ((looking-at cs)
1767           (if (and semantic-ignore-comments
1768                    (not semantic-flex-enable-whitespace))
1769               ;; If the language doesn't deal with comments nor
1770               ;; whitespaces, ignore them here.
1771               (let ((comment-start-point (point)))
1772                 (forward-comment 1)
1773                 (if (eq (point) comment-start-point)
1774                     ;; In this case our start-skip string failed
1775                     ;; to work properly.  Lets try and move over
1776                     ;; whatever white space we matched to begin
1777                     ;; with.
1778                     (skip-syntax-forward "-.'"
1779                                          (save-excursion
1780                                            (end-of-line)
1781                                            (point)))
1782                   ;;(forward-comment 1)
1783                   ;; Generate newline token if enabled
1784                   (if (and semantic-flex-enable-newlines
1785                            (bolp))
1786                       (backward-char 1)))
1787                 (if (eq (point) comment-start-point)
1788                     (error "Strange comment syntax prevents lexical analysis"))
1789                 (setq ep (point)))
1790             (let ((tk (if semantic-ignore-comments 'whitespace 'comment)))
1791               (save-excursion
1792                 (forward-comment 1)
1793                 ;; Generate newline token if enabled
1794                 (if (and semantic-flex-enable-newlines
1795                          (bolp))
1796                     (backward-char 1))
1797                 (setq ep (point)))
1798               ;; Language wants comments or want them as whitespaces,
1799               ;; link them together.
1800               (if (eq (car (car ts)) tk)
1801                   (setcdr (cdr (car ts)) ep)
1802                 (setq ts (cons (cons tk (cons (match-beginning 0) ep))
1803                                ts))))))
1804          ;; punctuation
1805          ((looking-at "\\(\\s.\\|\\s$\\|\\s'\\)")
1806           (setq ts (cons (cons 'punctuation
1807                                (cons (match-beginning 0) (match-end 0)))
1808                          ts)))
1809          ;; unknown token
1810          (t
1811           (error "What is that?")))
1812         (goto-char (or ep (match-end 0)))
1813         (setq ep nil)))
1814     ;; maybe catch the last beginning of line when needed
1815     (and semantic-flex-enable-bol
1816          (= (point) end)
1817          (bolp)
1818          (setq ts (cons (cons 'bol (cons (point) (point))) ts)))
1819     (goto-char pos)
1820     ;;(message "Flexing muscles...done")
1821     (nreverse ts)))
1822
1823 (provide 'semantic-lex)
1824
1825 ;;; semantic-lex.el ends here