diff options
Diffstat (limited to 'lisp/modules/syntax.lsp')
| -rw-r--r-- | lisp/modules/syntax.lsp | 1452 |
1 files changed, 1452 insertions, 0 deletions
diff --git a/lisp/modules/syntax.lsp b/lisp/modules/syntax.lsp new file mode 100644 index 0000000..c297235 --- /dev/null +++ b/lisp/modules/syntax.lsp @@ -0,0 +1,1452 @@ +;; +;; Copyright (c) 2002 by The XFree86 Project, Inc. +;; +;; Permission is hereby granted, free of charge, to any person obtaining a +;; copy of this software and associated documentation files (the "Software"), +;; to deal in the Software without restriction, including without limitation +;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;; and/or sell copies of the Software, and to permit persons to whom the +;; Software is furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in +;; all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;; THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF +;; OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. +;; +;; Except as contained in this notice, the name of the XFree86 Project shall +;; not be used in advertising or otherwise to promote the sale, use or other +;; dealings in this Software without prior written authorization from the +;; XFree86 Project. +;; +;; Author: Paulo César Pereira de Andrade +;; +;; +;; $XFree86: xc/programs/xedit/lisp/modules/syntax.lsp,v 1.11 2003/01/16 03:50:46 paulo Exp $ +;; + +(provide "syntax") +(require "xedit") +(in-package "XEDIT") + +(defvar *syntax-symbols* '( + syntax-highlight defsyntax defsynprop synprop-p syntax-p + syntable syntoken synaugment + *prop-default* *prop-keyword* *prop-number* *prop-string* + *prop-constant* *prop-comment* *prop-preprocessor* + *prop-punctuation* *prop-error* *prop-annotation* +)) +(export *syntax-symbols*) +(in-package "USER") +(dolist (symbol xedit::*syntax-symbols*) + (import symbol) +) +(in-package "XEDIT") +(makunbound '*syntax-symbols*) + +#| +TODO: +o Add a command to match without increment the offset in the input, this + may be useful for example in a case like: + some-table + match "<" + switch -1 + match "<" <- the table already eated this, so it won't be matched. + This must be carefully checked at compile time, such instruction should + be in a token that returns or starts a new one, and even then, may need + runtime check to make sure it won't enter an infinite loop. +o Allow combining properties, this is supported in Xaw, and could allow some + very interesting effects for complex documents. +o Maybe have an separated function/loop for tables that don't have tokens + that start/switch to another table, and/or have the contained attribute set. + This could allow running considerably faster. +o Do a better handling of interactive edition for tokens that start and end + with the same pattern, as an example strings, if the user types '"', it + will parse up to the end of the file, "inverting" all strings. +o Allow generic code to be run once a match is found, such code could handle + some defined variables and take decisions based on the parser state. This + should be detected at compile time, to maybe run a different parser for + such syntax tables, due to the extra time building the environment to + call the code. This would be useful to "really" parse documents with + complex syntax, for example, a man page source file. +o Add command to change current default property without initializing a new + state. +o Fix problems matching EOL. Since EOL is an empty string match, if there + is a rule to match only EOL, but some other rule matches up to the end + of the input, the match to EOL will not be recognized. Currently the only + way to handle this is to have a nested table that always returns once a + match is found, so that it will restart the match loop code even if the + input is at EOL. + One possible solution would be to add the ending newline to the input, + and then instead of matching "$", should match "\\n". +o XXX Usage of the variable newline-property must be reviewed in function + syntax-highlight, if the text property has a background attribute, + visual effect will look "strange", will paint a square with the + background attribute at the end of every line in the matched text. +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Some annotations to later write documentation for the module... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| + The current interface logic should be easy to understand for people +that have written lex scanners before. It has some extended semantics, +that could be translated to stacked BEGIN() statements in lex, but +currently does not have rules for matches in the format RE/TRAILING, as +well as code attached to rules (the biggest difference) and/or things +like REJECT and unput(). Also, at least currently, it is *really* quite +slower than lex. + + MATCHING RULES + -------------- + When two tokens are matched at the same input offset, the longest +token is used, if the length is the same, the first definition is +used. For example: + token1 => int + token2 => [A-Za-z]+ + input => integer + Token1 matches "int" and token2 matches "integer", but since token2 is +longer, it is used. But in the case: + token1 => int + token2 => [A-Za-z]+ + input => int + Both, token1 and token2 match "int", since token1 is defined first, it +is used. +|# + + +;; Initialize some default properties that may be shared in syntax +;; highlight definitions. Use of these default properties is encouraged, +;; so that "tokens" will be shown identically when editing program +;; sources in different programming languages. +(defsynprop *prop-default* + "default" + :font "*courier-medium-r*12*" + :foreground "black") + +(defsynprop *prop-keyword* + "keyword" + :font "*courier-bold-r*12*" + :foreground "gray12") + +(defsynprop *prop-number* + "number" + :font "*courier-bold-r*12*" + :foreground "OrangeRed3") + +(defsynprop *prop-string* + "string" + :font "*lucidatypewriter-medium-r*12*" + :foreground "RoyalBlue2") + +(defsynprop *prop-constant* + "constant" + :font "*lucidatypewriter-medium-r*12*" + :foreground "VioletRed3") + +(defsynprop *prop-comment* + "comment" + :font "*courier-medium-o*12*" + :foreground "SlateBlue3") + +(defsynprop *prop-preprocessor* + "preprocessor" + :font "*courier-medium-r*12*" + :foreground "green4") + +(defsynprop *prop-punctuation* + "punctuation" + :font "*courier-bold-r*12*" + :foreground "gray12") + +;; Control characters, not always errors... +(defsynprop *prop-control* + "control" + :font "*courier-bold-r*12*" + :foreground "yellow2" + :background "red3") + +(defsynprop *prop-error* + "error" + :font "*new century schoolbook-bold*24*" + :foreground "yellow" + :background "red") + +(defsynprop *prop-annotation* + "annotation" + :font "*courier-medium-r*12*" + :foreground "black" + :background "PaleGreen") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The "main" definition of the syntax highlight coding interface. +;; Creates a "special" variable with the given name, associating to +;; it an already compiled syntax table. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro defsyntax (variable label property indent options &rest lists) + `(if (boundp ',variable) + ,variable + (progn + (proclaim '(special ,variable)) + (setq ,variable + (compile-syntax-table + (string ',variable) ,options + (syntable ,label ,property ,indent ,@lists) + ) + ) + ) + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Just a wrapper to create a hash-table and bound it to a symbol. +;; Example of call: +;; (defsynoptions *my-syntax-options* +;; (:indent . 8) +;; (:indent-option-1 . 1) +;; (:indent-option-2 . 2) +;; ) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro defsynoptions (variable &rest options) + `(if (boundp ',variable) + ,variable + (progn + (proclaim '(special ,variable)) + (setq ,variable (make-hash-table :initial-contents ',options)) + ) + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; These definitions should be "private". +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defstruct syntoken + regex ;; A compiled regexp. + property ;; NIL for default, or a synprop structure. + contained ;; Only used when switch/begin is not NIL. Values: + ;; NIL -> just switch to or begin new + ;; syntax table. + ;; (not NIL) -> apply syntoken property + ;; (or default one) to matched + ;; text *after* switching to or + ;; beginning a new syntax table. + switch ;; Values for switch are: + ;; NIL -> do nothing + ;; A keyword -> switch to the syntax table + ;; identified by the keyword. + ;; A negative integer -> Pop the stack + ;; -<swich-value> times. + ;; A common value is -1, + ;; to switch to the previous + ;; state, but some times + ;; it is desired to return + ;; two or more times in + ;; in the stack. + ;; NOTE: This is actually a jump, the stack is + ;; popped until the named syntax table is found, + ;; if the stack becomes empty, a new state is + ;; implicitly created. + begin ;; NIL or a keyword (like switch), but instead of + ;; popping the stack, it pushes the current syntax + ;; table to the stack and sets a new current one. +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Just a wrapper to make-syntoken. +;; TODO: Add support for structure constructors. +;; XXX: Note that the NOSUB only works with the xedit regex, it +;; will still return the match offsets, but will ignore subexpressions, +;; that is, parenthesis are used only for grouping. +;; TODO: Create a new version of the re-exec call that returns +;; offsets in the format (<from> . <to>) and not +;; ((<from0> . <to0>) ... (<fromN> . <toN>)). Only the global result +;; is expected/used, so there is no reason to allocate more than one +;; cons cell per call. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun syntoken (pattern + &key icase nospec property contained switch begin (nosub t) + &aux + (regex + (re-comp pattern :icase icase :nospec nospec :nosub nosub) + ) + check) + + ;; Don't allow a regex that matches the null string enter the + ;; syntax table list. + (if (consp (setq check (re-exec regex "" :noteol t :notbol t))) +#+xedit (error "SYNTOKEN: regex matches empty string ~S" regex) +#-xedit () + ) + + (make-syntoken + :regex regex + :property property + :contained contained + :switch switch + :begin begin + ) +) + + +;; This structure is defined only to do some type checking, it just +;; holds a list of keywords. +(defstruct synaugment + labels ;; List of keywords labeling syntax tables. +) + +(defstruct syntable + label ;; A keyword naming this syntax table. + property ;; NIL or a default synprop structure. + indent ;; Indentation function for the syntax table. + tokens ;; A list of syntoken structures. + tables ;; A list of syntable structures. + augments ;; A list of synaugment structures, used only + ;; at "compile time", so that a table can be + ;; used before it's definition. + bol ;; One of the tokens match the empty string at + ;; the start of a line (loop optimization hint). + ;; Field filled at "link" time. + eol ;; Same comments as bol, but in this case, for + ;; the empty string at the end of a line. +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Just call make-syntable, but sorts the elements by type, allowing +;; a cleaner code when defining the syntax highlight rules. +;; XXX Same comments as for syntoken about the use of a constructor for +;; structures. TODO: when/if clos is implemented in the interpreter. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun syntable (label default-property indent &rest definitions) + + ;; Check for possible errors in the arguments. + (unless (keywordp label) + (error "SYNTABLE: ~A is not a keyword" label) + ) + (unless + (or + (null default-property) + (synprop-p default-property) + ) + (error "SYNTABLE: ~A is an invalid text property" + default-property + ) + ) + + ;; Don't allow unknown data in the definition list. + ;; XXX typecase should be added to the interpreter, and since + ;; the code is traversing the entire list, it could build + ;; now the arguments to make-syntable. + (dolist (item definitions) + (unless + (or + + ;; Allow NIL in the definition list, so that one + ;; can put conditionals in the syntax definition, + ;; and if the conditional is false, fill the slot + ;; with a NIL value. + (atom item) + (syntoken-p item) + (syntable-p item) + (synaugment-p item) + ) + (error "SYNTABLE: invalid syntax table argument ~A" item) + ) + ) + + ;; Build the syntax table. + (make-syntable + :label label + :property default-property + :indent indent + :tokens (remove-if-not #'syntoken-p definitions) + :tables (remove-if-not #'syntable-p definitions) + :augments (remove-if-not #'synaugment-p definitions) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Just to do a "preliminary" error checking, every element must be a +;; a keyword, and also check for reserved names. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun synaugment (&rest keywords) + (dolist (keyword keywords) + (unless (keywordp keyword) + (error "SYNAUGMENT: bad syntax table label ~A" keyword) + ) + ) + (make-synaugment :labels keywords) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Recursive compile utility function. +;; Returns a cons in the format: +;; car => List of all syntoken structures +;; (including child tables). +;; cdr => List of all child syntable structures. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun list-syntable-elements (table &aux result sub-result) + (setq + result + (cons + (syntable-tokens table) + (syntable-tables table)) + ) + + ;; For every child syntax table. + (dolist (child (syntable-tables table)) + + ;; Recursively call list-syntable-elements. + (setq sub-result (list-syntable-elements child)) + + (rplaca result (append (car result) (car sub-result))) + (rplacd result (append (cdr result) (cdr sub-result))) + ) + + ;; Return the pair of nested tokens and tables. + result +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Append tokens of the augment list to the tokens of the specified +;; syntax table. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-syntax-augment-list (table table-list + &aux labels augment tokens) + + ;; Create a list of all augment tables. + (dolist (augment (syntable-augments table)) + (setq labels (append labels (synaugment-labels augment))) + ) + + ;; Remove duplicates and references to "itself", + ;; without warnings? + (setq + labels + (remove + (syntable-label table) + (remove-duplicates labels :from-end t) + ) + ) + + ;; Check if the specified syntax tables exists! + (dolist (label labels) + (unless + (setq + augment + (car (member label table-list :key #'syntable-label)) + ) + (error "COMPILE-SYNTAX-AUGMENT-LIST: Cannot augment ~A in ~A" + label + (syntable-label table) + ) + ) + + ;; Increase list of tokens. + (setq tokens (append tokens (syntable-tokens augment))) + ) + + ;; Store the tokens in the augment list. They will be added + ;; to the syntax table in the second pass. + (setf (syntable-augments table) tokens) + + ;; Recurse on every child table. + (dolist (child (syntable-tables table)) + (compile-syntax-augment-list child table-list) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Just add the augmented tokens to the token list, recursing on +;; every child syntax table. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun link-syntax-augment-table (table) + (setf + (syntable-tokens table) + ;; When augmenting a table, duplicated tokens or different tokens + ;; that use the same regex pattern should be common. + (remove-duplicates + (nconc (syntable-tokens table) (syntable-augments table)) + :key #'syntoken-regex + :test #'equal + :from-end t + ) + + ;; Don't need to keep this list anymore. + (syntable-augments table) + () + ) + + ;; Check if one of the tokens match the empty string at the + ;; start or end of a text line. XXX The fields bol and eol + ;; are expected to be initialized to NIL. + (dolist (token (syntable-tokens table)) + (when (consp (re-exec (syntoken-regex token) "" :noteol t)) + (setf (syntable-bol table) t) + (return) + ) + ) + (dolist (token (syntable-tokens table)) + (when (consp (re-exec (syntoken-regex token) "" :notbol t)) + (setf (syntable-eol table) t) + (return) + ) + ) + + (dolist (child (syntable-tables table)) + (link-syntax-augment-table child) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; "Compile" the main structure of the syntax highlight code. +;; Variables "switches" and "begins" are used only for error checking. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-syntax-table (name options main-table &aux syntax elements + switches begins tables properties) + (unless (stringp name) + (error "COMPILE-SYNTAX-TABLE: ~A is not a string" name) + ) + + (setq + elements + (list-syntable-elements main-table) + + switches + (remove-if + #'null + (car elements) + :key #'syntoken-switch + ) + + begins + (remove-if-not + #'keywordp + (car elements) + :key #'syntoken-begin + ) + + ;; The "main-table" isn't in the list, because + ;; list-syntable-elements includes only the child tables; + ;; this is done to avoid the need of removing duplicates here. + tables + (cons main-table (cdr elements)) + ) + + ;; Check for typos in the keywords, or for not defined syntax tables. + (dolist (item (mapcar #'syntoken-switch switches)) + (unless + (or + (and + (integerp item) + (minusp item) + ) + (member item tables :key #'syntable-label) + ) + (error "COMPILE-SYNTAX-TABLE: SWITCH ~A cannot be matched" + item + ) + ) + ) + (dolist (item (mapcar #'syntoken-begin begins)) + (unless (member item tables :key #'syntable-label) + (error "COMPILE-SYNTAX-TABLE: BEGIN ~A cannot be matched" + item + ) + ) + ) + + ;; Create a list of all properties used by the syntax. + (setq + properties + (delete-duplicates + + ;; Remove explicitly set to "default" properties. + (remove nil + + (append + + ;; List all properties in the syntoken list. + (mapcar + #'syntoken-property + (car elements) + ) + + ;; List all properties in the syntable list. + (mapcar + #'syntable-property + tables + ) + ) + ) + :test #'string= + :key #'synprop-name + ) + ) + + ;; Provide a default property if none specified. + (unless + (member + "default" + properties + :test #'string= + :key #'synprop-name + ) + (setq properties (append (list *prop-default*) properties)) + ) + + + ;; Now that a list of all nested syntax tables is known, compile the + ;; augment list. Note that even the main-table can be augmented to + ;; include tokens of one of it's children. + + ;; Adding the tokens of the augment tables must be done in + ;; two passes, or it may cause surprises due to "inherited" + ;; tokens, as the augment table was processed first, and + ;; increased it's token list. + (compile-syntax-augment-list main-table tables) + + ;; Now just append the augmented tokens to the table's token list. + (link-syntax-augment-table main-table) + + ;; Change all syntoken switch and begin fields to point to the + ;; syntable. + (dolist (item switches) + (if (keywordp (syntoken-switch item)) + ;; A switch may be relative, check if a keyword + ;; was specified. + (setf + (syntoken-switch item) + (car + (member + (syntoken-switch item) + tables + :key #'syntable-label + ) + ) + ) + ) + ) + (dolist (item begins) + (setf + (syntoken-begin item) + (car + (member + (syntoken-begin item) + tables + :key #'syntable-label + ) + ) + ) + ) + + ;; Don't need to add a entity for default properties + (dolist (item (car elements)) + (and + (syntoken-property item) + (string= (synprop-name (syntoken-property item)) "default") + (setf (syntoken-property item) ()) + ) + ) + (dolist (item tables) + (and + (syntable-property item) + (string= (synprop-name (syntable-property item)) "default") + (setf (syntable-property item) ()) + ) + ) + + (setq syntax + (make-syntax + :name name + :options options + :labels tables + :quark + (compile-syntax-property-list + name + properties + ) + :token-count + (length (car elements)) + ) + ) + + ;; Ready to run! +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Loop applying the specifed syntax table to the text. +;; XXX This function needs a review. Should compile the regex patterns +;; with newline sensitive match (and scan the entire file), and keep a +;; cache of matched tokens (that may be at a very longer offset), and, +;; when the match is removed from the cache, readd the token to the +;; token-list; if the token does not match, it will not be in the cache, +;; but should be removed from the token-list. If properly implemented, it +;; should be somewhat like 4 times faster, but I would not be surprised +;; if it becames even faster. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun syntax-highlight (*syntax* + &optional + (*from* (point-min)) + (*to* (point-max)) + interactive + &aux +#+debug (*line-number* 0) + stream + indent-table + ) + + ;; Make sure the property list is in use. + ;; The interactive flag is only set after loading the file. + (or interactive + (property-list (syntax-quark *syntax*)) + ) + +#+debug + (setq *from* 0 *to* 0) + +#-debug + (and (>= *from* *to*) (return-from syntax-highlight (values *from* nil))) + + ;; Remove any existing properties from the text. + (clear-entities *from* (1+ *to*)) + + (setq stream +#-debug (make-string-input-stream (read-text *from* (- *to* *from*))) +#+debug *standard-input* + ) + + (prog* + ( + ;; Used to check if end of file found but syntax stack did + ;; not finish. + (point-max (point-max)) + + ;; Used in interactive mode, to return the syntax table + ;; where the cursor is located. + (point (point)) + + ;; The current stack of states. + stack + + ;; The current syntable. + (syntax-table (car (syntax-labels *syntax*))) + + ;; The current syntable's default property. + (default-property (syntable-property syntax-table)) + + ;; Add this property to newlines as a hint to the interactive + ;; callback, so that it knows from where to restart parsing. + newline-property + + ;; The tokens in the current syntax table that may match, + ;; i.e. the items in this list are not in nomatch. + token-list + + ;; A pointer to the syntable token list, if token-list is + ;; eq to this value, cannot change it inplace. + current-token-list + + ;; Help to avoid allocating too many new object cells, and + ;; optmizes a bit time in [n]?set-difference. + ;; This optimizes only the processing of one line of text + ;; as nomatch must be rebuilt when reading a new line of text. + token-list-stack + + ;; Matches for the current list of tokens. + matches + + ;; Line of text. + line + + ;; Length of the text line. + length + + ;; A inverse cache, don't call re-exec when the regex is + ;; already known to not match. + nomatch + + ;; Use cache as a list of matches to avoid repetitive + ;; unnecessary calls to re-exec. + ;; cache is a list in which every element has the format: + ;; (token . (start . end)) + ;; Line of text. + cache + + ;; Used just to avoid a function call at every re-exec call. + notbol + + match + + start + left + right + result + property + + ;; Beginig a new syntax table? + begin + + ;; Switching to another syntax table? + switch + + ;; Property flag when changing the current syntax table. + contained + + ;; Flag to know if syntax table has changed. + change + + ;; Variables used when removing invalid elements from the + ;; the cache. + item + from + to + ) + +;----------------------------------------------------------------------- +:read +#+debug-verbose + (format t "** Entering :READ stack length is ~D~%" (length stack)) +#+debug (format t "~%[~D]> " (incf *line-number*)) + + ;; If input has finished, return. + (unless (setq line (read-line stream nil nil)) + (when + (and + ;; If a nested syntax table wasn't finished + (consp stack) + (< + (setq *to* (scan *from* :eol :right)) + point-max + ) + ) + (setq line (read-text *from* (- *to* *from*))) + (clear-entities *from* (1+ *to*)) + (go :again) + ) +#-debug (close stream) + (return) + ) + +;------------------------------------------------------------------------ +:again + (setq + start 0 + length (length line) + token-list (syntable-tokens syntax-table) + current-token-list token-list + token-list-stack () + nomatch () + cache () + ) + + + ;; If empty line, and current table does not have matches for + ;; the empty string at start or end of a text line. + (when + (and + (= length 0) + (not (syntable-eol syntax-table)) + (not (syntable-bol syntax-table))) +#+debug-verbose + (format t "Empty line and table has no match to bol or eol~%") + + (and newline-property + (add-entity *from* 1 (synprop-quark newline-property))) + (go :update) + ) + +;------------------------------------------------------------------------ +:loop +#+debug-verbose + (format t "** Entering :LOOP at offset ~D in table ~A, cache has ~D items~%" + start + (syntable-label syntax-table) + (length cache)) + + (setq notbol (> start 0)) + + ;; For every token that may match. + (dolist + (token + (setq + token-list + (if (eq token-list current-token-list) + (set-difference token-list nomatch :test #'eq) + (nset-difference token-list nomatch :test #'eq) + ) + ) + ) + + ;; Try to fetch match from cache. + (if (setq match (member token cache :test #'eq :key #'car)) + ;; Match is in the cache. + + (progn + ;; Match must be moved to the beginning of the + ;; matches list, as a match from another syntax + ;; table may be also in the cache, but before + ;; the match for the current token. +#+debug-verbose (format t "cached: {~A:~S} ~A~%" + (cdar match) + (subseq line (cadar match) (cddar match)) + (syntoken-regex token)) + + ;; Remove the match from the cache. + (if (eq match cache) + + ;; This could be changed to only set "matches" + ;; if it is not the first element of cache, + ;; but is unsafe, because other tokens may + ;; be added to "matches", and will end up + ;; before when joining "matches" and "cache". + (progn + (setq cache (cdr cache)) + (rplacd match matches) + (setq matches match)) + + (progn + (if (= (length match) 1) + (progn + (rplacd (last cache 2) nil) + (rplacd match matches) + (setq matches match)) + (progn + (setq matches (cons (car match) matches)) + (rplaca match (cadr match)) + (rplacd match (cddr match))) + ) + ) + ) + + ;; Exit loop if the all the remaining + ;; input was matched. + (when + (and + (= start (cadar match)) + (= length (cddar match)) + ) +#+debug-verbose (format t "Rest of line match~%") + (return) + ) + ) + + ;; Not in the cache, call re-exec. + (if + (consp + (setq + match + (re-exec + (syntoken-regex token) + line + :start start + :notbol notbol))) + + ;; Match found. + (progn +#+debug-verbose (format t "Adding to cache: {~A:~S} ~A~%" + (car match) + (subseq line (caar match) (cdar match)) + (syntoken-regex token)) + + ;; Only the first pair is used. + (setq match (car match)) + + (cond + ( + (or + (null matches) + ;; No overlap and after most + ;; recent match. + (>= (car match) (cddar matches)) + ;; No overlap and before most + ;; recent match. + (<= (cdr match) (cadar matches)) + ) + (setq + matches + (cons (cons token match) matches) + ) + ) + ( + (or + ;; Overlap, but start before most + ;; recent match. + (< (car match) (cadar matches)) + (and + ;; Same offset as most recent + ;; match, but is longer. + (= (car match) (cadar matches)) + (> (cdr match) (cddar matches)) + ) + ) + (rplaca (car matches) token) + (rplacd (car matches) match) +#+debug-verbose (format t "Replaced most recent match~%") + ) + (t +#+debug-verbose (format t "Ignored~%") + ;; XXX The interpreter does not yet implement + ;; implicit tagbody in dolist, just comment + ;; the go call in that case. (Will just do + ;; an unecessary test...) + (go :ignored) + ) + ) + + ;; Exit loop if the all the remaining + ;; input was matched. + (when + (and + (= start (car match)) + (= length (cdr match))) +#+debug-verbose (format t "Rest of line match~%") + (return)) + ) + + ;; Match not found. + (progn +#+debug-verbose (format t "Adding to nomatch: ~A~%" + (syntoken-regex token)) + (setq nomatch (cons token nomatch))) + ) + ) +:ignored + ) + + ;; Add matches to the beginning of the cache list. + (setq + ;; Put matches with smaller offset first. + cache + (stable-sort (nconc (nreverse matches) cache) #'< :key #'cadr) + + ;; Make sure that when the match loop is reentered, this + ;; variable is NIL. + matches + () + ) + + ;; While the first entry in the cache is not from the current table. + (until (or (null cache) (member (caar cache) token-list :test #'eq)) + +#+debug-verbose + (format t "Not in the current table, removing {~A:~S} ~A~%" + (cdar cache) + (subseq line (cadar cache) (cddar cache)) + (syntoken-regex (caar cache))) + + (setq cache (cdr cache)) + ) + + + ;; If nothing was matched in the entire/remaining line. + (unless cache + (when default-property + (if + (or + (null result) + (> start (cadar result)) + (not (eq (cddar result) default-property))) + (setq + result + (cons + (cons start (cons length default-property)) + result + ) + ) + (rplaca (cdar result) length) + ) + ) + +#+debug-verbose + (format t "No match until end of line~%") + + ;; Result already known, and there is no syntax table + ;; change, bypass :PARSE. + (and interactive + (null indent-table) + (<= 0 (- point *from*) length) + (setq indent-table syntax-table)) + (go :process) + ) + +#+debug-verbose + (format t "Removing first candidate from cache {~A:~S} ~A~%" + (cdar cache) + (subseq line (cadar cache) (cddar cache)) + (syntoken-regex (caar cache)) + ) + + ;; Prepare to choose best match. + (setq + match (car cache) + left (cadr match) + right (cddr match) + cache (cdr cache) + ) + + ;; First element can be safely removed now. + ;; If there is only one, skip loop below. + (or cache (go :parse)) + + ;; Remove elements of cache that must be discarded. + (setq + item (car cache) + from (cadr item) + to (cddr item) + ) + + (loop + (if + (or + + ;; If everything removed from the cache. + (null item) + + ;; Or next item is at a longer offset than the + ;; end of current match. + (>= from right) + ) + (return) + ) + + (and + ;; If another match at the same offset. + (= left from) + + ;; And if this match is longer than the current one. + (> to right) + + (member (car item) token-list :test #'eq) + + (setq + match item + right to + ) + ) + +#+debug-verbose + (format t "Removing from cache {~A:~S} ~A~%" + (cdar cache) + (subseq line from to) + (syntoken-regex (caar cache))) + + (setq + cache (cdr cache) + item (car cache) + from (cadr item) + to (cddr item) + ) + ) + + +;----------------------------------------------------------------------- +:parse +#+debug-verbose + (format t "** Entering :PARSE~%") + + (setq + + ;; Change match value to the syntoken. + match (car match) + + begin (syntoken-begin match) + switch (syntoken-switch match) + contained (syntoken-contained match) + change (or begin switch) + ) + + ;; Check for unmatched leading text. + (when (and default-property (> left start)) +#+debug-verbose (format t "No match in {(~D . ~D):~S}~%" + start + left + (subseq line start left) + ) + (if + (or + (null result) + (> start (cadar result)) + (not (eq (cddar result) default-property))) + (setq + result + (cons + (cons start (cons left default-property)) + result + ) + ) + (rplaca (cdar result) left) + ) + ) + + ;; If the syntax table is not changed, + ;; or if the new table requires that the + ;; current default property be used. + (unless (and change contained) + + (and + (> right left) + (setq + property + (or + ;; If token specifies the property. + (syntoken-property match) + default-property + ) + ) + + ;; Add matched text. + (if + (or + (null result) + (> left (cadar result)) + (not (eq (cddar result) property)) + ) + (setq + result + (cons + (cons left (cons right property)) + result + ) + ) + (rplaca (cdar result) right) + ) + ) + +#+debug-verbose + (format t "(0)Match found for {(~D . ~D):~S}~%" + left + right + (subseq line left right) + ) + ) + + + ;; Update start offset in the input now! + (and interactive + (null indent-table) + (<= start (- point *from*) right) + (setq indent-table syntax-table)) + (setq start right) + + + ;; When changing the current syntax table. + (when change + (when switch + (if (numberp switch) + + ;; If returning to a previous state. + ;; Don't generate an error if the stack + ;; becomes empty? + (while + (< switch 0) + + (setq + syntax-table (pop stack) + token-list (pop token-list-stack) + switch (1+ switch) + ) + ) + + ;; Else, not to a previous state, but + ;; returning to a named syntax table, + ;; search for it in the stack. + (while + (and + + (setq + token-list (pop token-list-stack) + syntax-table (pop stack) + ) + + (not (eq switch syntax-table)) + ) + ;; Empty loop. + ) + ) + + ;; If no match found while popping + ;; the stack. + (unless syntax-table + + ;; Return to the topmost syntax table. + (setq + syntax-table + (car (syntax-labels *syntax*)) + ) + ) + +#+debug-verbose (format t "switching to ~A offset: ~D~%" + (syntable-label syntax-table) + start + ) + + (if (null token-list) + (setq token-list (syntable-tokens syntax-table)) + ) + ) + + (when begin + ;; Save state for a possible + ;; :SWITCH later. + (setq + stack (cons syntax-table stack) + token-list-stack (cons token-list token-list-stack) + token-list (syntable-tokens begin) + syntax-table begin + ) +#+debug-verbose (format t "begining ~A offset: ~D~%" + (syntable-label syntax-table) + start + ) + ) + + ;; Change current syntax table. + (setq + default-property (syntable-property syntax-table) + current-token-list (syntable-tokens syntax-table) + ) + + ;; Set newline property, to help interactive callback + ;; Only need to have a defined value, for now don't care + ;; about wich value is being used, neither if there is + ;; a value to be set. + (if (null stack) + (setq newline-property nil) + (or newline-property + (setq newline-property default-property) + (setq newline-property (syntoken-property match)) + ) + ) + + ;; If processing of text was deferred. + (when contained + + (and + (> right left) + (setq + property + (or + (syntoken-property match) + default-property + ) + ) + ;; Add matched text with the updated property. + (if + (or + (null result) + (> left (cadar result)) + (not (eq (cddar result) property)) + ) + (setq + result + (cons + (cons left (cons right property)) + result + ) + ) + (rplaca (cdar result) right) + ) + ) + +#+debug-verbose (format t "(1)Match found for {(~D . ~D):~S}~%" + left + right + (subseq line left right) + ) + ) + + (go :loop) + ) + + +;----------------------------------------------------------------------- + ;; Wait for the end of the line to process, so that + ;; it is possible to join sequential matches with the + ;; same text property. + (and (or cache (< start length)) (go :loop)) +:process + +#+debug-verbose + (format t "** Entering :PROCESS~%") + + (if result + (progn + ;; If the last property was at the end of the line, + ;; there are nested syntax tables, and there is a + ;; default property, include the newline in the property, + ;; as a hint to the interactive callback. + (and + newline-property + (if + (and + (eq (cddar result) newline-property) + (= length (cadar result)) + ) + (rplaca (cdar result) (1+ length)) + (setq + result + (cons + (cons length (cons (1+ length) newline-property)) + result + ) + ) + ) + ) + + ;; Result was created in reversed order. + (nreverse result) + (dolist (item result) + (setq + left (car item) + right (cadr item) + property (cddr item)) + + ;; Use the information. + (add-entity + (+ *from* left) + (- right left) + (synprop-quark property)) + ) + ) + + (and newline-property + (add-entity + (+ *from* length) + 1 + (synprop-quark newline-property)) + ) + ) + +;------------------------------------------------------------------------ +:update + ;; Prepare for new matches. + (setq + result nil + + ;; Update offset to read text. + ;; Add 1 for the skipped newline. + *from* (+ *from* length 1) + ) + + (go :read) + ) + +#+debug (terpri) + (values *to* indent-table) +) + +(compile 'syntax-highlight) |