From 0a193e032ba1ecf3f003e027e833dc9d274cb740 Mon Sep 17 00:00:00 2001 From: Kaleb Keithley Date: Fri, 14 Nov 2003 16:49:22 +0000 Subject: Initial revision --- lisp/modules/indent.lsp | 1420 ++++++++++++++++++++++++++++++ lisp/modules/lisp.lsp | 174 ++++ lisp/modules/progmodes/c.lsp | 1118 ++++++++++++++++++++++++ lisp/modules/progmodes/html.lsp | 327 +++++++ lisp/modules/progmodes/imake.lsp | 188 ++++ lisp/modules/progmodes/lisp.lsp | 384 ++++++++ lisp/modules/progmodes/make.lsp | 135 +++ lisp/modules/progmodes/man.lsp | 160 ++++ lisp/modules/progmodes/rpm.lsp | 166 ++++ lisp/modules/progmodes/sgml.lsp | 428 +++++++++ lisp/modules/progmodes/sh.lsp | 113 +++ lisp/modules/progmodes/xconf.lsp | 68 ++ lisp/modules/progmodes/xlog.lsp | 102 +++ lisp/modules/progmodes/xrdb.lsp | 115 +++ lisp/modules/psql.c | 983 +++++++++++++++++++++ lisp/modules/syntax.lsp | 1452 ++++++++++++++++++++++++++++++ lisp/modules/x11.c | 666 ++++++++++++++ lisp/modules/xaw.c | 665 ++++++++++++++ lisp/modules/xedit.lsp | 560 ++++++++++++ lisp/modules/xt.c | 1797 ++++++++++++++++++++++++++++++++++++++ 20 files changed, 11021 insertions(+) create mode 100644 lisp/modules/indent.lsp create mode 100644 lisp/modules/lisp.lsp create mode 100644 lisp/modules/progmodes/c.lsp create mode 100644 lisp/modules/progmodes/html.lsp create mode 100644 lisp/modules/progmodes/imake.lsp create mode 100644 lisp/modules/progmodes/lisp.lsp create mode 100644 lisp/modules/progmodes/make.lsp create mode 100644 lisp/modules/progmodes/man.lsp create mode 100644 lisp/modules/progmodes/rpm.lsp create mode 100644 lisp/modules/progmodes/sgml.lsp create mode 100644 lisp/modules/progmodes/sh.lsp create mode 100644 lisp/modules/progmodes/xconf.lsp create mode 100644 lisp/modules/progmodes/xlog.lsp create mode 100644 lisp/modules/progmodes/xrdb.lsp create mode 100644 lisp/modules/psql.c create mode 100644 lisp/modules/syntax.lsp create mode 100644 lisp/modules/x11.c create mode 100644 lisp/modules/xaw.c create mode 100644 lisp/modules/xedit.lsp create mode 100644 lisp/modules/xt.c (limited to 'lisp/modules') diff --git a/lisp/modules/indent.lsp b/lisp/modules/indent.lsp new file mode 100644 index 0000000..4a7f7aa --- /dev/null +++ b/lisp/modules/indent.lsp @@ -0,0 +1,1420 @@ +; +;; 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/indent.lsp,v 1.7 2003/01/29 03:05:53 paulo Exp $ +;; + +(provide "indent") +(require "xedit") +(in-package "XEDIT") + +(defconstant indent-spaces '(#\Tab #\Space)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The final indentation function. +;; Parameters: +;; indent +;; Number of spaces to insert +;; offset +;; Offset to where indentation should be added +;; no-tabs +;; If set, tabs aren't inserted +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun indent-text (indent offset &optional no-tabs + &aux start line length index current tabs spaces string + barrier base result (point (point)) + ) + + ;; Initialize + (setq + start (scan offset :eol :left) + line (read-text start (- offset start)) + length (length line) + index (1- length) + current 0 + base 0 + ) + + (and (minusp indent) (setq indent 0)) + + ;; Skip any spaces after offset, "paranoia check" + (while (member (char-after offset) indent-spaces) + (incf offset) + ) + + ;; Check if there are only spaces before `offset' and the line `start' + (while (and (>= index 0) (member (char line index) indent-spaces)) + (decf index) + ) + + ;; `index' will be zero if there are only spaces in the `line' + (setq barrier (+ start (incf index))) + + ;; Calculate `base' unmodifiable indentation, if any + (dotimes (i index) + (if (char= (char line i) #\Tab) + (incf base (- 8 (rem base 8))) + (incf base) + ) + ) + + ;; If any non blank character would need to be deleted + (and (> base indent) (return-from indent-text nil)) + + ;; Calculate `current' indentation + (setq current base) + (while (< index length) + (if (char= (char line index) #\Tab) + (incf current (- 8 (rem current 8))) + (incf current) + ) + (incf index) + ) + + ;; Maybe could also "optimize" the indentation even if it is already + ;; correct, removing spaces "inside" tabs. + (when (/= indent current) + (if no-tabs + (setq + length (- indent base) + result (+ barrier length) + string (make-string length :initial-element #\Space) + ) + (progn + (multiple-value-setq (tabs spaces) (floor (- indent base) 8)) + (setq + length (+ tabs spaces) + result (+ barrier length) + string (make-string length :initial-element #\Tab) + ) + (fill string #\Space :start tabs) + ) + ) + + (replace-text barrier offset string) + (and (>= offset point) (>= point barrier) (goto-char result)) + ) +) +(compile 'indent-text) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helper function, returns indentation of a given offset +;; If `align' is set, stop once a non blank character is seen, that +;; is, use `offset' only as a line identifier +;; If `resolve' is set, it means that the offset is just a hint, it +;; maybe anywhere in the line +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun offset-indentation (offset &key resolve align + &aux + char + line + (start (scan offset :eol :left)) + (indent 0)) + (if resolve + (loop + (if (characterp (setq char (char-after start))) + (if (char= char #\Tab) + (incf indent (- 8 (rem indent 8))) + ;; Not a tab, check if is a space + (if (char= char #\Space) + (incf indent) + ;; Not a tab neither a space + (return indent) + ) + ) + ;; EOF found + (return indent) + ) + ;; Increment offset to check next character + (incf start) + ) + (progn + (setq line (read-text start (- offset start))) + (dotimes (i (length line) indent) + (if (char= (setq char (char line i)) #\Tab) + (incf indent (- 8 (rem indent 8))) + (progn + (or align (member char indent-spaces) + (return indent) + ) + (incf indent) + ) + ) + ) + ) + ) +) +(compile 'offset-indentation) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; A default/fallback indentation function, just copy indentation +;; of previous line. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun default-indent (syntax syntable) + (let + ( + (offset (scan (point) :eol :left)) + start + left + right + ) + + syntable ;; XXX hack to not generate warning about unused + ;; variable, should be temporary (until unused + ;; variables can be declared as such) + + (if + (or + ;; if indentation is disabled + (and + (hash-table-p (syntax-options syntax)) + (gethash :disable-indent (syntax-options syntax)) + ) + ;; or if not at the start of a new line + (> (scan offset :eol :right) offset) + ) + (return-from default-indent) + ) + + (setq left offset) + (loop + (setq + start left + left (scan start :eol :left :count 2) + right (scan left :eol :right) + ) + ;; if start of file reached + (and (>= left start) (return)) + (when + (setq + start + (position-if-not + #'(lambda (char) (member char indent-spaces)) + (read-text left (- right left)) + ) + ) + + ;; indent the current line + (indent-text (offset-indentation (+ left start) :align t) offset) + (return) + ) + ) + ) +) +(compile 'default-indent) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helper function +;; Clear line before cursor if it is empty +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun indent-clear-empty-line (&aux left offset right line index) + (setq + offset (scan (point) :eol :left) + left (scan offset :eol :left :count 2) + right (scan left :eol :right) + ) + + ;; If not at the first line in the file and line is not already empty + (when (and (/= offset left) (/= left right)) + (setq + line (read-text left (- right left)) + index (1- (length line)) + ) + (while (and (>= index 0) (member (char line index) indent-spaces)) + (decf index) + ) + ;; If line was only spaces + (and (minusp index) (replace-text left right "")) + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Macro to be called whenever an indentation rule decides that +;; the parser is done. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indent-macro-terminate (&optional result) + `(return-from ind-terminate-block ,result) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Like indent-terminate, but "rejects" the input for the current line +;; and terminates the loop. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indent-macro-reject (&optional result) + `(progn + (setq ind-state ind-prev-state) + (return-from ind-terminate-block ,result) + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Like indent-reject, but "rejects" anything before the current token +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indent-macro-reject-left (&optional result) + `(progn + (setq ind-state ind-matches) + (return-from ind-terminate-block ,result) + ) +) + + +(defstruct indtoken + regex ;; a string, character or regex + token ;; the resulting token, nil or a keyword + begin ;; begin a new table + switch ;; switch to another table + ;; begin and switch fields are used like the ones for the syntax highlight + ;; syntoken structure. + label ;; filed at compile time + code ;; code to execute when it matches +) + +(defstruct indtable + label ;; a keyword, name of the table + tokens ;; list of indtoken structures + tables ;; list of indtable structures + augments ;; augment list +) + +(defstruct indaugment + labels ;; list of keywords labeling tables +) + +(defstruct indinit + variables ;; list of variables and optional initialization + ;; Format of variables must be suitable to LET*, example of call: + ;; (indinit + ;; var1 ;; initialized to NIL + ;; (var2 (afun)) ;; initialized to the value returned by AFUN + ;; ) +) + +(defstruct indreduce + token ;; reduced token + rules ;; list of rules + label ;; unique label associated with rule, this + ;; field is automatically filled in the + ;; compilation process. this field exists + ;; to allow several indreduce definitions + ;; that result in the same token + check ;; FORM evaluated, if T apply reduce rule + code ;; PROGN to be called when a rule matches +) + +;; NOTE, unlike "reduce" rules, "resolve" rules cannot be duplicated +(defstruct indresolve + match ;; the matched token (or a list of tokens) + code ;; PROGN to apply for this token +) + +(defstruct indent + reduces ;; list of indreduce structures + tables ;; list of indtable structures + inits ;; initialization list + resolves ;; list of indresolve structures + token-code ;; code to execute when a token matches + check-code ;; code to execute before applying a reduce rule + reduce-code ;; code to execute after reduce rule + resolve-code ;; code to execute when matching a token +) + +(defmacro defindent (variable label &rest lists) + `(if (boundp ',variable) + ,variable + (progn + (proclaim '(special ,variable)) + (setq ,variable (compile-indent-table ,label ,@lists)) + ) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Create an indent token. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indtoken (pattern token + &key icase nospec begin switch code (nosub t)) + (setq pattern (re-comp (eval pattern) :icase icase :nospec nospec :nosub nosub)) + (when (consp (re-exec pattern "" :notbol t :noteol t)) + (error "INDTOKEN: regex ~A matches empty string" pattern) + ) + + ;; result of macro, return token structure + (make-indtoken + :regex pattern + :token token + :begin begin + :switch switch + :code code + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Create an indentation table. Basically a list of indentation tokens. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun indtable (label &rest definitions) + ;; check for simple errors + (unless (keywordp label) + (error "INDTABLE: ~A is not a keyword" label) + ) + (dolist (item definitions) + (unless + (or + (atom item) + (indtoken-p item) + (indtable-p item) + (indaugment-p item) + ) + (error "INDTABLE: invalid indent table argument ~A" item) + ) + ) + + ;; return indent table structure + (make-indtable + :label label + :tokens (remove-if-not #'indtoken-p definitions) + :tables (remove-if-not #'indtable-p definitions) + :augments (remove-if-not #'indaugment-p definitions) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Add identifier to list of augment tables. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun indaugment (&rest keywords) + (dolist (keyword keywords) + (unless (keywordp keyword) + (error "INDAUGMENT: bad indent table label ~A" keyword) + ) + ) + + ;; return augment list structure + (make-indaugment :labels keywords) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Add variables to initialization list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indinit (&rest variables) + (make-indinit :variables variables) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Create a "reduction rule" +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indreduce (token check rules &rest code &aux nullp consp) + ;; check for simple errors + (unless (or (keywordp token) (null token)) + (error "INDREDUCE: ~A is not a keyword" token) + ) + (dolist (rule rules) + (or (listp rule) (error "INDREDUCE: invalid indent rule ~A" rule)) + ;; XXX This test is not enough, maybe should add some sort of + ;; runtime check to avoid circularity. + (and (eq token (car rule)) (null (cdr rule)) + (error "INDREDUCE: ~A reduces to ~A" token) + ) + (dolist (item rule) + (and (or nullp consp) (not (keywordp item)) + (error "INDREDUCE: a keyword must special pattern") + ) + (if (consp item) + (progn + (unless + (or + (and + (eq (car item) 'not) + (keywordp (cadr item)) + (null (cddr item)) + ) + (and + (eq (car item) 'or) + (null (member-if-not #'keywordp (cdr item))) + ) + ) + (error "INDREDUCE: syntax error parsing ~A" item) + ) + (setq consp t) + ) + (progn + (setq nullp (null item) consp nil) + (unless (or (keywordp item) nullp (eq item t)) + (error "INDREDUCE: ~A is not a keyword" item) + ) + ) + ) + ) +; (and consp +; (error "INDREDUCE: pattern must be followed by keyword") +; ) + ) + + ;; result of macro, return indent reduce structure + (make-indreduce + :token token + :check check + :rules (remove-if #'null rules) + :code code + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Create a "resolve rule" +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indresolve (match &rest code) + ;; check for simple errors + (if (consp match) + (dolist (token match) + (or (keywordp token) (error "INDRESOLVE: ~A is not a keyword" token)) + ) + (or (keywordp match) (error "INDRESOLVE: ~A is not a keyword" match)) + ) + + ;; result of macro, return indent resolve structure + (make-indresolve + :match match + :code code + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helper function for compile-indent-table. Returns a list of all +;; tables and tokens for a given table, including tokens and tables +;; of children. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun list-indtable-elements (table &aux result sub-result) + (setq result (cons (indtable-tokens table) (indtable-tables table))) + (dolist (child (indtable-tables table)) + (setq sub-result (list-indtable-elements child)) + (rplaca result (append (car result) (car sub-result))) + (rplacd result (append (cdr result) (cdr sub-result))) + ) + ;; Return pair of all nested tokens and tables + result +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; First pass adding augumented tokens to a table, done in two passes +;; to respect inheritance order. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-indent-augment-list (table table-list &aux labels augment tokens) + + ;; Create a list of all augment tables. + (dolist (augment (indtable-augments table)) + (setq labels (append labels (indaugment-labels augment))) + ) + + ;; Remove duplicates and references to "itself", without warnings? + (setq + labels + (remove (indtable-label table) (remove-duplicates labels :from-end t)) + ) + + ;; Check if the specified indent tables exists! + (dolist (label labels) + (unless + (setq augment (car (member label table-list :key #'indtable-label))) + (error "COMPILE-INDENT-AUGMENT-LIST: Cannot augment ~A in ~A" + label + (indtable-label table) + ) + ) + + ;; Increase list of tokens. + (setq tokens (append tokens (indtable-tokens augment))) + ) + + ;; Store the tokens in the augment list. They will be added + ;; to the indent table in the second pass. + (setf (indtable-augments table) tokens) + + ;; Recurse on every child table. + (dolist (child (indtable-tables table)) + (compile-indent-augment-list child table-list) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Last pass adding augmented tokens to a table. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun link-indent-augment-list (table) + (setf + (indtable-tokens table) + (remove-duplicates + (nconc (indtable-tokens table) (indtable-augments table)) + :key #'indtoken-regex + :test #'equal + :from-end t + ) + + ;; Don't need to keep this list anymore. + (indtable-augments table) + () + ) + + (dolist (child (indtable-tables table)) + (link-indent-augment-list child) + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Compile the indent reduction rules +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-indent-reduces (reduces + &aux need label check rules reduce + check-code reduce-code) + (dolist (item reduces) + (setq + label (indreduce-label item) + check (indreduce-check item) + rules (indreduce-rules item) + reduce (indreduce-code item) + need (and + rules + (not label) + (or + reduce + (null check) + (not (constantp check)) + ) + ) + ) + (when need + (and (null label) (setq label (intern (string (gensym)) 'keyword))) + + (setf (indreduce-label item) label) + + (and + (or (null check) + (not (constantp check)) + ) + (setq + check (list (list 'eq '*ind-label* label) check) + check-code (nconc check-code (list check)) + ) + ) + + (and reduce + (setq + reduce (cons (list 'eq '*ind-label* label) reduce) + reduce-code (nconc reduce-code (list reduce)) + ) + ) + ) + ) + + ;; XXX Instead of using COND, could/should use CASE + ;; TODO Implement a smart CASE in the bytecode compiler, if + ;; possible, should generate a hashtable, or a table + ;; of indexes (for example when all elements in the cases + ;; are characters) and then jump directly to the code. + (if check-code + (setq check-code (cons 'cond (nconc check-code '((t t))))) + (setq check-code t) + ) + (and reduce-code (setq reduce-code (cons 'cond reduce-code))) + + (values check-code reduce-code) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Compile the indent resolve code +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-indent-resolves (resolves &aux match resolve resolve-code) + (and + (/= + (length resolves) + (length (remove-duplicates resolves :key #'indresolve-match)) + ) + ;; XXX Could do a more complete job and tell what is wrong... + (error "COMPILE-INDENT-RESOLVES: duplicated labels") + ) + + (dolist (item resolves) + (when (setq resolve (indresolve-code item)) + (setq + match + (indresolve-match item) + + resolve + (cons + (if (listp match) + (list 'member '*ind-token* `',match :test `#'eq) + (list 'eq '*ind-token* match) + ) + resolve + ) + + resolve-code + (nconc resolve-code (list resolve)) + ) + ) + ) + + (and resolve-code (cons 'cond resolve-code)) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Create an indentation table +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-indent-table (name &rest lists + &aux main elements switches begins tables symbols + label code token-code check-code reduce-code + (inits (remove-if-not #'indinit-p lists)) + (reduces (remove-if-not #'indreduce-p lists)) + (resolves (remove-if-not #'indresolve-p lists)) + ) + (setq + lists (delete-if + #'(lambda (object) + (or + (indinit-p object) + (indreduce-p object) + (indresolve-p object) + ) + ) + lists) + main (apply #'indtable name lists) + elements (list-indtable-elements main) + switches (remove-if #'null (car elements) :key #'indtoken-switch) + begins (remove-if #'null (car elements) :key #'indtoken-begin) + tables (cons main (cdr elements)) + ) + + ;; Check for typos in the keywords, or for not defined indent tables. + (dolist (item (mapcar #'indtoken-switch switches)) + (unless + (or (and (integerp item) (minusp item)) + (member item tables :key #'indtable-label) + ) + (error "COMPILE-INDENT-TABLE: SWITCH ~A cannot be matched" item) + ) + ) + (dolist (item (mapcar #'indtoken-begin begins)) + (unless (member item tables :key #'indtable-label) + (error "COMPILE-INDENT-TABLE: BEGIN ~A cannot be matched" item) + ) + ) + + ;; Build augment list. + (compile-indent-augment-list main tables) + (link-indent-augment-list main) + + ;; Change switch and begin fields to point to the indent table + (dolist (item switches) + (if (keywordp (indtoken-switch item)) + (setf + (indtoken-switch item) + (car (member (indtoken-switch item) tables :key #'indtable-label)) + ) + ) + ) + (dolist (item begins) + (setf + (indtoken-begin item) + (car (member (indtoken-begin item) tables :key #'indtable-label)) + ) + ) + + ;; Build initialization list + (dolist (init inits) + (setq symbols (nconc symbols (indinit-variables init))) + ) + + ;; Build token code + (dolist (item (car elements)) + (when (setq code (indtoken-code item)) + (setf + label + (intern (string (gensym)) 'keyword) + + (indtoken-label item) + label + + code + (list (list 'eq '*ind-label* label) code) + + token-code + (nconc token-code (list code)) + ) + ) + ) + + (multiple-value-setq + (check-code reduce-code) + (compile-indent-reduces reduces) + ) + + (make-indent + :tables tables + :inits symbols + :reduces reduces + :resolves resolves + :token-code (and token-code (cons 'cond token-code)) + :check-code check-code + :reduce-code reduce-code + :resolve-code (compile-indent-resolves resolves) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Search rule-pattern in match-pattern +;; Returns offset of match, and it's length, if any +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun indent-search-rule (rule-pattern match-pattern + &aux start rule rulep matchp test offset length) + (if (member-if-not #'keywordp rule-pattern) + ;; rule has wildcards + (progn + (setq + rulep rule-pattern + matchp match-pattern + start match-pattern + ) + (loop + (setq rule (car rulep)) + (cond + ;; Special pattern + ((consp rule) + (if (eq (car rule) 'not) + (progn + (setq + test (cadr rule) + rulep (cdr rulep) + rule (car rulep) + ) + (while + (and + ;; something to match + matchp + ;; NOT match is true + (not (eq (car matchp) test)) + ;; next match is not true + (not (eq (car matchp) rule)) + ) + (setq matchp (cdr matchp)) + ) + (if (eq (car matchp) rule) + ;; rule matched + (setq + matchp (cdr matchp) + rulep (cdr rulep) + ) + ;; failed + (setq + rulep rule-pattern + matchp (cdr start) + start matchp + ) + ) + ) + ;; (eq (car rule) 'or) + (progn + (if (member (car matchp) (cdr rule) :test #'eq) + (setq rulep (cdr rulep) matchp (cdr matchp)) + ;; failed + (progn + ;; end of match found! + (and (null matchp) (return)) + ;; reset search + (setq + rulep rule-pattern + matchp (cdr start) + start matchp + ) + ) + ) + ) + ) + ) + + ;; Skip until end of match-pattern or rule is found + ((null rule) + (setq rulep (cdr rulep)) + ;; If matches everything + (if (null rulep) + (progn (setq matchp nil) (return)) + ;; If next token cannot be matched + (unless + (setq + matchp + (member (car rulep) matchp :test #'eq) + ) + (setq rulep rule-pattern) + (return) + ) + ) + (setq rulep (cdr rulep) matchp (cdr matchp)) + ) + + ;; Matched + ((eq rule t) + ;; If there isn't a rule to skip + (and (null matchp) (return)) + (setq rulep (cdr rulep) matchp (cdr matchp)) + ) + + ;; Matched + ((eq rule (car matchp)) + (setq rulep (cdr rulep) matchp (cdr matchp)) + ) + + ;; No match + (t + ;; end of match found! + (and (null matchp) (return)) + ;; reset search + (setq + rulep rule-pattern + matchp (cdr start) + start matchp + ) + ) + ) + + ;; if everything matched + (or rulep (return)) + ) + + ;; All rules matched + (unless rulep + ;; Calculate offset and length of match + (setq offset 0 length 0) + (until (eq match-pattern start) + (setq + offset (1+ offset) + match-pattern (cdr match-pattern) + ) + ) + (until (eq match-pattern matchp) + (setq + length (1+ length) + match-pattern (cdr match-pattern) + ) + ) + ) + ) + ;; no wildcards + (and (setq offset (search rule-pattern match-pattern :test #'eq)) + (setq length (length rule-pattern)) + ) + ) + + (values offset length) +) +(compile 'indent-search-rule) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Indentation parser +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro indent-macro (ind-definition ind-offset &optional ind-no-tabs) + `(prog* + ( + ;; Current indentation table + (ind-table (car (indent-tables ,ind-definition))) + + ;; The parser rules + (ind-reduces (indent-reduces ,ind-definition)) + + ;; Token list for the table + (ind-tokens (indtable-tokens ind-table)) + + ;; Stack of nested tables/states + ind-stack + + ;; indentation to be used + (*indent* 0) + + ;; offset to apply indentation + *offset* + + ;; Number of lines read + (*ind-lines* 1) + + ;; Matched token + *ind-token* + + ;; list of tokens after current match, should not be changed + *ind-token-list* + + ;; label associated with rule + *ind-label* + + ;; offset of match + *ind-offset* + + ;; length of match + *ind-length* + + ;; insert position + (*ind-point* (point)) + + (ind-from (scan ,ind-offset :eol :left)) + (ind-to ,ind-offset) + (ind-line (read-text ind-from (- ind-to ind-from))) + + ;; start of current line + (*ind-start* ind-from) + + ;; State information + ind-state + + ;; For use with (indent-macro-reject) + ind-prev-state + + ;; Matches for the current line + ind-matches + + ;; Matched tokens not yet used + ind-cache + + ;; Pattern being tested + ind-token + + ;; Used when searching for a regex + ind-match + + ;; Table to change + ind-change + + ;; Length of ind-line + (ind-length (length ind-line)) + + ;; Don't parse after this offset + (ind-end ind-length) + + ;; Temporary variables used during loops + ind-left + ind-right + ind-tleft + ind-tright + + ;; Set when start of file is found + ind-startp + + ;; Flag for regex search + (ind-noteol (< ind-to (scan ind-from :eol :right))) + + ;; Initialization variables expanded here + ,@(indent-inits (eval ind-definition)) + ) + + ;; Initial input already read + (go :ind-loop) + +;------------------------------------------------------------------------ +; Read a text line +:ind-read + (setq + ind-to ind-from + ind-from (scan ind-from :eol :left :count 2) + ) + ;; If start of file reached + (and (= ind-to ind-from) (setq ind-startp t) (go :ind-process)) + + (setq + *ind-lines* (1+ *ind-lines*) + ind-to (scan ind-from :eol :right) + ind-line (read-text ind-from (- ind-to ind-from)) + ind-length (length ind-line) + ind-end ind-length + ind-noteol nil + ind-cache nil + ind-prev-state ind-state + ) + +;------------------------------------------------------------------------ +; Loop parsing backwards +:ind-loop + (setq ind-matches nil) + (dolist (token ind-tokens) + ;; Prepare to loop + (setq + ind-token (indtoken-regex token) + ind-left 0 + ) + ;; While the pattern matches + (loop + (setq ind-right ind-left) + (if + (consp + (setq + ind-match + (re-exec + ind-token + ind-line + :start ind-left + :end ind-end + :notbol (> ind-left 0) + :noteol ind-noteol + ) + ) + ) + + ;; Remember about match + (setq + ind-match (car ind-match) + ind-left (cdr ind-match) + ind-matches (cons (cons token ind-match) ind-matches) + ) + + ;; No match + (return) + ) + ;; matched an empty string + (and (= ind-left ind-right) (incf ind-left)) + + ;; matched a single eol or bol + (and (>= ind-left ind-end) (return)) + ) + ) + + ;; Add new matches to cache + (when ind-matches + (setq + ind-cache + (stable-sort + (nconc (nreverse ind-matches) ind-cache) #'< :key #'cadr + ) + ) + ) + + ;; If nothing in the cache + (or ind-cache (go :ind-process)) + + (setq + ind-left (cadar ind-cache) + ind-right (cddar ind-cache) + ind-matches (cdr ind-cache) + ) + + ;; If only one element in the cache + (or ind-matches (go :ind-parse)) + + (setq + ind-tleft (cadar ind-matches) + ind-tright (cddar ind-matches) + ) + + ;; Remove overlaps + (loop + (if (or (>= ind-tleft ind-right) (<= ind-tright ind-left)) + ;; No overlap + (progn + (setq + ind-left ind-tleft + ind-right ind-tright + ind-matches (cdr ind-matches) + ) + ;; If everything checked + (or ind-matches (return)) + ) + ;; Overlap found + (progn + (if (consp (cdr ind-matches)) + ;; There are yet items to be checked + (progn + (rplaca ind-matches (cadr ind-matches)) + (rplacd ind-matches (cddr ind-matches)) + ) + ;; Last item + (progn + (rplacd (last ind-cache 2) nil) + (return) + ) + ) + ) + ) + + ;; Prepare for next check + (setq + ind-tleft (cadar ind-matches) + ind-tright (cddar ind-matches) + ) + ) + +;------------------------------------------------------------------------ +; Process the matched tokens +:ind-parse + (setq ind-cache (nreverse ind-cache)) + +:ind-parse-loop + (or (setq ind-match (car ind-cache)) (go :ind-process)) + + (setq + ind-cache (cdr ind-cache) + ind-token (car ind-match) + ) + + (or (member ind-token ind-tokens :test #'eq) + (go :ind-parse-loop) + ) + + ;; If a state should be added + (when (setq ind-change (indtoken-token ind-token)) + (setq + ind-left (cadr ind-match) + ind-right (cddr ind-match) + + *ind-offset* + (+ ind-from ind-left) + + *ind-length* + (- ind-right ind-left) + + ind-state + (cons + (cons ind-change (cons *ind-offset* *ind-length*)) + ind-state + ) + + *ind-label* + (indtoken-label ind-token) + ) + + ;; Expand token code + ,(indent-token-code (eval ind-definition)) + ) + + ;; Check if needs to switch to another table + (when (setq ind-change (indtoken-switch ind-token)) + ;; Need to switch to a previous table + (if (integerp ind-change) + ;; Relative switch + (while (and ind-stack (minusp ind-change)) + (setq + ind-table (pop ind-stack) + ind-change (1+ ind-change) + ) + ) + ;; Search table in the stack + (until + (or + (null ind-stack) + (eq + (setq ind-table (pop ind-stack)) + ind-change + ) + ) + ) + ) + + ;; If no match or stack became empty + (and (null ind-table) + (setq + ind-table + (car (indent-tables ,ind-definition)) + ) + ) + ) + + ;; Check if needs to start a new table + ;; XXX use ind-tleft to reduce number of local variables + (when (setq ind-tleft (indtoken-begin ind-token)) + (setq + ind-change ind-tleft + ind-stack (cons ind-table ind-stack) + ind-table ind-change + ) + ) + + ;; If current "indent pattern table" changed + (when ind-change + (setq + ind-tokens (indtable-tokens ind-table) + ind-cache (nreverse ind-cache) + ind-end (cadr ind-match) + ind-noteol (> ind-length ind-end) + ) + (go :ind-loop) + ) + + (and ind-cache (go :ind-parse-loop)) + +;------------------------------------------------------------------------ +; Everything checked, process result +:ind-process + + ;; If stack is not empty, don't apply rules + (and ind-stack (not ind-startp) (go :ind-read)) + + (block ind-terminate-block + (setq ind-cache nil ind-tleft 0 ind-change (mapcar #'car ind-state)) + (dolist (entry ind-reduces) + (setq + *ind-token* (indreduce-token entry) + *ind-label* (indreduce-label entry) + ) + (dolist (rule (indreduce-rules entry)) + (loop + ;; Check if reduction can be applied + (or + (multiple-value-setq + (ind-match ind-length) + (indent-search-rule rule ind-change) + ) + (return) + ) + + (setq + ;; First element matched + ind-matches (nthcdr ind-match ind-state) + + ;; Offset of match + *ind-offset* (cadar ind-matches) + + *ind-token-list* (nthcdr ind-match ind-change) + + ;; Length of match, note that *ind-length* + ;; Will be transformed to zero bellow if + ;; the rule is deleting entries. + *ind-length* + (if (> ind-length 1) + (progn + (setq + ;; XXX using ind-tright, to reduce + ;; number of local variables... + ind-tright + (nth (1- ind-length) ind-matches) + + ind-right + (+ (cadr ind-tright) + (cddr ind-tright) + ) + ) + (- ind-right *ind-offset*) + ) + (cddar ind-matches) + ) + ) + + ;; XXX using ind-tleft as a counter, to reduce + ;; number of used variables... + (and (>= (incf ind-tleft) 1000) + ;; Should never apply so many reduce rules on + ;; every iteration, if needs to, something is + ;; wrong in the indentation definition... + (error "~D INDREDUCE iterations, ~ + now checking (~A ~A)" + ind-tleft *ind-token* rule + ) + ) + + ;; Check if should apply the reduction + (or + ;; Expand check code + ,(indent-check-code (eval ind-definition)) + (return) + ) + + (if (null *ind-token*) + ;; Remove match + (progn + (setq *ind-length* 0) + (if (= ind-match 0) + ;; Matched the first entry + (setq + ind-state + (nthcdr ind-length ind-matches) + ) + (progn + (setq + ind-matches + (nthcdr (1- ind-match) ind-state) + ) + (rplacd + ind-matches + (nthcdr (1+ ind-length) ind-matches) + ) + ) + ) + ) + + ;; Substitute/simplify + (progn + (rplaca (car ind-matches) *ind-token*) + (when (> ind-length 1) + (rplacd (cdar ind-matches) *ind-length*) + (rplacd + ind-matches + (nthcdr ind-length ind-matches) + ) + ) + ) + ) + (setq + ind-cache t + ind-change (mapcar #'car ind-state) + ) + + ;; Expand reduce code + ,(indent-reduce-code (eval ind-definition)) + ) + ) + ) + + ;; ind-cache will be T if at least one change was done + (and ind-cache (go :ind-process)) + + ;; Start of file reached + (or ind-startp (go :ind-read)) + + ) ;; end of ind-terminate-block + + + (block ind-terminate-block + (setq *ind-token-list* (mapcar #'car ind-state)) + (dolist (item ind-state) + (setq + *ind-token* (car item) + *ind-offset* (cadr item) + *ind-length* (cddr item) + ) + ;; Expand resolve code + ,(indent-resolve-code (eval ind-definition)) + (setq *ind-token-list* (cdr *ind-token-list*)) + ) + ) + + (and (integerp *indent*) + (integerp *offset*) + (indent-text *indent* *offset* ,ind-no-tabs) + ) + ) +) diff --git a/lisp/modules/lisp.lsp b/lisp/modules/lisp.lsp new file mode 100644 index 0000000..55d5e6c --- /dev/null +++ b/lisp/modules/lisp.lsp @@ -0,0 +1,174 @@ +;; +;; Copyright (c) 2001 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/lisp.lsp,v 1.10 2002/12/20 04:32:47 paulo Exp $ +;; +(provide "lisp") + +(in-package "LISP") + +(export '( + second third fourth fifth sixth seventh eighth ninth tenth + pathname merge-pathnames + logtest signum + alphanumericp copy-seq push pop prog prog* + with-open-file with-output-to-string +)) + +(defun second (a) (nth 1 a)) +(defun third (a) (nth 2 a)) +(defun fourth (a) (nth 3 a)) +(defun fifth (a) (nth 4 a)) +(defun sixth (a) (nth 5 a)) +(defun seventh (a) (nth 6 a)) +(defun eighth (a) (nth 7 a)) +(defun ninth (a) (nth 8 a)) +(defun tenth (a) (nth 9 a)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; pathnames +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun pathname (filename) + (values (parse-namestring filename))) + +(defun merge-pathnames (pathname &optional defaults default-version) + (if (null default-version) + (parse-namestring pathname nil defaults) + (parse-namestring pathname nil + (make-pathname :defaults defaults :version default-version)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; math +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun logtest (integer1 integer2) + (not (zerop (logand integer1 integer2)))) + +(defun signum (number) + (if (zerop number) number (/ number (abs number)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; misc functions/macros +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun alphanumericp (char) + (or (alpha-char-p char) (not (null (digit-char-p char))))) + +(defun copy-seq (sequence) + (subseq sequence 0)) + +(defmacro prog (init &rest body) + `(block nil (let ,init (tagbody ,@body)))) + +(defmacro prog* (init &rest body) + `(block nil (let* ,init (tagbody ,@body)))) + +(defmacro with-open-file (file &rest body) + `(let ((,(car file) (open ,@(cdr file)))) + (unwind-protect + (progn ,@body) + (if ,(car file) (close ,(car file)))))) + +(defmacro with-output-to-string (stream &rest body) + `(let ((,(car stream) (make-string-output-stream))) + (unwind-protect + (progn ,@body (get-output-stream-string ,(car stream))) + (and ,(car stream) (close ,(car stream)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; setf +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defsetf car (list) (value) `(progn (rplaca ,list ,value) ,value)) +(defsetf cdr (list) (value) `(progn (rplacd ,list ,value) ,value)) + +(defsetf caar (list) (value) `(progn (rplaca (car ,list) ,value) ,value)) +(defsetf cadr (list) (value) `(progn (rplaca (cdr ,list) ,value) ,value)) +(defsetf cdar (list) (value) `(progn (rplacd (car ,list) ,value) ,value)) +(defsetf cddr (list) (value) `(progn (rplacd (cdr ,list) ,value) ,value)) +(defsetf caaar (list) (value) `(progn (rplaca (caar ,list) ,value) ,value)) +(defsetf caadr (list) (value) `(progn (rplaca (cadr ,list) ,value) ,value)) +(defsetf cadar (list) (value) `(progn (rplaca (cdar ,list) ,value) ,value)) +(defsetf caddr (list) (value) `(progn (rplaca (cddr ,list) ,value) ,value)) +(defsetf cdaar (list) (value) `(progn (rplacd (caar ,list) ,value) ,value)) +(defsetf cdadr (list) (value) `(progn (rplacd (cadr ,list) ,value) ,value)) +(defsetf cddar (list) (value) `(progn (rplacd (cdar ,list) ,value) ,value)) +(defsetf cdddr (list) (value) `(progn (rplacd (cddr ,list) ,value) ,value)) +(defsetf caaaar (list) (value) `(progn (rplaca (caaar ,list) ,value) ,value)) +(defsetf caaadr (list) (value) `(progn (rplaca (caadr ,list) ,value) ,value)) +(defsetf caadar (list) (value) `(progn (rplaca (cadar ,list) ,value) ,value)) +(defsetf caaddr (list) (value) `(progn (rplaca (caddr ,list) ,value) ,value)) +(defsetf cadaar (list) (value) `(progn (rplaca (cdaar ,list) ,value) ,value)) +(defsetf cadadr (list) (value) `(progn (rplaca (cdadr ,list) ,value) ,value)) +(defsetf caddar (list) (value) `(progn (rplaca (cddar ,list) ,value) ,value)) +(defsetf cadddr (list) (value) `(progn (rplaca (cdddr ,list) ,value) ,value)) +(defsetf cdaaar (list) (value) `(progn (rplacd (caaar ,list) ,value) ,value)) +(defsetf cdaadr (list) (value) `(progn (rplacd (caadr ,list) ,value) ,value)) +(defsetf cdadar (list) (value) `(progn (rplacd (cadar ,list) ,value) ,value)) +(defsetf cdaddr (list) (value) `(progn (rplacd (caddr ,list) ,value) ,value)) +(defsetf cddaar (list) (value) `(progn (rplacd (cdaar ,list) ,value) ,value)) +(defsetf cddadr (list) (value) `(progn (rplacd (cdadr ,list) ,value) ,value)) +(defsetf cdddar (list) (value) `(progn (rplacd (cddar ,list) ,value) ,value)) +(defsetf cddddr (list) (value) `(progn (rplacd (cdddr ,list) ,value) ,value)) + +(defsetf first (list) (value) `(progn (rplaca ,list ,value) ,value)) +(defsetf second (list) (value) `(progn (rplaca (nthcdr 1 ,list) ,value) ,value)) +(defsetf third (list) (value) `(progn (rplaca (nthcdr 2 ,list) ,value) ,value)) +(defsetf fourth (list) (value) `(progn (rplaca (nthcdr 3 ,list) ,value) ,value)) +(defsetf fifth (list) (value) `(progn (rplaca (nthcdr 4 ,list) ,value) ,value)) +(defsetf sixth (list) (value) `(progn (rplaca (nthcdr 5 ,list) ,value) ,value)) +(defsetf seventh (list) (value) `(progn (rplaca (nthcdr 6 ,list) ,value) ,value)) +(defsetf eighth (list) (value) `(progn (rplaca (nthcdr 7 ,list) ,value) ,value)) +(defsetf ninth (list) (value) `(progn (rplaca (nthcdr 8 ,list) ,value) ,value)) +(defsetf tenth (list) (value) `(progn (rplaca (nthcdr 9 ,list) ,value) ,value)) + +(defsetf rest (list) (value) `(progn (rplacd ,list ,value) ,value)) + +(defun lisp::nth-store (index list value) + (rplaca (nthcdr index list) value) value) +(defsetf nth lisp::nth-store) + +(defsetf aref (array &rest indices) (value) + `(lisp::vector-store ,array ,@indices ,value)) + +(defsetf get (symbol key &optional default) (value) + `(lisp::put ,symbol ,key ,value)) + +(defsetf symbol-plist lisp::set-symbol-plist) + +(defsetf gethash (key hash-table &optional default) (value) + `(lisp::puthash ,key ,hash-table ,value)) + +(defsetf char lisp::char-store) +(defsetf schar lisp::char-store) +(defsetf elt lisp::elt-store) +(defsetf svref lisp::elt-store) +(defsetf documentation lisp::documentation-store) + +(defsetf symbol-value set) + +(defsetf subseq (sequence start &optional end) (value) + `(progn (replace ,sequence ,value :start1 ,start :end1 ,end) ,value)) diff --git a/lisp/modules/progmodes/c.lsp b/lisp/modules/progmodes/c.lsp new file mode 100644 index 0000000..bc4474b --- /dev/null +++ b/lisp/modules/progmodes/c.lsp @@ -0,0 +1,1118 @@ +;; +;; 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/progmodes/c.lsp,v 1.26 2003/01/29 03:05:54 paulo Exp $ +;; + +(require "syntax") +(require "indent") +(in-package "XEDIT") + +(defsynprop *prop-format* + "format" + :font "*lucidatypewriter-medium-r*12*" + :foreground "RoyalBlue2" + :underline t +) + +(defsynoptions *c-DEFAULT-style* + ;; Positive number. Basic indentation. + (:indentation . 4) + + ;; Boolean. Support for GNU style indentation. + (:brace-indent . nil) + + ;; Boolean. Add one indentation level to case and default? + (:case-indent . t) + + ;; Boolean. Remove one indentation level for labels? + (:label-dedent . t) + + ;; Boolean. Add one indentation level to continuations? + (:cont-indent . t) + + ;; Boolean. Move cursor to the indent column after pressing ? + (:newline-indent . t) + + ;; Boolean. Set to T if tabs shouldn't be used to fill indentation. + (:emulate-tabs . nil) + + ;; Boolean. Force a newline before braces? + (:newline-before-brace . nil) + + ;; Boolean. Force a newline after braces? + (:newline-after-brace . nil) + + ;; Boolean. Force a newline after semicolons? + (:newline-after-semi . nil) + + ;; Boolean. Only calculate indentation after pressing ? + ;; This may be useful if the parser does not always + ;; do what the user expects... + (:only-newline-indent . nil) + + ;; Boolean. Remove extra spaces from previous line. + ;; This should default to T when newline-indent is not NIL. + (:trim-blank-lines . t) + + ;; Boolean. If this hash-table entry is set, no indentation is done. + ;; Useful to temporarily disable indentation. + (:disable-indent . nil) +) + +;; BSD like style +(defsynoptions *c-BSD-style* + (:indentation . 8) + (:brace-indent . nil) + (:case-indent . nil) + (:label-dedent . t) + (:cont-indent . t) + (:newline-indent . t) + (:emulate-tabs . nil) + (:newline-before-brace . nil) + (:newline-after-brace . t) + (:newline-after-semi . t) + (:trim-blank-lines . t) +) + +;; GNU like style +(defsynoptions *c-GNU-style* + (:indentation . 2) + (:brace-indent . t) + (:case-indent . nil) + (:label-dedent . t) + (:cont-indent . t) + (:newline-indent . nil) + (:emulate-tabs . nil) + (:newline-before-brace . t) + (:newline-after-brace . t) + (:newline-after-semi . t) + (:trim-blank-lines . nil) +) + +;; K&R like style +(defsynoptions *c-K&R-style* + (:indentation . 5) + (:brace-indent . nil) + (:case-indent . nil) + (:label-dedent . t) + (:cont-indent . t) + (:newline-indent . t) + (:emulate-tabs . t) + (:newline-before-brace . t) + (:newline-after-brace . t) + (:newline-after-semi . t) + (:trim-blank-lines . t) +) + +(defvar *c-styles* '( + ("xedit" . *c-DEFAULT-style*) + ("BSD" . *c-BSD-style*) + ("GNU" . *c-GNU-style*) + ("K&R" . *c-K&R-style*) +)) + +(defvar *c-mode-options* *c-DEFAULT-style*) +; (setq *c-mode-options* *c-gnu-style*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; This is a very lazy "pattern matcher" for the C language. +;; If the syntax in the code is not correct, it may get confused, and +;; because it is "lazy" some wrong constructs will be recognized as +;; correct when reducing patterns. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defindent *c-mode-indent* :main + ;; this must be the first token + (indtoken "^\\s*" :start-of-line) + (indtoken "\\" :c-case) + (indtoken "\\" :c-default) + (indtoken "\\" :do) + (indtoken "\\" :c-if) + (indtoken "\\" :c-else) + (indtoken "\\" :c-for) + (indtoken "\\" :c-switch) + (indtoken "\\" :c-while) + ;; Match identifiers and numbers as an expression + (indtoken "\\w+" :expression) + (indtoken ";" :semi :nospec t) + (indtoken "," :comma :nospec t) + (indtoken ":" :collon :nospec t) + ;; Ignore spaces before collon, this avoids dedenting ternary + ;; and bitfield definitions as the parser does not distinguish + ;; labels from those, another option would be to use the pattern + ;; "\\w+:", but this way should properly handle labels generated + ;; by macros, example: `MACRO_LABEL(value):' + (indtoken "\\s+:" nil) + + (indinit (c-braces 0)) + (indtoken "{" + :obrace + :nospec t + :code (decf c-braces) + ) + (indtoken "}" + :cbrace + :nospec t + :begin :braces + :code (incf c-braces) + ) + (indtable :braces + (indtoken "{" + :obrace + :nospec t + :switch -1 + :code (decf c-braces) + ) + (indtoken "}" + :cbrace + :nospec t + :begin :braces + :code (incf c-braces) + ) + ) + + (indinit (c-bra 0)) + (indtoken ")" :cparen :nospec t :code (incf c-bra)) + (indtoken "(" :oparen :nospec t :code (decf c-bra)) + (indtoken "]" :cbrack :nospec t :code (incf c-bra)) + (indtoken "[" :obrack :nospec t :code (decf c-bra)) + (indtoken "\\\\$" :continuation) + + ;; C++ style comment, disallow other tokens to match inside comment + (indtoken "//.*$" nil) + + (indtoken "#" :hash :nospec t) + + ;; if in the same line, reduce now, this must be done because the + ;; delimiters are identical + (indtoken "'([^\\']|\\\\.)*'" :expression) + (indtoken "\"([^\\\"]|\\\\.)*\"" :expression) + + (indtoken "\"" :cstring :nospec t :begin :string) + + (indtoken "'" :cconstant :nospec t :begin :constant) + + (indtoken "*/" :ccomment :nospec t :begin :comment) + ;; this must be the last token + (indtoken "$" :end-of-line) + + (indtable :string + ;; Ignore escaped characters + (indtoken "\\." nil) + ;; Return to the toplevel when the start of the string is found + (indtoken "\"" :ostring :nospec t :switch -1) + ) + (indtable :constant + ;; Ignore escaped characters + (indtoken "\\." nil) + ;; Return to the toplevel when the start of the character is found + (indtoken "'" :oconstant :nospec t :switch -1) + ) + (indtable :comment + (indtoken "/*" :ocomment :nospec t :switch -1) + ) + + ;; "Complex" statements + (indinit (c-complex 0) (c-cases 0)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Order of reduce rules here is important, process comment, + ;; continuations, preprocessor and set states when an eol is found. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (indinit (c-offset (point-max)) + (c-prev-offset c-offset) + ) + (indreduce :indent + t + ((:start-of-line)) + (and (= *ind-start* *ind-offset*) + (setq + *offset* (+ *ind-offset* *ind-length*) + ) + ) + (setq + c-prev-offset c-offset + c-offset *ind-offset* + ) + ) + + ;; Delete comments + (indreduce nil + t + ((:ocomment nil :ccomment)) + ) + + ;; Join in a single token to simplify removal of possible multiline + ;; preprocessor directives + (indinit c-continuation) + (indreduce :continuation + t + ((:continuation :end-of-line)) + (setq c-continuation t) + ) + + (indreduce :eol + t + ((:end-of-line)) + ;; Anything after the eol offset is safe to parse now + (setq c-continuation nil) + ) + + ;; Delete blank lines + (indreduce nil + t + ((:indent :eol)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Preprocessor + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce nil + (>= *ind-offset* *ind-start*) + ((:indent :hash)) + (setq *indent* 0) + (indent-macro-reject-left) + ) + (indreduce nil + t + ((:indent :hash nil :eol)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Expressions + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce :expression + t + ;; Reduce to a single expression + ((:expression :parens) + (:expression :bracks) + (:expression :expression) + ;; These may be multiline + (:ostring (not :ostring) :cstring) + (:oconstant (not :oconstant) :cconstant) + ) + ) + + (indreduce :expression + t + ((:expression :eol :indent :expression) + (:expression :eol :expression) + ) + ) + + (indreduce :exp-comma + t + ((:expression :comma) + ) + ) + + ;; A semicollon, start a statement + (indreduce :stat + t + ((:semi)) + ) + + ;; Expression following (possibly empty) statement + (indreduce :stat + t + (((or :expression :exp-comma) :stat)) + ) + + ;; Multiline statements + (indreduce :stat + t + (((or :expression :exp-comma) :eol :indent :stat) + ;; rule below may have removed the :indent + ((or :expression :exp-comma) :eol :stat) + ) + ) + + (indinit c-exp-indent) + ;; XXX This rule avoids parsing large amounts of code + (indreduce :stat + t + ;; Eat eol if following expression + ((:indent :stat :eol) + (:indent :stat) + ) + (if + (or + (null c-exp-indent) + (/= (cdar c-exp-indent) (+ *ind-offset* *ind-length*)) + ) + ;; A new statement, i.e. not just joining a multiline one + (push + (cons + (offset-indentation *ind-offset* :resolve t) + (+ *ind-offset* *ind-length*) + ) + c-exp-indent + ) + ;; Update start of statement + (rplaca + (car c-exp-indent) + (offset-indentation *ind-offset* :resolve t) + ) + ) + (when (consp (cdr c-exp-indent)) + (if (and + (zerop c-complex) + (zerop c-cases) + (zerop c-bra) + (= (caar c-exp-indent) (caadr c-exp-indent)) + ) + ;; Two statements with the same indentation + (progn + (setq *indent* (caar c-exp-indent)) + (indent-macro-reject-left) + ) + ;; Different indentation or complex state + (progn + (rplacd c-exp-indent nil) + (setq c-complex 0) + ) + ) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Handle braces + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce :stat + ;; If block finishes before current line, group as a statement + (< (+ *ind-offset* *ind-length*) *ind-start*) + ((:obrace (not :obrace) :cbrace)) + ) + (indreduce :obrace + ;; If not in the first line + (< *ind-offset* *ind-start*) + ;; If the opening { is the first non blank char in the line + ((:indent :obrace)) + (setq *indent* (offset-indentation (+ *ind-offset* *ind-length*))) + + ;; XXX This may be the starting brace of a switch + (setq c-case-flag nil) + (indent-macro-reject-left) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Labels + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; XXX this frequently doesn't do what is expected, should redefine + ;; some rules, as it frequently will dedent while typing something + ;; like test ? exp1 : exp2 + ;; ^ dedents here because it reduces everything + ;; before ':' to a single :expression token. + (indreduce :label + t + ((:indent :expression :collon :eol)) + (when (and *label-dedent* (>= *ind-offset* *ind-start*)) + (setq + *indent* + (- (offset-indentation *ind-offset* :resolve t) *base-indent*) + ) + (indent-macro-reject-left) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Handle if + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce :if + t + ((:c-if :parens) + ) + (incf c-complex) + ) + + (indreduce :else + t + ((:c-else)) + (incf c-complex) + ) + + ;; Join + (indreduce :else-if + t + ((:else :if) + (:else :eol :indent :if) + ) + (incf c-complex) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Handle for + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Join with the parentheses + (indreduce :for + t + ((:c-for :parens) + ) + (incf c-complex) + ) + ;; Before current line, simplify + (indreduce :stat + (< (+ *ind-offset* *ind-length*) *ind-point*) + ((:for :stat) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Handle while and do + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce :while + t + ((:c-while :parens) + ;; Assume that it is yet being edited, or adjusting indentation + (:c-while) + ) + (incf c-complex) + ) + (indreduce :stat + t + ((:do :stat :while) + (:while :stat) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Handle switch + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indinit c-case-flag) + + (indreduce :switch + t + ((:c-switch :parens) + ) + ) + ;; Transform in a statement + (indreduce :stat + (< (+ *ind-offset* *ind-length*) *ind-start*) + ((:switch :stat) + ;; Do it now or some rule may stop parsing, and calculate + ;; a wrong indentation for nested switches + (:switch :eol :indent :stat) + ) + ) + ;; An open switch + (indreduce :obrace + (and + (<= c-braces 0) + (> *ind-start* *ind-offset*) + ) + ((:indent :switch :obrace) + ) + (setq + *indent* (offset-indentation *ind-offset* :resolve t) + c-case-flag nil + ) + (indent-macro-reject-left) + ) + (indreduce :obrace + (and + (<= c-braces 0) + (> *ind-start* *ind-offset*) + ) + ((:indent :switch :eol :indent :obrace) + ) + (setq + *indent* (- (offset-indentation *ind-offset* :resolve t) *base-indent*) + c-case-flag nil + ) + (and *brace-indent* (incf *indent* *base-indent*)) + (indent-macro-reject-left) + ) + ;; Before current line + (indreduce :case + (and + (or + (not *case-indent*) + (prog1 c-case-flag (setq c-case-flag t)) + ) + (<= c-braces 0) + (< *ind-offset* *ind-start*) + ) + ((:indent :case) + ) + (setq + *indent* (offset-indentation *ind-offset* :resolve t) + c-case-flag nil + ) + (indent-macro-reject-left) + ) + (indreduce :case + t + ((:c-case :expression :collon) + (:c-default :collon) + ;; Assume that it is yet being edited, or adjusting indentation + (:c-case) + (:c-default) + ) + (and (>= *ind-offset* *ind-start*) + (incf c-cases) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Handle parentheses and brackets + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Reduce matches + (indreduce :parens + t + ((:oparen (not :oparen) :cparen)) + (when + (and + (< *ind-offset* *ind-start*) + (> (+ *ind-offset* *ind-length*) *ind-start*) + ) + (setq *indent* (1+ (offset-indentation *ind-offset* :align t))) + (indent-macro-reject-left) + ) + ) + (indreduce :bracks + t + ((:obrack (not :obrack) :cbrack)) + (when + (and + (< *ind-offset* *ind-start*) + (> (+ *ind-offset* *ind-length*) *ind-start*) + ) + (setq *indent* (1+ (offset-indentation *ind-offset* :align t))) + (indent-macro-reject-left) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Assuming previous lines have correct indentation, this allows + ;; resolving the indentation fastly + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Line ended with an open brace + (indreduce :obrace + (< *ind-offset* *ind-start*) + ((:indent (or :for :while :if :else-if :else :do) :obrace) + ) + (setq *indent* (offset-indentation *ind-offset* :resolve t)) + (indent-macro-reject-left) + ) + ;; Adjust indentation level if current line starts with an open brace + (indreduce nil + (< *ind-offset* *ind-start* (+ *ind-offset* *ind-length*)) + ;; Just set initial indentation + ((:indent (or :for :while :if :else-if :else :do) :eol :indent :obrace) + ) + (setq + *indent* + (- (offset-indentation *ind-offset* :resolve t) *base-indent*) + ) + (and *brace-indent* (incf *indent* *base-indent*)) + (indent-macro-reject-left) + ) + ;; Previous rule failed, current line does not start with an open brace + (indreduce :flow + ;; first statement is in current line + (and + (<= c-braces 0) + (> (+ *ind-offset* *ind-length*) *ind-start* *ind-offset*) + ) + ((:indent (or :for :while :if :else-if :else :do) :eol :indent) + ) + (setq *indent* (offset-indentation *ind-offset* :resolve t)) + (indent-macro-reject-left) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Simplify, remove old (:eol :indent) + ;; This must be the last rule, to avoid not matching the + ;; rules for fast calculation of indentation above + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce nil + (> *ind-offset* c-prev-offset) + ((:eol :indent)) + ) + + + (indinit (c-flow 0)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; If + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indinit c-if-flow) + (indresolve :if + (and (< *ind-offset* *ind-start*) + (push c-flow c-if-flow) + (incf *indent* *base-indent*) + (incf c-flow) + ) + ) + (indresolve (:else-if :else) + (when c-if-flow + (while (< c-flow (car c-if-flow)) + (incf *indent* *base-indent*) + (incf c-flow) + ) + (or (eq *ind-token* :else-if) (pop c-if-flow)) + ) + (and (< *ind-offset* *ind-start*) + (incf *indent* *base-indent*) + (incf c-flow) + ) + ) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; For/while/do + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indinit c-do-flow) + (indresolve (:for :while :do) + (if (eq *ind-token* :do) + (and (< *ind-offset* *ind-start*) (push c-flow c-do-flow)) + (when (and c-do-flow (eq *ind-token* :while)) + (while (< c-flow (car c-do-flow)) + (incf *indent* *base-indent*) + (incf c-flow) + ) + (pop c-do-flow) + ) + ) + (and (< *ind-offset* *ind-start*) + (incf *indent* *base-indent*) + (incf c-flow) + ) + ) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Switch + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indresolve :switch + (setq c-case-flag nil) + ) + (indresolve (:case :c-case) + (if (< *ind-offset* *ind-start*) + (or c-case-flag + (setq + *indent* + (+ (offset-indentation *ind-offset* :resolve t) + *base-indent* + ) + ) + ) + (if c-case-flag + (and (= (decf c-cases) 0) + (decf *indent* *base-indent*) + ) + (or *case-indent* + (decf *indent* *base-indent*) + ) + ) + ) + (setq c-case-flag t) + ) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Braces/flow control + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indresolve :flow + (incf *indent* *base-indent*) + ) + (indresolve :obrace + (and (< *ind-offset* *ind-start*) + (incf *indent* *base-indent*) + ) + ) + (indresolve :cbrace + (decf *indent* *base-indent*) + (and *case-indent* c-case-flag + (decf *indent* *base-indent*) + (setq c-case-flag nil) + ) + (and (not *offset*) (>= *ind-offset* *ind-start*) + (setq *offset* *ind-offset*) + ) + ) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Statements + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indresolve :stat + (when (< *ind-offset* *ind-start*) + (while (> c-flow 0) + (setq + *indent* (- *indent* *base-indent*) + c-flow (1- c-flow) + ) + ) + ) + (and + *cont-indent* + (< *ind-offset* *ind-start*) + (> (+ *ind-offset* *ind-length*) *ind-start*) + (incf *indent* *base-indent*) + ) + ) + + (indresolve :expression + (and + *cont-indent* + (zerop c-bra) + (> *indent* 0) + (< *ind-offset* *ind-start*) + (> (+ *ind-offset* *ind-length*) *ind-start*) + (incf *indent* *base-indent*) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Open + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indresolve (:oparen :obrack) + (and (< *ind-offset* *ind-start*) + (setq *indent* (1+ (offset-indentation *ind-offset* :align t))) + ) + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Find a "good" offset to start parsing backwards, so that it should +;; always generate the same results. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun c-offset-indent (&aux char (point (point))) + ;; Skip spaces forward + (while (member (setq char (char-after point)) indent-spaces) + (incf point) + ) + (or (characterp char) (return-from c-offset-indent point)) + + ;; Skip word chars + (when (alphanumericp char) + (while (and (setq char (char-after point)) (alphanumericp char)) + (incf point) + ) + (or (characterp char) (return-from c-offset-indent point)) + + ;; Skip spaces forward + (while (member (setq char (char-after point)) indent-spaces) + (incf point) + ) + (or (characterp char) (return-from c-offset-indent point)) + ) + + ;; don't include " or ' to avoid parsing strings "inverted" + (if (member char '(#\Newline #\" #\')) point (1+ point)) +) +(compile 'c-offset-indent) + +(defun c-should-indent (options) + (when (hash-table-p options) + ;; check if previous line has extra spaces + (and (gethash :trim-blank-lines options) + (indent-clear-empty-line) + ) + + ;; indentation disabled? + (and (gethash :disable-indent options) + (return-from c-should-indent) + ) + + (let* + ( + (point (point)) + (start (scan point :eol :left)) + (char (char-before point)) + offset + match + text + ) + + ;; at the start of an empty file + (or (characterp char) + (return-from c-should-indent) + ) + + ;; if at bol and should indent only when starting a line + (and (gethash :only-newline-indent options) + (return-from c-should-indent (= point start)) + ) + + (and + (char= char #\;) + (gethash :newline-after-semi options) + (return-from c-should-indent t) + ) + + ;; if one of these was typed, must check indentation + (and (member char '(#\{ #\} #\: #\] #\) #\#)) + (return-from c-should-indent t) + ) + + ;; at the start of a line + (and (= point start) + (return-from c-should-indent (gethash :newline-indent options)) + ) + + ;; if first character + (and (= point (1+ start)) + (return-from c-should-indent t) + ) + + ;; check if is the first non-blank character in a new line + (when + (and + (gethash :cont-indent options) + (= point (scan point :eol :right)) + (alphanumericp char) + ) + (setq offset (1- point)) + (while + (and + (> offset start) + (member (char-before offset) indent-spaces) + ) + (decf offset) + ) + ;; line has only one character with possible spaces before it + (and (<= offset start) + (return-from c-should-indent t) + ) + ) + + ;; check for keywords that change indentation + (when (alphanumericp char) + (setq offset (1- point)) + (while + (and + (alphanumericp (char-before offset)) + (> offset start) + ) + (decf offset) + ) + (setq + text (read-text offset (- point offset)) + match (re-exec #.(re-comp "(case|else|while)\\w?\\>") + text) + ) + (and + (consp match) + (return-from c-should-indent (<= (- (caar match) offset) 2)) + ) + ) + ) + ) + ;; Should not indent + nil +) +(compile 'c-should-indent) + + +(defun c-indent-check (syntax syntable options + &aux start point char left brace change) + (setq + point (point) + char (char-before point) + left point + brace (member char '(#\{ #\})) + ) + + (when + (and brace (gethash :newline-before-brace options)) + (setq start (scan point :eol :left)) + (while + (and + (> (decf left) start) + (member (char-before left) indent-spaces) + ) + ;; skip blanks + ) + (when (> left start) + (replace-text left left (string #\Newline)) + (c-indent syntax syntable) + (setq change t) + ) + ) + + (when + (or + (and brace (not change) (gethash :newline-after-brace options)) + (and (char= char #\;) (gethash :newline-after-semi options)) + ) + (setq left (point)) + (replace-text left left (string #\Newline)) + (goto-char (1+ left)) + (c-indent syntax syntable) + ) +) + +(defun c-indent (syntax syntable) + (let* + ( + (options (syntax-options syntax)) + *base-indent* + *brace-indent* + *case-indent* + *label-dedent* + *cont-indent* + ) + + (or (c-should-indent options) (return-from c-indent)) + + (setq + *base-indent* (gethash :indentation options 4) + *brace-indent* (gethash :brace-indent options nil) + *case-indent* (gethash :case-indent options t) + *label-dedent* (gethash :label-dedent options t) + *cont-indent* (gethash :cont-indent options t) + ) + + (indent-macro + *c-mode-indent* + (c-offset-indent) + (gethash :emulate-tabs options) + ) + + (c-indent-check syntax syntable options) + ) +) +(compile 'c-indent) + +(defsyntax *c-mode* :main nil #'c-indent *c-mode-options* + ;; All recognized C keywords. + (syntoken + (string-concat + "\\<(" + "asm|auto|break|case|catch|char|class|const|continue|default|" + "delete|do|double|else|enum|extern|float|for|friend|goto|if|" + "inline|int|long|new|operator|private|protected|public|register|" + "return|short|signed|sizeof|static|struct|switch|template|this|" + "throw|try|typedef|union|unsigned|virtual|void|volatile|while" + ")\\>") + :property *prop-keyword*) + + ;; Numbers, this is optional, comment this rule if xedit is + ;; too slow to load c files. + (syntoken + (string-concat + "\\<(" + ;; Integers + "(\\d+|0x\\x+)(u|ul|ull|l|ll|lu|llu)?|" + ;; Floats + "\\d+\\.?\\d*(e[+-]?\\d+)?[lf]?" + ")\\>") + :icase t + :property *prop-number* + ) + + ;; String start rule. + (syntoken "\"" :nospec t :begin :string :contained t) + + ;; Character start rule. + (syntoken "'" :nospec t :begin :character :contained t) + + ;; Preprocessor start rule. + (syntoken "^\\s*#\\s*\\w+" :begin :preprocessor :contained t) + + ;; Comment start rule. + (syntoken "/*" :nospec t :begin :comment :contained t) + + ;; C++ style comments. + (syntoken "//.*" :property *prop-comment*) + + ;; Punctuation, this is also optional, comment this rule if xedit is + ;; too slow to load c files. + (syntoken "[][(){}/*+:;=<>,&.!%|^~?-][][(){}*+:;=<>,&.!%|^~?-]?" + :property *prop-punctuation*) + + + ;; Rules for comments. + (syntable :comment *prop-comment* #'default-indent + ;; Match nested comments as an error. + (syntoken "/*" :nospec t :property *prop-error*) + + (syntoken "XXX|TODO|FIXME" :property *prop-annotation*) + + ;; Rule to finish a comment. + (syntoken "*/" :nospec t :switch -1) + ) + + ;; Rules for strings. + (syntable :string *prop-string* #'default-indent + ;; Ignore escaped characters, this includes \". + (syntoken "\\\\.") + + ;; Match, most, printf arguments. + (syntoken "%%|%([+-]?\\d+)?(l?[deEfgiouxX]|[cdeEfgiopsuxX])" + :property *prop-format*) + + ;; Ignore continuation in the next line. + (syntoken "\\\\$") + + ;; Rule to finish a string. + (syntoken "\"" :nospec t :switch -1) + + ;; Don't allow strings continuing in the next line. + (syntoken ".?$" :begin :error) + ) + + ;; Rules for characters. + (syntable :character *prop-constant* nil + ;; Ignore escaped characters, this includes \'. + (syntoken "\\\\.") + + ;; Ignore continuation in the next line. + (syntoken "\\\\$") + + ;; Rule to finish a character constant. + (syntoken "'" :nospec t :switch -1) + + ;; Don't allow constants continuing in the next line. + (syntoken ".?$" :begin :error) + ) + + ;; Rules for preprocessor. + (syntable :preprocessor *prop-preprocessor* #'default-indent + ;; Preprocessor includes comments. + (syntoken "/*" :nospec t :begin :comment :contained t) + + ;; Ignore lines finishing with a backslash. + (syntoken "\\\\$") + + ;; Return to previous state if end of line found. + (syntoken ".?$" :switch -1) + ) + + (syntable :error *prop-error* nil + (syntoken "^.*$" :switch -2) + ) + + ;; You may also want to comment this rule if the parsing is + ;; noticeably slow. + (syntoken "\\c" :property *prop-control*) +) diff --git a/lisp/modules/progmodes/html.lsp b/lisp/modules/progmodes/html.lsp new file mode 100644 index 0000000..86f8eea --- /dev/null +++ b/lisp/modules/progmodes/html.lsp @@ -0,0 +1,327 @@ +;; +;; 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/progmodes/html.lsp,v 1.3 2002/10/06 17:11:48 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +#| + This is not a validation tool for html. + + It is possible to, using macros generate all combinations of text attributes, + to properly handle ......... etc, as well as generating macros + to automatically closing tags, but for now this file was built to work as an + experience with the syntax highlight code. +|# + +(defsynprop *prop-html-default* + "default" + :font "-*-lucida-medium-r-*-*-14-*-*-*-*-*-*-1" + :foreground "Gray10") + +(defsynprop *prop-html-bold* + "bold" + :font "-*-lucida-bold-r-*-*-14-*-*-*-*-*-*-1" + :foreground "Gray15") + +(defsynprop *prop-html-italic* + "italic" + :font "-*-lucida-medium-i-*-*-14-*-*-*-*-*-*-1" + :foreground "Gray10") + +(defsynprop *prop-html-pre* + "pre" + :font "-*-courier-medium-r-*-*-14-*-*-*-*-*-*-1" + :foreground "Gray10") + +(defsynprop *prop-html-link* + "link" + :font "-*-lucida-medium-r-*-*-14-*-*-*-*-*-*-1" + :foreground "Blue" + :underline "t") + +(defsynprop *prop-html-small* + "small" + :font "-*-lucida-medium-r-*-*-10-*-*-*-*-*-*-1" + :foreground "Gray10") + +(defsynprop *prop-html-big* + "big" + :font "-*-lucida-medium-r-*-*-20-*-*-*-*-*-*-1" + :foreground "Gray15") + +(defsynprop *prop-html-name* + "name" + :font "-*-lucida-bold-r-*-*-14-*-*-*-*-*-*-1" + :foreground "Black" + :background "rgb:e/f/e") + +(defsynprop *prop-html-h1* + "h1" + :font "-*-lucida-bold-r-*-*-20-*-*-*-*-*-*-1" + :foreground "Gray15") + +(defsynprop *prop-html-h2* + "h2" + :font "-*-lucida-bold-r-*-*-17-*-*-*-*-*-*-1" + :foreground "Gray15") + +(defsynprop *prop-html-h4* + "h4" + :font "-*-lucida-bold-r-*-*-12-*-*-*-*-*-*-1" + :foreground "Gray15") + +(defsynprop *prop-html-h5* + "h5" + :font "-*-lucida-bold-r-*-*-10-*-*-*-*-*-*-1" + :foreground "Gray15") + +(defsynprop *prop-html-li* + "li" + :font "-*-lucida-bold-r-*-*-8-*-*-*-*-*-*-1" + :foreground "rgb:0/5/0" + :underline t) + +(defsynprop *prop-html-hr* + "hr" + :font "-*-courier-bold-r-*-*-12-*-*-*-*-*-*-1" + :foreground "rgb:0/5/0" + :overstrike t) + +(defsynprop *prop-html-title* + "title" + :font "-*-lucida-medium-r-*-*-14-*-*-*-*-*-*-1" + :foreground "Red3" + :underline "t") + +(defsynprop *prop-html-tag* + "tag" + :font "-*-courier-medium-r-*-*-10-*-*-*-*-*-*-1" + :foreground "green4") + +(defsynprop *prop-html-string* + "string" + :font "-*-lucida-medium-r-*-*-10-*-*-*-*-*-*-1" + :foreground "RoyalBlue2") + +(defsynprop *prop-html-comment* + "comment" + :font "-*-courier-medium-o-*-*-10-*-*-*-*-*-*-1" + :foreground "SlateBlue3") + +(defsynprop *prop-html-entity* + "entity" + :font "-*-lucida-medium-r-*-*-12-*-*-*-*-*-*-1" + :foreground "Red4") + +(defsynprop *prop-html-unknown* + "unknown" + :font "-*-courier-bold-r-*-*-10-*-*-*-*-*-*-1" + :foreground "yellow" + :background "red") + +(defmacro html-syntoken (name) + `(syntoken (string-concat "<" ,name "\\>") + :icase t :contained t + :begin (intern (string-concat ,name "$") 'keyword))) +(defmacro html-syntable (name property) + `(let + ((label (intern (string-concat ,name "$") 'keyword)) + (nested-label (intern (string (gensym)) 'keyword))) + (syntable label *prop-html-tag* nil + (synaugment :generic-tag) + (syntoken ">" :nospec t :property *prop-html-tag* :begin nested-label) + (syntable nested-label ,property nil + (syntoken (string-concat "") + :icase t :nospec t :property *prop-html-tag* :switch -2) + (syntoken (string-concat "" :nospec t :switch -1)) + (syntoken "&([a-zA-Z0-9_.-]+|#\\x\\x?);?" :property *prop-html-entity*) + (syntoken "
  • " :nospec t :icase t :property *prop-html-li*) + (syntoken "
    " :nospec t :icase t :property *prop-html-hr*) + + (syntoken "" :icase t :contained t :begin :tag) + (syntoken "<(p|br)>" :icase t :property *prop-html-tag*) + + ;; If in the toplevel, unbalanced! + ;; XXX When adding new nested tables, don't forget to update this pattern. + (syntoken + (string-concat + "") + :icase t :property *prop-html-unknown* :begin :unbalanced) + (syntable :unbalanced *prop-html-unknown* nil + (syntoken ">" :nospec t :switch :main) + (synaugment :generic-tag) + ) + + #|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + ;; XXX ONLY add a rule for "html", "head" and "body" if you want to do a + ;; more complete check for common errors. If you add those rules, it will + ;; reparse the entire file at every character typed (unless there are + ;; errors in which case the parser resets the state). + ;; For visualization only that would be OK... + ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||# + + (html-syntoken "b") + (html-syntable "b" *prop-html-bold*) + (html-syntoken "strong") + (html-syntable "strong" *prop-html-bold*) + + (html-syntoken "i") + (html-syntable "i" *prop-html-italic*) + (html-syntoken "em") + (html-syntable "em" *prop-html-italic*) + (html-syntoken "address") + (html-syntable "address" *prop-html-italic*) + + (html-syntoken "pre") + (html-syntable "pre" *prop-html-pre*) + (html-syntoken "code") + (html-syntable "code" *prop-html-pre*) + (html-syntoken "tt") + (html-syntable "tt" *prop-html-pre*) + + (html-syntoken "small") + (html-syntable "small" *prop-html-small*) + + (html-syntoken "big") + (html-syntable "big" *prop-html-big*) + + ;; Cannot hack html-syntoken and html-syntable to handle this, + ;; as the option to " :icase t :contained t :begin :a) + (syntable :a *prop-html-tag* nil + ;; Tag is open + (syntoken "\\" :icase t :begin :a-href) + (syntoken "\\" :icase t :begin :a-name) + (syntoken "<" :nospec t :property *prop-html-unknown* :switch -2) + (synaugment :generic-tag) + (syntoken ">" :nospec t :begin :a-generic-text) + (syntable :a-href *prop-html-tag* nil + (syntoken ">" :nospec t :begin :a-href-text) + (synaugment :generic-tag) + (syntable :a-href-text *prop-html-link* nil + (syntoken "" + :icase t :nospec t :property *prop-html-tag* :switch -3) + (syntoken "" :nospec t :begin :a-name-text) + (synaugment :generic-tag) + (syntable :a-name-text *prop-html-name* nil + (syntoken "" + :icase t :nospec t :property *prop-html-tag* :switch -3) + (syntoken "" + :icase t :nospec t :property *prop-html-tag* :switch -2) + (syntoken " and
    should be in a special table, to not require + ;; and ending tag. + ;; XXX Maybe should also add a table for

    . + (html-syntoken "dt") + (html-syntable "dt" nil) + (html-syntoken "dd") + (html-syntable "dd" nil) + + (html-syntoken "span") + (html-syntable "span" nil) + (html-syntoken "div") + (html-syntable "div" nil) + (html-syntoken "menu") + (html-syntable "menu" nil) + + (html-syntoken "h1") + (html-syntable "h1" *prop-html-h1*) + (html-syntoken "h2") + (html-syntable "h2" *prop-html-h2*) + (html-syntoken "h3") + (html-syntable "h3" *prop-html-bold*) + (html-syntoken "h4") + (html-syntable "h4" *prop-html-h4*) + (html-syntoken "h5") + (html-syntable "h5" *prop-html-h5*) + (html-syntoken "title") + (html-syntable "title" *prop-html-title*) + + (html-syntoken "font") + (html-syntable "font" *prop-control*) + + (syntoken "<" :nospec t :contained t :begin :tag) + (syntable :generic-tag *prop-html-tag* nil + (syntoken "\"" :nospec t :contained t :begin :string) + (syntoken "<" :nospec t :property *prop-html-unknown*) + ) + (syntable :tag *prop-html-tag* nil + (syntoken ">" :nospec t :switch -1) + (synaugment :generic-tag) + ) + ;; Tag ended in a newline, common practice... + (syntable :continued-end-tag *prop-html-tag* nil + (syntoken ">" :nospec t :switch -3) + (synaugment :generic-tag) + ) + (syntable :continued-nested-end-tag *prop-html-tag* nil + (syntoken ">" :nospec t :switch -4) + (synaugment :generic-tag) + ) + + (syntable :string *prop-html-string* nil + (syntoken "\\\\.") + (syntoken "\"" :nospec t :switch -1) + ) +) diff --git a/lisp/modules/progmodes/imake.lsp b/lisp/modules/progmodes/imake.lsp new file mode 100644 index 0000000..ea34ed6 --- /dev/null +++ b/lisp/modules/progmodes/imake.lsp @@ -0,0 +1,188 @@ +;; +;; 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/progmodes/imake.lsp,v 1.2 2002/10/06 17:11:48 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +(defsynprop *prop-shell* + "shell" + :font "*courier-bold-r*12*" + :foreground "Red4" +) + +(defsynprop *prop-variable* + "variable" + :font "*courier-medium-r*12*" + :foreground "Red3" +) + +;; The syntax-highlight definition does not try to flag errors, just show +;; tabs in the start of lines for better visualization. +(defsynprop *prop-tabulation* + "tabulation" + :font "*courier-medium-r*12*" + :background "Gray90" +) + +(defsynprop *prop-xcomm* + "xcomm" + :font "*courier-medium-o*12*" + :foreground "SkyBlue4" +) + + +(defsyntax *imake-mode* :main nil nil nil + (syntoken "^\\s*XCOMM\\W?.*$" + :property *prop-xcomm*) + + (syntoken "^\\t+" + :property *prop-tabulation*) + + (syntoken "$(" + :nospec t + :begin :shell + :property *prop-shell*) + + (syntoken "[][(){};$<=>&@/\\,.:~!|*?'`+-]" + :property *prop-shell*) + + ;; Preprocessor start rule. + (syntoken "^\\s*#\\s*\\w+" + :begin :preprocessor + :contained t) + + ;; Comment start rule. + (syntoken "/*" + :nospec t + :begin :comment + :contained t) + + ;; String start rule. + (syntoken "\"" + :begin :string + :nospec t + :contained t) + + ;; Quoted string start rule. + (syntoken "\\\"" + :begin :quoted-string + :nospec t + :contained t) + + (syntable :shell *prop-variable* nil + (syntoken ")" + :nospec t + :property *prop-shell* + :switch -1) + ) + + ;; Rules for comments. + (syntable :comment *prop-comment* nil + + ;; Match nested comments as an error. + (syntoken "/*" + :nospec t + :property *prop-error*) + + (syntoken "XXX|TODO|FIXME" + :property *prop-annotation*) + + ;; Rule to finish a comment. + (syntoken "*/" + :nospec t + :switch -1) + ) + + ;; Rules for preprocessor. + (syntable :preprocessor *prop-preprocessor* nil + + ;; Preprocessor includes comments. + (syntoken "/*" + :nospec t + :begin :comment + :contained t) + + ;; Visualization help, show tabs in the start of lines. + (syntoken "^\\t+" + :property *prop-tabulation*) + + ;; Ignore lines finishing with a backslash. + (syntoken "\\\\$") + + ;; Return to previous state if end of line found. + (syntoken ".?$" + :switch -1) + ) + + ;; Rules for strings. + (syntable :string *prop-string* nil + + ;; Ignore escaped characters, this includes \". + (syntoken "\\\\.") + + ;; Ignore continuation in the next line. + (syntoken "\\\\$") + + ;; Rule to finish a string. + (syntoken "\"" + :nospec t + :switch -1) + + ;; Don't allow strings continuing in the next line. + (syntoken ".?$" + :begin :error) + ) + + ;; Rules for quoted strings. + (syntable :quoted-string *prop-constant* nil + + ;; Rule to finish the quoted string. + (syntoken "\\\"" + :nospec t + :switch -1) + + ;; Ignore escaped characters + (syntoken "\\\\.") + + ;; Ignore continuation in the next line. + (syntoken "\\\\$") + + ;; Don't allow strings continuing in the next line. + (syntoken ".?$" + :begin :error) + ) + + (syntable :error *prop-error* nil + (syntoken "^.*$" + :switch -2) + ) +) diff --git a/lisp/modules/progmodes/lisp.lsp b/lisp/modules/progmodes/lisp.lsp new file mode 100644 index 0000000..ebf2c10 --- /dev/null +++ b/lisp/modules/progmodes/lisp.lsp @@ -0,0 +1,384 @@ +;; +;; 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/progmodes/lisp.lsp,v 1.9 2003/01/30 02:46:26 paulo Exp $ +;; + +(require "syntax") +(require "indent") +(in-package "XEDIT") + +(defsynprop *prop-special* + "special" + :font "*courier-bold-r*12*" + :foreground "NavyBlue" +) + +(defsynprop *prop-quote* + "quote" + :font "*courier-bold-r*12*" + :foreground "Red3" +) + +(defsynprop *prop-package* + "package" + :font "*lucidatypewriter-medium-r*12*" + :foreground "Gold4" +) + +(defsynprop *prop-unreadable* + "unreadable" + :font "*courier-medium-r*12*" + :foreground "Gray25" + :underline t +) + +(defsynoptions *lisp-DEFAULT-style* + ;; Positive number. Basic indentation. + (:indentation . 2) + + ;; Boolean. Move cursor to the indent column after pressing ? + (:newline-indent . t) + + ;; Boolean. Use spaces instead of tabs to fill indentation? + (:emulate-tabs . nil) + + ;; Boolean. Remove extra spaces from previous line. + ;; This should default to T when newline-indent is not NIL. + (:trim-blank-lines . t) + + ;; Boolean. If this hash-table entry is set, no indentation is done. + ;; Useful to temporarily disable indentation. + (:disable-indent . nil) +) + +(defvar *lisp-mode-options* *lisp-DEFAULT-style*) + +(defindent *lisp-mode-indent* :main + ;; this must be the first token + (indtoken "^\\s*" :indent + :code (or *offset* (setq *offset* (+ *ind-offset* *ind-length*)))) + ;; ignore single line comments + (indtoken ";.*$" nil) + ;; multiline comments + (indtoken "|#" :comment :nospec t :begin :comment) + ;; characters + (indtoken "#\\\\(\\W|\\w+(-\\w+)?)" :character) + ;; numbers + (indtoken + (string-concat + "(\\<|[+-])\\d+(" + ;; integers + "(\\>|\\.(\\s|$))|" + ;; ratios + "/\\d+\\>|" + ;;floats + "\\.?\\d*([SsFfDdLlEe][+-]?\\d+)?\\>" + ")") + :number) + ;; symbols, with optional package + (indtoken + (string-concat + ;; optional package name and ending ':' + "([A-Za-z_0-9%-]+:)?" + ;; internal symbol if after package name, or keyword + ":?" + ;; symbol name + "[][{}A-Za-z_0-9!$%&/<=>^~*+-]+") + :symbol) + ;; strings in the same line + (indtoken "\"([^\\\"]|\\\\.)*\"" :string) + ;; multiline strings + (indtoken "\"" :cstring :nospec t :begin :string) + ;; "quoted" symbols in the same line + (indtoken "\\|([^\\|]|\\\\.)*\\|" :symbol) + ;; multiline + (indtoken "|" :csymbol :nospec t :begin :symbol) + (indtoken "#" :hash :nospec t) + + (indinit (parens 0)) + (indtoken "(" :oparen :nospec t :code (incf parens)) + (indtoken ")" :cparen :nospec t :code (decf parens)) + + (indtable :comment + ;; multiline comments can nest + (indtoken "|#" nil :nospec t :begin :comment) + (indtoken "#|" nil :nospec t :switch -1)) + + (indtable :string + ;; Ignore escaped characters + (indtoken "\\." nil) + ;; Return to the toplevel when the start of the string is found + (indtoken "\"" :ostring :nospec t :switch -1)) + + (indtable :symbol + ;; Ignore escaped characters + (indtoken "\\." nil) + ;; Return to the toplevel when the start of the symbol is found + (indtoken "|" :osymbol :nospec t :switch -1)) + + ;; ignore comments + (indreduce nil + t + ((:comment))) + + ;; reduce multiline strings + (indreduce :string + t + ((:ostring (not :ostring) :cstring))) + + ;; reduce multiline symbols + (indreduce :symbol + t + ((:osymbol (not :osymbol) :csymbol))) + + ;; reduce basic types, don't care if inside list or not + (indreduce :element + t + ((:number) + (:string) + (:character) + (:element :element) + (:indent :element))) + + (indreduce :symbol + t + ((:symbol :symbol) + (:symbol :element) + (:indent :symbol))) + + ;; the "real" indentation value, to make easier parsing code like: + ;; (foo (bar (baz (blah + ;; ^ ^ + ;; | | + ;; indent | + ;; effective indentation to be used + (indinit (indent 0)) + + ;; indentation values of opening parenthesis. + (indinit stack) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; if before current line and open parenthesis >= 0, use indentation + ;; of current line to calculate relative indentation. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (indreduce :oparen ;; simple list? + (and (>= parens 0) (< *ind-offset* *ind-start*)) + ((:indent :oparen)) + (setq + *indent* (offset-indentation (+ *ind-offset* *ind-length*) :resolve t) + indent *indent*) + (indent-macro-reject-left)) + + ;; reduce list if there isn't indentation change + (indreduce :element + t + ((:oparen (not :oparen) :cparen))) + + (indresolve :oparen + (setq + *indent* + (offset-indentation + (+ *ind-offset* *ind-length* -1 *base-indent*) :align t)) + (push *indent* stack) + (incf indent *base-indent*) + (if (< *indent* indent) (setq *indent* indent))) + + (indresolve :cparen + (decf indent *base-indent*) + (setq *indent* (pop stack)) + (if (null stack) + (setq *indent* indent) + (setq *indent* (car stack)))) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Find a "good" offset to start parsing backwards, so that it should +;; always generate the same results. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun lisp-offset-indent (&aux char (point (scan (point) :eol :left))) + ;; skip spaces + (while (member (setq char (char-after point)) indent-spaces) + (incf point)) + (if (member char '(#\))) (1+ point) point)) + +(defun lisp-should-indent (options &aux char point start) + (when (hash-table-p options) + ;; check if previous line has extra spaces + (and (gethash :trim-blank-lines options) + (indent-clear-empty-line)) + + ;; indentation disabled? + (and (gethash :disable-indent options) + (return-from lisp-should-indent)) + + (setq + point (point) + char (char-before (point)) + start (scan point :eol :left)) + + ;; at the start of a line + (and (= point start) + (return-from lisp-should-indent (gethash :newline-indent options))) + + ;; if first character + (and (= point (1+ start)) (return-from lisp-should-indent t)) + + ;; if closing parenthesis and first nonblank char + (when (and (characterp char) (char= char #\))) + (decf point) + (while + (and (> point start) (member (char-before point) indent-spaces)) + (decf point)) + (return-from lisp-should-indent (<= point start))) + ) + ;; should not indent + nil) + +(defun lisp-indent (syntax syntable) + (let* + ((options (syntax-options syntax)) + *base-indent*) + + (or (lisp-should-indent options) (return-from lisp-indent)) + + (setq *base-indent* (gethash :indentation options 2)) + + (indent-macro + *lisp-mode-indent* + (lisp-offset-indent) + (gethash :emulate-tabs options)))) + +(compile 'lisp-indent) + +(defsyntax *lisp-mode* :main nil #'lisp-indent *lisp-mode-options* + ;; highlight car and parenthesis + (syntoken "\\(+\\s*[][{}A-Za-z_0-9!$%&/<=>?^~*:+-]*\\)*" + :property *prop-keyword*) + (syntoken "\\)+" :property *prop-keyword*) + + ;; nil and t + (syntoken "\\<(nil|t)\\>" :icase t :property *prop-special*) + + (syntoken "|" :nospec t :begin :unreadable :contained t) + + ;; keywords + (syntoken ":[][{}A-Za-z_0-9!$%&/<=>^~+-]+" :property *prop-constant*) + + ;; special symbol. + (syntoken "\\*[][{}A-Za-z_0-9!$%&7=?^~+-]+\\*" + :property *prop-special*) + + ;; special identifiers + (syntoken "&(aux|key|optional|rest)\\>" :icase t :property *prop-constant*) + + ;; numbers + (syntoken + ;; since lisp is very liberal in what can be a symbol, this pattern + ;; will not always work as expected, since \< and \> will not properly + ;; work for all characters that may be in a symbol name + (string-concat + "(\\<|[+-])\\d+(" + ;; integers + "(\\>|\\.(\\s|$))|" + ;; ratios + "/\\d+\\>|" + ;;floats + "\\.?\\d*([SsFfDdLlEe][+-]?\\d+)?\\>" + ")") + :property *prop-number*) + + ;; characters + (syntoken "#\\\\(\\W|\\w+(-\\w+)?)" :property *prop-constant*) + + ;; quotes + (syntoken "[`'.]|,@?" :property *prop-quote*) + + ;; package names + (syntoken "[A-Za-z_0-9%-]+::?" :property *prop-package*) + + ;; read time evaluation + (syntoken "#\\d+#" :property *prop-preprocessor*) + (syntoken "#([+'cCsS-]|\\d+[aA=])?" :begin :preprocessor :contained t) + + (syntoken "\\c" :property *prop-control*) + + ;; symbols, do nothing, just resolve conflicting matches + (syntoken "[][{}A-Za-z_0-9!$%&/<=>^~*+-]+") + + (syntable :simple-comment *prop-comment* nil + (syntoken "$" :switch -1) + (syntoken "XXX|FIXME|TODO" :property *prop-annotation*)) + + (syntable :comment *prop-comment* nil + ;; comments can nest + (syntoken "#|" :nospec t :begin :comment) + ;; return to previous state + (syntoken "|#" :nospec t :switch -1) + (syntoken "XXX|FIXME|TODO" :property *prop-annotation*)) + + (syntable :unreadable *prop-unreadable* nil + ;; ignore escaped characters + (syntoken "\\\\.") + (syntoken "|" :nospec t :switch -1)) + + (syntable :string *prop-string* nil + ;; ignore escaped characters + (syntoken "\\\\.") + (syntoken "\"" :nospec t :switch -1)) + + (syntable :preprocessor *prop-preprocessor* nil + ;; a symbol + (syntoken "[][{}A-Za-z_0-9!$%&/<=>^~:*+-]+" :switch -1) + + ;; conditional expression + (syntoken "(" :nospec t :begin :preprocessor-expression :contained t) + + (syntable :preprocessor-expression *prop-preprocessor* nil + ;; recursive + (syntoken "(" :nospec t :begin :preprocessor-recursive :contained t) + (syntoken ")" :nospec t :switch -2) + + (syntable :preprocessor-recursive *prop-preprocessor* nil + (syntoken "(" :nospec t + :begin :preprocessor-recursive + :contained t) + (syntoken ")" :nospec t :switch -1) + (synaugment :comments-and-strings)) + (synaugment :comments-and-strings)) + (synaugment :comments-and-strings)) + + (syntable :comments-and-strings nil nil + (syntoken "\"" :nospec t :begin :string :contained t) + (syntoken "#|" :nospec t :begin :comment :contained t) + (syntoken ";" :begin :simple-comment :contained t)) + + (synaugment :comments-and-strings) +) diff --git a/lisp/modules/progmodes/make.lsp b/lisp/modules/progmodes/make.lsp new file mode 100644 index 0000000..d5cbc00 --- /dev/null +++ b/lisp/modules/progmodes/make.lsp @@ -0,0 +1,135 @@ +;; +;; 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/progmodes/make.lsp,v 1.2 2002/10/06 17:11:48 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +(defsynprop *prop-shell* + "shell" + :font "*courier-bold-r*12*" + :foreground "Red4" +) + +(defsynprop *prop-variable* + "variable" + :font "*courier-medium-r*12*" + :foreground "Red3" +) + +;; The syntax-highlight definition does not try to flag errors, just show +;; tabs in the start of lines for better visualization. +(defsynprop *prop-tabulation* + "tabulation" + :font "*courier-medium-r*12*" + :background "Gray90" +) + + +(defsyntax *make-mode* :main nil nil nil + (syntoken "^\\t+" :property *prop-tabulation*) + + (syntoken "^\\.\\w+" :property *prop-keyword*) + + (syntoken "$(" + :nospec t + :begin :shell + :property *prop-shell*) + + (syntoken "[][(){};$<=>&@/\\,.:~!|*?'`+-]" + :property *prop-shell*) + + ;; Preprocessor start rule. + (syntoken "#.*" + :property *prop-comment*) + + ;; String start rule. + (syntoken "\"" + :begin :string + :nospec t + :contained t) + + ;; Quoted string start rule. + (syntoken "\\\"" + :begin :quoted-string + :nospec t + :contained t) + + (syntable :shell *prop-variable* nil + (syntoken ")" + :nospec t + :property *prop-shell* + :switch -1) + ) + + ;; Rules for strings. + (syntable :string *prop-string* nil + + ;; Ignore escaped characters, this includes \". + (syntoken "\\\\.") + + ;; Ignore continuation in the next line. + (syntoken "\\\\$") + + ;; Rule to finish a string. + (syntoken "\"" + :nospec t + :switch -1) + + ;; Don't allow strings continuing in the next line. + (syntoken ".?$" + :begin :error) + ) + + ;; Rules for quoted strings. + (syntable :quoted-string *prop-constant* nil + + ;; Rule to finish the quoted string. + (syntoken "\\\"" + :nospec t + :switch -1) + + ;; Ignore escaped characters + (syntoken "\\\\.") + + ;; Ignore continuation in the next line. + (syntoken "\\\\$") + + ;; Don't allow strings continuing in the next line. + (syntoken ".?$" + :begin :error) + ) + + (syntable :error *prop-error* nil + (syntoken "^.*$" + :switch -2) + ) +) diff --git a/lisp/modules/progmodes/man.lsp b/lisp/modules/progmodes/man.lsp new file mode 100644 index 0000000..77a59a8 --- /dev/null +++ b/lisp/modules/progmodes/man.lsp @@ -0,0 +1,160 @@ +;; +;; 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/progmodes/man.lsp,v 1.2 2002/10/06 17:11:48 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +(defsynprop *prop-man-b* + "b" + :font "*courier-bold-r*12*" + :foreground "gray12" +) + +(defsynprop *prop-man-i* + "i" + :font "*courier-medium-o*12*" + :foreground "black" +) + +(defsynprop *prop-man-bi* + "bi" + :font "*courier-bold-o*12*" + :foreground "gray20" +) + +(defsynprop *prop-man-th* + "th" + :font "-*-courier-*-*-*-*-18-*-*-*-*-*-*-1" + :foreground "Red3" +) + +(defsynprop *prop-man-sh* + "sh" + :font "-*-courier-*-*-*-*-14-*-*-*-*-*-*-1" + :foreground "OrangeRed3" +) + +(defsynprop *prop-man-ss* + "ss" + :font "-*-courier-*-*-*-*-12-*-*-*-*-*-*-1" + :foreground "Gold4" +) + +(defsynprop *prop-man-escape* + "escape" + :font "*lucidatypewriter-medium-r*12*" + :foreground "RoyalBlue4" +) + +(defsynprop *prop-man-string* + "string" + :font "*lucidatypewriter-bold-r*12*" + :foreground "RoyalBlue3" +; :underline t +) + +(defmacro man-syntoken (pattern) + `(syntoken (string-concat "^\\.(" ,pattern ")(\\s+|$)") + :icase t +; :contained t + :property *prop-preprocessor* + :begin (intern (string ,pattern) 'keyword))) + +(defmacro man-syntable (pattern property) + `(syntable (intern (string ,pattern) 'keyword) ,property nil + (syntoken "$" :switch -1) + (synaugment :extras))) + + +(defsyntax *man-mode* :main nil nil nil + (syntoken "^\\.\\\\\".*" + :property *prop-comment*) + + (man-syntoken "b|br|nm") + (man-syntable "b|br|nm" *prop-man-b*) + + (man-syntoken "i|ir|ri|ip") + (man-syntable "i|ir|ri|ip" *prop-man-i*) + + (man-syntoken "th|dt") + (man-syntable "th|dt" *prop-man-th*) + + (man-syntoken "sh") + (man-syntable "sh" *prop-man-sh*) + + (man-syntoken "ss") + (man-syntable "ss" *prop-man-ss*) + + (man-syntoken "bi") + (man-syntable "bi" *prop-man-bi*) + + ;; Anything not matched... + (syntoken "^\\.[a-z][a-z](\\s+|$)" + :icase t + :property *prop-preprocessor*) + + (syntable :extras nil nil + (syntoken "\\<__\\l+__\\>" + :property *prop-constant*) + (syntoken "\\\\fB" + :property *prop-preprocessor* + :begin :b) + (syntoken "\\\\fI" + :property *prop-preprocessor* + :begin :i) + (syntoken "\\\\f\\u" + :property *prop-preprocessor*) + + (syntoken "\\\\\\*?." + :property *prop-man-escape*) + + (syntoken "\"" + :property *prop-man-string*) + + (syntable :i *prop-man-i* nil + (syntoken "$" + :switch :main) + (syntoken "\\\\f\\u" + :property *prop-preprocessor* + :switch -1) + ) + (syntable :b *prop-man-b* nil + (syntoken "$" + :switch :main) + (syntoken "\\\\f\\u" + :property *prop-preprocessor* + :switch -1) + ) + ) + + (synaugment :extras) +) diff --git a/lisp/modules/progmodes/rpm.lsp b/lisp/modules/progmodes/rpm.lsp new file mode 100644 index 0000000..bd0cc6c --- /dev/null +++ b/lisp/modules/progmodes/rpm.lsp @@ -0,0 +1,166 @@ +;; +;; Copyright (c) 2003 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/progmodes/rpm.lsp,v 1.1 2003/01/16 03:50:46 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +;; Only for testing, unifinished, good for viewing but too slow for real use... +#| +(defsynprop *prop-rpm-special* + "rpm-special" + :font "*courier-bold-r*12*" + :foreground "NavyBlue" +) + +(defsynprop *prop-rpm-escape* + "rpm-escape" + :font "*lucidatypewriter-medium-r*12*" + :foreground "Red3") + +;; main package is implicit +(defsyntax *rpm-mode* :package nil nil nil + (syntable :sections nil nil + (syntoken "^%package" + :icase t + :switch :package + ;; XXX :begin :package was added just to test finishing and + ;; starting a new syntax-table, unfortunately if using it + ;; this way, frequently the entire file will be reparsed + ;; at every character typed. + ;; TODO study these cases and implement code to avoid it, + ;; the easiest way is limiting the number of backtracked lines, + ;; the screen contents sometimes could not correctly reflect + ;; file contents in this case... + :begin :package + :property *prop-rpm-special*) + (syntoken "^%(build|setup|install|pre|preun|post|postun)\\>" + :icase t + :property *prop-rpm-special* + :switch :package + :begin :shell) + ;; %changelog, XXX no rules to return to the toplevel + (syntoken "^%changelog\\>" + :icase t + :switch :package + :begin :changelog + :property *prop-rpm-special*) + (syntable :changelog nil nil + ;; ignore if escaped + (syntoken "%%") + ;; "warn" if not escaped + (syntoken "%" :property *prop-control*) + ;; emails + (syntoken "<[a-z0-9_-]+@[a-z0-9_-]+\\.\\w+(\\.\\w+)?>" + :icase t + :property *prop-string*) + ) + ;; comments + (syntoken "#" :contained t :nospec t :begin :comment) + (syntable :comment *prop-comment* nil + ;; some macros are expanded even when inside comments, and may + ;; cause surprises, "warn" about it + (syntoken "%\\{?\\w+\\}?" :property *prop-rpm-special*) + (syntoken "$" :switch -1) + ) + (synaugment :global) + ) + + ;; may appear anywhere + (syntable :global nil nil + ;; preprocessor like commands + (syntoken "^%(define|if|ifarch|else|endif)\\>" + :icase t + :property *prop-preprocessor*) + ;; variables + (syntoken "%\\{.*\\}" :property *prop-constant*) + ) + + ;; example: "Group: ..." or "Group(pt_BR): ..." + (syntoken "^\\w+(\\(\\w+\\))?:" :property *prop-keyword*) + + ;; for sections with shell commands + (syntable :shell nil nil + (syntoken "\\<(if|then|elif|else|fi|for|do|done|case|esac|while|until)\\>" + :property *prop-keyword*) + (syntable :strings nil nil + (syntoken "\"" :nospec t :begin :string :contained t) + (syntable :string *prop-string* nil + (syntoken "\\$\\(?\\w+\\)?" :property *prop-constant*) + (syntoken "\\\\.") + (syntoken "\"" :nospec t :switch -1) + ) + (syntoken "\'" :nospec t :begin :constant :contained t) + (syntable :constant *prop-constant* nil + (syntoken "\\\\.") + (syntoken "\'" :nospec t :switch -1) + ) + (syntoken "\`" :nospec t :begin :escape :contained t) + (syntable :escape *prop-rpm-escape* nil + (syntoken "\\$\\(?\\w+\\)?" :property *prop-constant*) + (syntoken "\\\\.") + (syntoken "\`" :nospec t :switch -1) + ) + ) + (synaugment :strings :sections) + ) + (synaugment :sections) +) +|# + + +(defsyntax *rpm-mode* :package nil nil nil + ;; commands, macro definitions, etc + (syntoken "^\\s*%\\s*\\w+" :property *prop-keyword*) + + ;; rpm "variables" + (syntoken "%\\{.*\\}" :property *prop-constant*) + + ;; package info, example: "Group: ...", "Group(pt_BR): ...", etc. + (syntoken "^\\w+(\\(\\w+\\))?:" :property *prop-preprocessor*) + + ;; comments + (syntoken "#" :contained t :nospec t :begin :comment) + (syntable :comment *prop-comment* nil + ;; some macros are expanded even when inside comments, and may + ;; cause surprises, "warn" about it + (syntoken "%define\\>" :property *prop-control*) + (syntoken "%\\{?\\w+\\}?" :property *prop-string*) + (syntoken "$" :switch -1) + ) + + ;; emails + (syntoken "?" + :icase t + :property *prop-string*) + ;; links + (syntoken "\\<(http|ftp)://\\S+" :property *prop-string*) +) diff --git a/lisp/modules/progmodes/sgml.lsp b/lisp/modules/progmodes/sgml.lsp new file mode 100644 index 0000000..511aae5 --- /dev/null +++ b/lisp/modules/progmodes/sgml.lsp @@ -0,0 +1,428 @@ +;; +;; 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/progmodes/sgml.lsp,v 1.2 2002/10/06 17:11:48 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +;; Default property the text is shown. +(defsynprop *prop-sgml-default* + "default" + :font "-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-1" + :foreground "Gray10" +) + +(defsynprop *prop-sgml-default-short* + "default-short" + :font "-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-1" + :foreground "Gray10" + :underline t +) + +;; Large font. +(defsynprop *prop-sgml-sect* + "sect" + :font "-*-helvetica-bold-r-*-*-17-*-*-*-*-*-*-1" + :foreground "Gray20" +) + +;; Monospaced property. +(defsynprop *prop-sgml-tt* + "tt" + :font "-*-courier-medium-r-*-*-12-*-*-*-*-*-*-1" + :foreground "Black" +) + +;; Italic property. +(defsynprop *prop-sgml-it* + "it" + :font "-*-helvetica-medium-o-*-*-12-*-*-*-*-*-*-1" + :foreground "Black" +) + +;; Bold font property. +(defsynprop *prop-sgml-bf* + "bf" + :font "-*-helvetica-bold-r-*-*-12-*-*-*-*-*-*-1" + :foreground "Gray10" +) + +;; Looks like a link... +(defsynprop *prop-sgml-link* + "link" + :font "-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-1" + :foreground "blue" + :underline t +) + +;; Monospaced, also looks like a link... +(defsynprop *prop-sgml-email* + "email" + :font "-*-courier-medium-r-*-*-12-*-*-*-*-*-*-1" + :foreground "blue" + :underline t +) + +;; Another monospaced property, +(defsynprop *prop-sgml-screen* + "screen" + :font "-*-fixed-*-*-*-*-*-*-*-*-*-*-*-1" + :foreground "Gray10" +) + +(defsynprop *prop-sgml-maybe-entity* + "maybe-entity" + :font "*lucidatypewriter-medium-r*12*" + :foreground "VioletRed4" + :background "LightYellow" +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The macros sgml-syntoken and sgml-syntable allows creating rules for +;; matching text inside tags in the format: +;; or or +;; any-text +;; +;; The generated rules don't allow things like: < tag> or +;; +;; This could also be done as a normal definition, with a starting rule like: +;; "<(tag1|tag2|tag3)\\>" +;; and an ending rule like: +;; "" +;; But is implemented in way that will fail on purpose for things like: +;; any text +;; +;; NOTE: These definitions aren't cheap in the time required to process the +;; file, and are just adaptations/tests with the syntax-highlight code, +;; probably it is better to avoid using it in other syntax definitions. +;; NOTE2: It cannot be defined as a single macro because it is required to +;; generate 2 entries in the main SGML syntax highlight definition, +;; or, should generate the entire definition from a macro; you will +;; need to type the tag name twice, but shouldn't be a problem if +;; you are using sgml :-) +;; XXX: Maybe the syntax-highlight code could save the starting match and +;; apply a regex generated at run-time to check for the ending tag, +;; but this probably would make the parser too slow, better to have +;; a specialized parser if that is required... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro sgml-syntoken (name) + `(syntoken (string-concat "<" ,name "\\>") + :icase t + :contained t + :begin (intern (string-concat ,name "$") 'keyword)) +) +(defmacro sgml-syntable (name property) + `(let + ( + (label (intern (string-concat ,name "$") 'keyword)) + (nested-label (intern (string (gensym)) 'keyword)) + ) + (syntable label *prop-preprocessor* nil + ;; tag is still open, process any options + (synaugment :generic-tag) + (syntoken ">" + :nospec t + :property *prop-preprocessor* + :begin nested-label) + ;; Generate a nested table that includes everything, and only + ;; returns when the closing tag is found. + (syntable nested-label ,property nil + (syntoken (string-concat "") + :icase t + :nospec t + :property *prop-preprocessor* + :switch -2) + (synaugment :main) + ) + ) + ) +) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Generate tokens for tags that don't require and ending tag. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro sgml-syntable-simple (name property) + `(let + ( + (label (intern (string-concat ,name "$") 'keyword)) + (nested-label (intern (string (gensym)) 'keyword)) + ) + (syntable label *prop-preprocessor* nil + ;; tag is still open, process any options + (synaugment :generic-tag) + (syntoken ">" + :nospec t + :property *prop-preprocessor* + :begin nested-label) + ;; Generate a nested table that finishes whenever an unmatched + ;; start or end tag is found. + (syntable nested-label ,property nil + (syntoken "" + :icase t + :nospec t + :property *prop-preprocessor* + :switch :main) + (synaugment :main) + ) + ) + ) +) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Define some macros to generate tokens for tags in the format: +;; " + :property *prop-control* + :switch :main) + ) +) + + +;; The main SGML syntax table +(defsyntax *sgml-mode* :main *prop-sgml-default* nil nil + ;; Comments + (syntoken "" + :nospec t + :switch -1) + ) + + ;; Entities + (syntoken "&[a-zA-Z0-9_.-]+;" + :property *prop-constant*) + ;; Probably an entity, missing ending `;' + (syntoken "&[a-zA-Z0-9_.-]+" + :property *prop-sgml-maybe-entity*) + + ;; Strings + (syntable :string *prop-string* nil + ;; Ignore escaped characters. + (syntoken "\\\\.") + ;; Rule to finish the string. + (syntoken "\"" + :nospec t + :switch -1) + ) + + ;; Links + (syntable :link *prop-preprocessor* nil + ;; No link string following "url=" + (syntoken ">" + :nospec t + :property *prop-control* + :switch -1) + (syntoken "\"" + :nospec t + :contained t + :begin :link-string) + (syntable :link-string *prop-sgml-link* nil + ;; Ignore escaped characters. + (syntoken "\\\\.") + ;; Rule to finish the link, note that returns two levels. + (syntoken "\"" + :nospec t + :switch -2) + ) + ) + + ;; "Special" tag + (syntoken "" + :nospec t + :switch -1) + (syntable :brackets *prop-sgml-default* nil + (syntoken "]" + :nospec t + :property *prop-preprocessor* + :switch -1) + ;; Allow nesting. + (syntoken "[" + :nospec t + :property *prop-preprocessor* + :begin :brackets) + ;; Entities. + (syntoken "%[a-zA-Z0-9_.-]+;?" + :property *prop-annotation*) + ;; Allow everything inside the brackets + (synaugment :main) + ) + ;; Don't use generic tag tokens, only create a rule for strings + (syntoken "\"" + :nospec t + :begin :string + :contained t) + ;; Allow everything inside the "special" tag + (synaugment :main) + ) + + ;; Some "short" tags + (sgml-syntoken-short "tt") + (sgml-syntable-short "tt" *prop-sgml-tt*) + (sgml-syntoken-short "it") + (sgml-syntable-short "it" *prop-sgml-it*) + (sgml-syntoken-short "bf") + (sgml-syntable-short "bf" *prop-sgml-bf*) + (sgml-syntoken-short "em") + (sgml-syntable-short "em" *prop-sgml-bf*) + + ;; Short tag + (syntoken "<\\w+/" + :property *prop-preprocessor* + :begin :short-tag) + (syntable :short-tag *prop-sgml-default-short* nil + (syntoken "/" + :nospec t + :property *prop-preprocessor* + :switch -1) + (syntoken "" + :property *prop-control* + :switch -1) + ) + + ;; Don't allow spaces, this may and may not be the start of a tag, + ;; but the syntax-highlight definition is not specialized... + (syntoken "<([^/a-zA-Z]|$)" + :property *prop-control*) + + ;; Some tags that require an end tag + (sgml-syntoken "tt") + (sgml-syntable "tt" *prop-sgml-tt*) + (sgml-syntoken "code") + (sgml-syntable "code" *prop-sgml-tt*) + (sgml-syntoken "tag") + (sgml-syntable "tag" *prop-sgml-tt*) + (sgml-syntoken "verb") + (sgml-syntable "verb" *prop-sgml-tt*) + (sgml-syntoken "programlisting") + (sgml-syntable "programlisting" *prop-sgml-tt*) + (sgml-syntoken "it") + (sgml-syntable "it" *prop-sgml-it*) + (sgml-syntoken "bf") + (sgml-syntable "bf" *prop-sgml-bf*) + (sgml-syntoken "em") + (sgml-syntable "em" *prop-sgml-bf*) + (sgml-syntoken "mail") + (sgml-syntable "mail" *prop-sgml-email*) + (sgml-syntoken "email") + (sgml-syntable "email" *prop-sgml-email*) + (sgml-syntoken "screen") + (sgml-syntable "screen" *prop-sgml-screen*) + (sgml-syntoken "tscreen") + (sgml-syntable "tscreen" *prop-sgml-screen*) + + + ;; Helper for tags that don't need an ending one. + ;; NOTE: Since the parser is not specialized, if the tag is + ;; folowed by one that has a special property defined here, + ;; it may not be detected, i.e. put a

    after the + ;; and it will work. + (syntable :simple-nested-tag *prop-preprocessor* nil + ;; tag is still open, process any options + (synaugment :generic-tag) + (syntoken ">" + :nospec t + :property *prop-preprocessor* + :switch -3) + ) + (sgml-syntoken "sect") + (sgml-syntable-simple "sect" *prop-sgml-sect*) + (sgml-syntoken "sect1") + (sgml-syntable-simple "sect1" *prop-sgml-sect*) + (sgml-syntoken "sect2") + (sgml-syntable-simple "sect2" *prop-sgml-sect*) + + ;; Generic tags + (syntoken "<" + :nospec t + :contained t + :begin :tag) + ;; Table :generic-tag is defined to be augmented, no rule to finish it. + (syntable :generic-tag *prop-preprocessor* nil + ;; Start string + (syntoken "\"" + :nospec t + :begin :string + :contained t) + ;; Start url link + (syntoken "url=" + :nospec t + :begin :link) + ;; Cannot nest + (syntoken "<" + :nospec t + :property *prop-control*) + ) + (syntable :tag *prop-preprocessor* nil + ;; Finish the tag + (syntoken ">" + :nospec t + :switch -1) + ;; Import generic definitions + (synaugment :generic-tag) + ) +) diff --git a/lisp/modules/progmodes/sh.lsp b/lisp/modules/progmodes/sh.lsp new file mode 100644 index 0000000..79679ed --- /dev/null +++ b/lisp/modules/progmodes/sh.lsp @@ -0,0 +1,113 @@ +;; +;; Copyright (c) 2003 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/progmodes/sh.lsp,v 1.1 2003/01/16 03:50:46 paulo Exp $ +;; + +(require "syntax") +(require "indent") +(in-package "XEDIT") + +(defsynprop *prop-escape* + "escape" + :font "*lucidatypewriter-medium-r*12*" + :foreground "Red3") + +(defsynprop *prop-variable* + "variable" + :font "*lucidatypewriter-medium-r*12*" + :foreground "Gold4") + +(defsynprop *prop-backslash* + "backslash" + :font "*courier-bold-r*12*" + :foreground "green4") + +;; XXX it would be interesting if "here-documents" could be parsed +;; just searching for "<<\s*EOF\\>" and then for "^EOF\\>" should +;; handle most cases, but would be a hack... +(defsyntax *sh-mode* :main nil #'default-indent nil + ;; keywords and common commands/builtins + (syntoken "\\<(if|then|elif|else|fi|case|in|esac|for|do|done|while|until|break|continue|eval|exit|exec|test|echo|cd|shift|local|return)\\>" + :property *prop-keyword*) + + ; comments + (syntoken "#.*$" :property *prop-comment*) + + ;; punctuation + (syntoken "[][;:*?(){}<>&!|$#]+" :property *prop-punctuation*) + + ;; variable declaration + (syntoken "\\w+=" :property *prop-preprocessor*) + + ;; numbers + (syntoken "\\<\\d+\\>" :property *prop-number*) + + ;; escaped characters at toplevel + (syntoken "\\\\." :property *prop-backslash*) + + ;; single quote + (syntoken "'" :nospec t :contained t :begin :single) + (syntable :single *prop-constant* nil + ;; do nothing, escaped characters + (syntoken "\\\\.") + (syntoken "'" :nospec t :switch -1) + ) + + ;; double quote + (syntoken "\"" :nospec t :contained t :begin :double) + (syntable :double *prop-string* #'default-indent + ;; escaped characters + (syntoken "\\\\." :property *prop-backslash*) + (syntoken "\"" :nospec t :switch -1) + ;; rule to start escape + (syntoken "`" :nospec t :contained t :begin :escape) + ;; ignore single quote, required because escape is augmented + (syntoken "'" :nospec t) + (synaugment :escape :variable) + ) + + ;; escaped commands + (syntoken "`" :nospec t :contained t :begin :escape) + (syntable :escape *prop-escape* #'default-indent + ;; escaped characters + (syntoken "\\\\." :property *prop-backslash*) + (syntoken "`" :nospec t :switch -1) + ;; rule to start double quote inside escape + (syntoken "\"" :nospec t :contained t :begin :double) + ;; rule to start single quote + (syntoken "'" :nospec t :contained t :begin :single) + (synaugment :double :variable) + ) + + (syntable :variable nil nil + (syntoken "\\$\\w+" :property *prop-variable*) + ) + (synaugment :variable) +) diff --git a/lisp/modules/progmodes/xconf.lsp b/lisp/modules/progmodes/xconf.lsp new file mode 100644 index 0000000..dea70a2 --- /dev/null +++ b/lisp/modules/progmodes/xconf.lsp @@ -0,0 +1,68 @@ +;; +;; Copyright (c) 2003 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/progmodes/xconf.lsp,v 1.1 2003/01/16 03:50:46 paulo Exp $ +;; + +(require "syntax") +(require "indent") +(in-package "XEDIT") + +(defsyntax *xconf-mode* :main nil #'default-indent nil + ;; section start + (syntoken "\\<(Section|SubSection)\\>" + :property *prop-keyword* :icase t :begin :section) + ;; just for fun, highlight the section name differently + (syntable :section *prop-constant* #'default-indent + (syntoken "\"" :nospec t :begin :name) + (syntable :name *prop-constant* nil + ;; ignore escaped characters + (syntoken "\\\\.") + (syntoken "\"" :nospec t :switch -2) + ) + ) + + ;; section end + (syntoken "\\<(EndSection|EndSubSection)\\>" + :property *prop-keyword* :icase t) + + ;; numeric options + (syntoken "\\<\\d+(\\.\\d+)?\\>" :property *prop-number*) + + ;; comments + (syntoken "#.*$" :property *prop-comment*) + + ;; strings + (syntoken "\"" :nospec t :begin :string :contained t) + (syntable :string *prop-string* #'default-indent + ;; ignore escaped characters + (syntoken "\\\\.") + (syntoken "\"" :nospec t :switch -1) + ) +) diff --git a/lisp/modules/progmodes/xlog.lsp b/lisp/modules/progmodes/xlog.lsp new file mode 100644 index 0000000..6bc8b57 --- /dev/null +++ b/lisp/modules/progmodes/xlog.lsp @@ -0,0 +1,102 @@ +;; +;; Copyright (c) 2003 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/progmodes/xlog.lsp,v 1.1 2003/01/16 06:25:51 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +(defsynprop *prop-xlog-probe* + "xlog-probe" + :font "*courier-medium-r*12*" + :background "rgb:c/f/c") + +(defsynprop *prop-xlog-config* + "xlog-config" + :font "*courier-medium-r*12*" + :background "rgb:c/e/f") + +(defsynprop *prop-xlog-default* + "xlog-default" + :font "*courier-medium-r*12*" + :background "rgb:e/c/f") + +(defsynprop *prop-xlog-warning* + "xlog-warning" + :font "*courier-bold-r*12*" + :foreground "Red4" + :background "Yellow1" +) + +(defsynprop *prop-xlog-error* + "xlog-error" + :font "*courier-bold-r*12*" + :foreground "Yellow2" + :background "Red3" +) + +(defsyntax *xlog-mode* :main nil nil nil + ;; highlight version + (syntoken "^XFree86 Version \\S+" :property *prop-annotation*) + + ;; release date + (syntoken "^Release Date: " :property *prop-keyword* :begin :note) + + ;; highlight operating system description + (syntoken "^Build Operating System: " :property *prop-keyword* :begin :note) + + (syntable :note *prop-annotation* nil (syntoken "$" :switch -1)) + + ;; don't highlight info lines + (syntoken "^\\(II\\) " :property *prop-keyword*) + + ;; default lines + (syntoken "^\\(==\\) " :property *prop-keyword* :begin :default) + (syntable :default *prop-xlog-default* nil (syntoken "$" :switch -1)) + + ;; probe lines + (syntoken "^\\(--\\) " :property *prop-keyword* :begin :probe) + (syntable :probe *prop-xlog-probe* nil (syntoken "$" :switch -1)) + + ;; config lines + (syntoken "^\\(\\*\\*\\) " :property *prop-keyword* :begin :config) + (syntable :config *prop-xlog-config* nil (syntoken "$" :switch -1)) + + ;; warnings + (syntoken "^\\(WW\\) " :property *prop-keyword* :begin :warning) + (syntable :warning *prop-xlog-warning* nil (syntoken "$" :switch -1)) + + ;; errors + (syntoken "^\\(EE\\) " :property *prop-keyword* :begin :error) + (syntable :error *prop-xlog-error* nil (syntoken "$" :switch -1)) + + ;; command line and "uncommon" messages + (syntoken "^\\(..\\) " :property *prop-control* :begin :warning) +) diff --git a/lisp/modules/progmodes/xrdb.lsp b/lisp/modules/progmodes/xrdb.lsp new file mode 100644 index 0000000..c0a099c --- /dev/null +++ b/lisp/modules/progmodes/xrdb.lsp @@ -0,0 +1,115 @@ +;; +;; 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/progmodes/xrdb.lsp,v 1.2 2002/10/06 17:11:48 paulo Exp $ +;; + +(require "syntax") +(in-package "XEDIT") + +(defsynprop *prop-xrdb-comment* + "xrdb-comment" + :font "*courier-medium-o*12*" + :foreground "sienna" +) + +(defsynprop *prop-xrdb-special* + "format" + :font "*lucidatypewriter-medium-r*12*" + :foreground "RoyalBlue4" +) + +(defsynprop *prop-xrdb-punctuation* + "punctuation" + :font "-*-courier-bold-r-*-*-14-*-*-*-*-*-*-1" + :foreground "OrangeRed4" +) + +(defsyntax *xrdb-mode* :main nil nil nil + (syntoken "^\\s*!.*" + :property *prop-xrdb-comment*) + (syntoken "^\\s*#.*" + :property *prop-preprocessor*) + (syntoken "\\*|\\.|\\?" + :property *prop-xrdb-punctuation* + :begin :resource) + (syntoken "." + :nospec t + :begin :resource) + + ;; Extra comments + (syntoken "/*" :nospec t :begin :comment :contained t) + (syntable :comment *prop-comment* nil + (syntoken "/*" :nospec t :property *prop-error*) + ;; Rule to finish a comment. + (syntoken "*/" :nospec t :switch -1) + ) + + (syntable :resource nil nil + (syntoken "\\*|\\.|\\?" :property *prop-xrdb-punctuation*) + (syntoken ":\\s*" :property *prop-xrdb-punctuation* :begin :value) + ) + + (syntable :value *prop-string* nil + (syntoken "\\\\$" :property *prop-constant*) + + + ;; If the pattern ends at a newline, must switch to the previous state. + ;; Not sure yet how to better handle this. The parser does not detect + ;; eol because it is a match to the empty string. A possible hack + ;; would be to check if the pattern string ends in a "$", but probably + ;; better in this case to have a syntoken option, to tell the parser + ;; an eol may exist. + (syntoken + (string-concat + "(" + "\\d+|" ;; numbers + "(#\\x+|rgb:\\x+/\\x+/\\x+)|" ;; color spec + "#\\w+" ;; translation table + ")$") + :property *prop-xrdb-special* :switch -2) + (syntoken "(\\\\n?|\")$" + :property *prop-constant* :switch -2) + + ;; XXX Cut&paste of the above, only without the match to eol + (syntoken + (string-concat + "(" + "\\d+|" + "(#\\x+|rgb:\\x+/\\x+/\\x+)|" + "#\\w+" + ")") + :property *prop-xrdb-special*) + (syntoken "(\\\\n?|\")" + :property *prop-constant*) + + (syntoken "/*" :nospec t :begin :comment :contained t) + (syntoken ".?$" :switch -2) + ) +) diff --git a/lisp/modules/psql.c b/lisp/modules/psql.c new file mode 100644 index 0000000..6945947 --- /dev/null +++ b/lisp/modules/psql.c @@ -0,0 +1,983 @@ +/* + * Copyright (c) 2001 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/psql.c,v 1.12 2002/11/23 08:26:52 paulo Exp $ */ + +#include +#include +#undef USE_SSL /* cannot get it to compile... */ +#include +#include +#include "internal.h" +#include "private.h" + +/* + * Prototypes + */ +int psqlLoadModule(void); + +LispObj *Lisp_PQbackendPID(LispBuiltin*); +LispObj *Lisp_PQclear(LispBuiltin*); +LispObj *Lisp_PQconsumeInput(LispBuiltin*); +LispObj *Lisp_PQdb(LispBuiltin*); +LispObj *Lisp_PQerrorMessage(LispBuiltin*); +LispObj *Lisp_PQexec(LispBuiltin*); +LispObj *Lisp_PQfinish(LispBuiltin*); +LispObj *Lisp_PQfname(LispBuiltin*); +LispObj *Lisp_PQfnumber(LispBuiltin*); +LispObj *Lisp_PQfsize(LispBuiltin*); +LispObj *Lisp_PQftype(LispBuiltin*); +LispObj *Lisp_PQgetlength(LispBuiltin*); +LispObj *Lisp_PQgetvalue(LispBuiltin*); +LispObj *Lisp_PQhost(LispBuiltin*); +LispObj *Lisp_PQnfields(LispBuiltin*); +LispObj *Lisp_PQnotifies(LispBuiltin*); +LispObj *Lisp_PQntuples(LispBuiltin*); +LispObj *Lisp_PQoptions(LispBuiltin*); +LispObj *Lisp_PQpass(LispBuiltin*); +LispObj *Lisp_PQport(LispBuiltin*); +LispObj *Lisp_PQresultStatus(LispBuiltin*); +LispObj *Lisp_PQsetdb(LispBuiltin*); +LispObj *Lisp_PQsetdbLogin(LispBuiltin*); +LispObj *Lisp_PQsocket(LispBuiltin*); +LispObj *Lisp_PQstatus(LispBuiltin*); +LispObj *Lisp_PQtty(LispBuiltin*); +LispObj *Lisp_PQuser(LispBuiltin*); + +/* + * Initialization + */ +static LispBuiltin lispbuiltins[] = { + {LispFunction, Lisp_PQbackendPID, "pq-backend-pid connection"}, + {LispFunction, Lisp_PQclear, "pq-clear result"}, + {LispFunction, Lisp_PQconsumeInput, "pq-consume-input connection"}, + {LispFunction, Lisp_PQdb, "pq-db connection"}, + {LispFunction, Lisp_PQerrorMessage, "pq-error-message connection"}, + {LispFunction, Lisp_PQexec, "pq-exec connection query"}, + {LispFunction, Lisp_PQfinish, "pq-finish connection"}, + {LispFunction, Lisp_PQfname, "pq-fname result field-number"}, + {LispFunction, Lisp_PQfnumber, "pq-fnumber result field-name"}, + {LispFunction, Lisp_PQfsize, "pq-fsize result field-number"}, + {LispFunction, Lisp_PQftype, "pq-ftype result field-number"}, + {LispFunction, Lisp_PQgetlength, "pq-getlength result tupple field-number"}, + {LispFunction, Lisp_PQgetvalue, "pq-getvalue result tupple field-number &optional type"}, + {LispFunction, Lisp_PQhost, "pq-host connection"}, + {LispFunction, Lisp_PQnfields, "pq-nfields result"}, + {LispFunction, Lisp_PQnotifies, "pq-notifies connection"}, + {LispFunction, Lisp_PQntuples, "pq-ntuples result"}, + {LispFunction, Lisp_PQoptions, "pq-options connection"}, + {LispFunction, Lisp_PQpass, "pq-pass connection"}, + {LispFunction, Lisp_PQport, "pq-port connection"}, + {LispFunction, Lisp_PQresultStatus, "pq-result-status result"}, + {LispFunction, Lisp_PQsetdb, "pq-setdb host port options tty dbname"}, + {LispFunction, Lisp_PQsetdbLogin, "pq-setdb-login host port options tty dbname login password"}, + {LispFunction, Lisp_PQsocket, "pq-socket connection"}, + {LispFunction, Lisp_PQstatus, "pq-status connection"}, + {LispFunction, Lisp_PQtty, "pq-tty connection"}, + {LispFunction, Lisp_PQuser, "pq-user connection"}, +}; + +LispModuleData psqlLispModuleData = { + LISP_MODULE_VERSION, + psqlLoadModule +}; + +static int PGconn_t, PGresult_t; + +/* + * Implementation + */ +int +psqlLoadModule(void) +{ + int i; + char *fname = "PSQL-LOAD-MODULE"; + + PGconn_t = LispRegisterOpaqueType("PGconn*"); + PGresult_t = LispRegisterOpaqueType("PGresult*"); + + GCDisable(); + /* NOTE: Implemented just enough to make programming examples + * (and my needs) work. + * Completing this is an exercise to the reader, or may be implemented + * when/if required. + */ + LispExecute("(DEFSTRUCT PG-NOTIFY RELNAME BE-PID)\n" + "(DEFSTRUCT PG-POINT X Y)\n" + "(DEFSTRUCT PG-BOX HIGH LOW)\n" + "(DEFSTRUCT PG-POLYGON SIZE NUM-POINTS BOUNDBOX POINTS)\n"); + + /* enum ConnStatusType */ + (void)LispSetVariable(ATOM2("PG-CONNECTION-OK"), + REAL(CONNECTION_OK), fname, 0); + (void)LispSetVariable(ATOM2("PG-CONNECTION-BAD"), + REAL(CONNECTION_BAD), fname, 0); + (void)LispSetVariable(ATOM2("PG-CONNECTION-STARTED"), + REAL(CONNECTION_STARTED), fname, 0); + (void)LispSetVariable(ATOM2("PG-CONNECTION-MADE"), + REAL(CONNECTION_MADE), fname, 0); + (void)LispSetVariable(ATOM2("PG-CONNECTION-AWAITING-RESPONSE"), + REAL(CONNECTION_AWAITING_RESPONSE), fname, 0); + (void)LispSetVariable(ATOM2("PG-CONNECTION-AUTH-OK"), + REAL(CONNECTION_AUTH_OK), fname, 0); + (void)LispSetVariable(ATOM2("PG-CONNECTION-SETENV"), + REAL(CONNECTION_SETENV), fname, 0); + + + /* enum ExecStatusType */ + (void)LispSetVariable(ATOM2("PGRES-EMPTY-QUERY"), + REAL(PGRES_EMPTY_QUERY), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-COMMAND-OK"), + REAL(PGRES_COMMAND_OK), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-TUPLES-OK"), + REAL(PGRES_TUPLES_OK), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-COPY-OUT"), + REAL(PGRES_COPY_OUT), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-COPY-IN"), + REAL(PGRES_COPY_IN), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-BAD-RESPONSE"), + REAL(PGRES_BAD_RESPONSE), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-NONFATAL-ERROR"), + REAL(PGRES_NONFATAL_ERROR), fname, 0); + (void)LispSetVariable(ATOM2("PGRES-FATAL-ERROR"), + REAL(PGRES_FATAL_ERROR), fname, 0); + GCEnable(); + + for (i = 0; i < sizeof(lispbuiltins) / sizeof(lispbuiltins[0]); i++) + LispAddBuiltinFunction(&lispbuiltins[i]); + + return (1); +} + +LispObj * +Lisp_PQbackendPID(LispBuiltin *builtin) +/* + pq-backend-pid connection + */ +{ + int pid; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + pid = PQbackendPID(conn); + + return (INTEGER(pid)); +} + +LispObj * +Lisp_PQclear(LispBuiltin *builtin) +/* + pq-clear result + */ +{ + PGresult *res; + + LispObj *result; + + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + PQclear(res); + + return (NIL); +} + +LispObj * +Lisp_PQconsumeInput(LispBuiltin *builtin) +/* + pq-consume-input connection + */ +{ + int result; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + result = PQconsumeInput(conn); + + return (INTEGER(result)); +} + +LispObj * +Lisp_PQdb(LispBuiltin *builtin) +/* + pq-db connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQdb(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQerrorMessage(LispBuiltin *builtin) +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQerrorMessage(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQexec(LispBuiltin *builtin) +/* + pq-exec connection query + */ +{ + PGconn *conn; + PGresult *res; + + LispObj *connection, *query; + + query = ARGUMENT(1); + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + CHECK_STRING(query); + res = PQexec(conn, THESTR(query)); + + return (res ? OPAQUE(res, PGresult_t) : NIL); +} + +LispObj * +Lisp_PQfinish(LispBuiltin *builtin) +/* + pq-finish connection + */ +{ + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + PQfinish(conn); + + return (NIL); +} + +LispObj * +Lisp_PQfname(LispBuiltin *builtin) +/* + pq-fname result field-number + */ +{ + char *string; + int field; + PGresult *res; + + LispObj *result, *field_number; + + field_number = ARGUMENT(1); + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + CHECK_INDEX(field_number); + field = FIXNUM_VALUE(field_number); + + string = PQfname(res, field); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQfnumber(LispBuiltin *builtin) +/* + pq-fnumber result field-name + */ +{ + int number; + int field; + PGresult *res; + + LispObj *result, *field_name; + + field_name = ARGUMENT(1); + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + CHECK_STRING(field_name); + number = PQfnumber(res, THESTR(field_name)); + + return (INTEGER(number)); +} + +LispObj * +Lisp_PQfsize(LispBuiltin *builtin) +/* + pq-fsize result field-number + */ +{ + int size, field; + PGresult *res; + + LispObj *result, *field_number; + + field_number = ARGUMENT(1); + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + CHECK_INDEX(field_number); + field = FIXNUM_VALUE(field_number); + + size = PQfsize(res, field); + + return (INTEGER(size)); +} + +LispObj * +Lisp_PQftype(LispBuiltin *builtin) +{ + Oid oid; + int field; + PGresult *res; + + LispObj *result, *field_number; + + field_number = ARGUMENT(1); + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + CHECK_INDEX(field_number); + field = FIXNUM_VALUE(field_number); + + oid = PQftype(res, field); + + return (INTEGER(oid)); +} + +LispObj * +Lisp_PQgetlength(LispBuiltin *builtin) +/* + pq-getlength result tupple field-number + */ +{ + PGresult *res; + int tuple, field, length; + + LispObj *result, *otupple, *field_number; + + field_number = ARGUMENT(2); + otupple = ARGUMENT(1); + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + CHECK_INDEX(otupple); + tuple = FIXNUM_VALUE(otupple); + + CHECK_INDEX(field_number); + field = FIXNUM_VALUE(field_number); + + length = PQgetlength(res, tuple, field); + + return (INTEGER(length)); +} + +LispObj * +Lisp_PQgetvalue(LispBuiltin *builtin) +/* + pq-getvalue result tuple field &optional type-specifier + */ +{ + char *string; + double real = 0.0; + PGresult *res; + int tuple, field, isint = 0, isreal = 0, integer; + + LispObj *result, *otupple, *field_number, *type; + + type = ARGUMENT(3); + field_number = ARGUMENT(2); + otupple = ARGUMENT(1); + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + CHECK_INDEX(otupple); + tuple = FIXNUM_VALUE(otupple); + + CHECK_INDEX(field_number); + field = FIXNUM_VALUE(field_number); + + string = PQgetvalue(res, tuple, field); + + if (type != UNSPEC) { + char *typestring; + + CHECK_SYMBOL(type); + typestring = ATOMID(type); + + if (strcmp(typestring, "INT16") == 0) { + integer = *(short*)string; + isint = 1; + goto simple_type; + } + else if (strcmp(typestring, "INT32") == 0) { + integer = *(int*)string; + isint = 1; + goto simple_type; + } + else if (strcmp(typestring, "FLOAT") == 0) { + real = *(float*)string; + isreal = 1; + goto simple_type; + } + else if (strcmp(typestring, "REAL") == 0) { + real = *(double*)string; + isreal = 1; + goto simple_type; + } + else if (strcmp(typestring, "PG-POLYGON") == 0) + goto polygon_type; + else if (strcmp(typestring, "STRING") != 0) + LispDestroy("%s: unknown type %s", + STRFUN(builtin), typestring); + } + +simple_type: + return (isint ? INTEGER(integer) : isreal ? DFLOAT(real) : + (string ? STRING(string) : NIL)); + +polygon_type: + { + LispObj *poly, *box, *p = NIL, *cdr, *obj; + POLYGON *polygon; + int i, size; + + size = PQgetlength(res, tuple, field); + polygon = (POLYGON*)(string - sizeof(int)); + + GCDisable(); + /* get polygon->boundbox */ + cdr = EVAL(CONS(ATOM("MAKE-PG-POINT"), + CONS(KEYWORD("X"), + CONS(REAL(polygon->boundbox.high.x), + CONS(KEYWORD("Y"), + CONS(REAL(polygon->boundbox.high.y), NIL)))))); + obj = EVAL(CONS(ATOM("MAKE-PG-POINT"), + CONS(KEYWORD("X"), + CONS(REAL(polygon->boundbox.low.x), + CONS(KEYWORD("Y"), + CONS(REAL(polygon->boundbox.low.y), NIL)))))); + box = EVAL(CONS(ATOM("MAKE-PG-BOX"), + CONS(KEYWORD("HIGH"), + CONS(cdr, + CONS(KEYWORD("LOW"), + CONS(obj, NIL)))))); + /* get polygon->p values */ + for (i = 0; i < polygon->npts; i++) { + obj = EVAL(CONS(ATOM("MAKE-PG-POINT"), + CONS(KEYWORD("X"), + CONS(REAL(polygon->p[i].x), + CONS(KEYWORD("Y"), + CONS(REAL(polygon->p[i].y), NIL)))))); + if (i == 0) + p = cdr = CONS(obj, NIL); + else { + RPLACD(cdr, CONS(obj, NIL)); + cdr = CDR(cdr); + } + } + + /* make result */ + poly = EVAL(CONS(ATOM("MAKE-PG-POLYGON"), + CONS(KEYWORD("SIZE"), + CONS(REAL(size), + CONS(KEYWORD("NUM-POINTS"), + CONS(REAL(polygon->npts), + CONS(KEYWORD("BOUNDBOX"), + CONS(box, + CONS(KEYWORD("POINTS"), + CONS(QUOTE(p), NIL)))))))))); + GCEnable(); + + return (poly); + } +} + +LispObj * +Lisp_PQhost(LispBuiltin *builtin) +/* + pq-host connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQhost(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQnfields(LispBuiltin *builtin) +/* + pq-nfields result + */ +{ + int nfields; + PGresult *res; + + LispObj *result; + + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + nfields = PQnfields(res); + + return (INTEGER(nfields)); +} + +LispObj * +Lisp_PQnotifies(LispBuiltin *builtin) +/* + pq-notifies connection + */ +{ + LispObj *result, *code, *cod = COD; + PGconn *conn; + PGnotify *notifies; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + if ((notifies = PQnotifies(conn)) == NULL) + return (NIL); + + GCDisable(); + code = CONS(ATOM("MAKE-PG-NOTIFY"), + CONS(KEYWORD("RELNAME"), + CONS(STRING(notifies->relname), + CONS(KEYWORD("BE-PID"), + CONS(REAL(notifies->be_pid), NIL))))); + COD = CONS(code, COD); + GCEnable(); + result = EVAL(code); + COD = cod; + + free(notifies); + + return (result); +} + +LispObj * +Lisp_PQntuples(LispBuiltin *builtin) +/* + pq-ntuples result + */ +{ + int ntuples; + PGresult *res; + + LispObj *result; + + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + ntuples = PQntuples(res); + + return (INTEGER(ntuples)); +} + +LispObj * +Lisp_PQoptions(LispBuiltin *builtin) +/* + pq-options connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQoptions(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQpass(LispBuiltin *builtin) +/* + pq-pass connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQpass(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQport(LispBuiltin *builtin) +/* + pq-port connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQport(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQresultStatus(LispBuiltin *builtin) +/* + pq-result-status result + */ +{ + int status; + PGresult *res; + + LispObj *result; + + result = ARGUMENT(0); + + if (!CHECKO(result, PGresult_t)) + LispDestroy("%s: cannot convert %s to PGresult*", + STRFUN(builtin), STROBJ(result)); + res = (PGresult*)(result->data.opaque.data); + + status = PQresultStatus(res); + + return (INTEGER(status)); +} + +LispObj * +LispPQsetdb(LispBuiltin *builtin, int loginp) +/* + pq-setdb host port options tty dbname + pq-setdb-login host port options tty dbname login password + */ +{ + PGconn *conn; + char *host, *port, *options, *tty, *dbname, *login, *password; + + LispObj *ohost, *oport, *ooptions, *otty, *odbname, *ologin, *opassword; + + if (loginp) { + opassword = ARGUMENT(6); + ologin = ARGUMENT(5); + } + else + opassword = ologin = NIL; + odbname = ARGUMENT(4); + otty = ARGUMENT(3); + ooptions = ARGUMENT(2); + oport = ARGUMENT(1); + ohost = ARGUMENT(0); + + if (ohost != NIL) { + CHECK_STRING(ohost); + host = THESTR(ohost); + } + else + host = NULL; + + if (oport != NIL) { + CHECK_STRING(oport); + port = THESTR(oport); + } + else + port = NULL; + + if (ooptions != NIL) { + CHECK_STRING(ooptions); + options = THESTR(ooptions); + } + else + options = NULL; + + if (otty != NIL) { + CHECK_STRING(otty); + tty = THESTR(otty); + } + else + tty = NULL; + + if (odbname != NIL) { + CHECK_STRING(odbname); + dbname = THESTR(odbname); + } + else + dbname = NULL; + + if (ologin != NIL) { + CHECK_STRING(ologin); + login = THESTR(ologin); + } + else + login = NULL; + + if (opassword != NIL) { + CHECK_STRING(opassword); + password = THESTR(opassword); + } + else + password = NULL; + + conn = PQsetdbLogin(host, port, options, tty, dbname, login, password); + + return (conn ? OPAQUE(conn, PGconn_t) : NIL); +} + +LispObj * +Lisp_PQsetdb(LispBuiltin *builtin) +/* + pq-setdb host port options tty dbname + */ +{ + return (LispPQsetdb(builtin, 0)); +} + +LispObj * +Lisp_PQsetdbLogin(LispBuiltin *builtin) +/* + pq-setdb-login host port options tty dbname login password + */ +{ + return (LispPQsetdb(builtin, 1)); +} + +LispObj * +Lisp_PQsocket(LispBuiltin *builtin) +/* + pq-socket connection + */ +{ + int sock; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + sock = PQsocket(conn); + + return (INTEGER(sock)); +} + +LispObj * +Lisp_PQstatus(LispBuiltin *builtin) +/* + pq-status connection + */ +{ + int status; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + status = PQstatus(conn); + + return (INTEGER(status)); +} + +LispObj * +Lisp_PQtty(LispBuiltin *builtin) +/* + pq-tty connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQtty(conn); + + return (string ? STRING(string) : NIL); +} + +LispObj * +Lisp_PQuser(LispBuiltin *builtin) +/* + pq-user connection + */ +{ + char *string; + PGconn *conn; + + LispObj *connection; + + connection = ARGUMENT(0); + + if (!CHECKO(connection, PGconn_t)) + LispDestroy("%s: cannot convert %s to PGconn*", + STRFUN(builtin), STROBJ(connection)); + conn = (PGconn*)(connection->data.opaque.data); + + string = PQuser(conn); + + return (string ? STRING(string) : NIL); +} 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 + ;; - 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 ( . ) and not +;; (( . ) ... ( . )). 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) diff --git a/lisp/modules/x11.c b/lisp/modules/x11.c new file mode 100644 index 0000000..3cdb0bc --- /dev/null +++ b/lisp/modules/x11.c @@ -0,0 +1,666 @@ +/* + * Copyright (c) 2001 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/x11.c,v 1.10 2002/11/23 08:26:52 paulo Exp $ */ + +#include +#include +#include "internal.h" +#include "private.h" +#include + +/* + * Prototypes + */ +int x11LoadModule(void); + +LispObj *Lisp_XOpenDisplay(LispBuiltin *builtin); +LispObj *Lisp_XCloseDisplay(LispBuiltin *builtin); +LispObj *Lisp_XDefaultRootWindow(LispBuiltin *builtin); +LispObj *Lisp_XDefaultScreen(LispBuiltin *builtin); +LispObj *Lisp_XDefaultScreenOfDisplay(LispBuiltin *builtin); +LispObj *Lisp_XBlackPixel(LispBuiltin *builtin); +LispObj *Lisp_XBlackPixelOfScreen(LispBuiltin *builtin); +LispObj *Lisp_XWidthOfScreen(LispBuiltin *builtin); +LispObj *Lisp_XHeightOfScreen(LispBuiltin *builtin); +LispObj *Lisp_XWhitePixel(LispBuiltin *builtin); +LispObj *Lisp_XWhitePixelOfScreen(LispBuiltin *builtin); +LispObj *Lisp_XDefaultGC(LispBuiltin *builtin); +LispObj *Lisp_XDefaultGCOfScreen(LispBuiltin *builtin); +LispObj *Lisp_XCreateSimpleWindow(LispBuiltin *builtin); +LispObj *Lisp_XMapWindow(LispBuiltin *builtin); +LispObj *Lisp_XDestroyWindow(LispBuiltin *builtin); +LispObj *Lisp_XFlush(LispBuiltin *builtin); +LispObj *Lisp_XRaiseWindow(LispBuiltin *builtin); +LispObj *Lisp_XBell(LispBuiltin *builtin); + +LispObj *Lisp_XDrawLine(LispBuiltin *builtin); + +/* + * Initialization + */ +static LispBuiltin lispbuiltins[] = { + {LispFunction, Lisp_XOpenDisplay, "x-open-display &optional display-name"}, + {LispFunction, Lisp_XCloseDisplay, "x-close-display display"}, + {LispFunction, Lisp_XDefaultRootWindow, "x-default-root-window display"}, + {LispFunction, Lisp_XDefaultScreen, "x-default-screen display"}, + {LispFunction, Lisp_XDefaultScreenOfDisplay, "x-default-screen-of-display display"}, + {LispFunction, Lisp_XBlackPixel, "x-black-pixel display &optional screen"}, + {LispFunction, Lisp_XBlackPixelOfScreen, "x-black-pixel-of-screen screen"}, + {LispFunction, Lisp_XWhitePixel, "x-white-pixel display &optional screen"}, + {LispFunction, Lisp_XWhitePixelOfScreen, "x-white-pixel-of-screen screen"}, + {LispFunction, Lisp_XDefaultGC, "x-default-gc display &optional screen"}, + {LispFunction, Lisp_XDefaultGCOfScreen, "x-default-gc-of-screen screen"}, + {LispFunction, Lisp_XCreateSimpleWindow, "x-create-simple-window display parent x y width height &optional border-width border background"}, + {LispFunction, Lisp_XMapWindow, "x-map-window display window"}, + {LispFunction, Lisp_XDestroyWindow, "X-DESTROY-WINDOW"}, + {LispFunction, Lisp_XFlush, "x-flush display"}, + {LispFunction, Lisp_XDrawLine, "x-draw-line display drawable gc x1 y1 x2 y2"}, + {LispFunction, Lisp_XBell, "x-bell display &optional percent"}, + {LispFunction, Lisp_XRaiseWindow, "x-raise-window display window"}, + {LispFunction, Lisp_XWidthOfScreen, "x-width-of-screen screen"}, + {LispFunction, Lisp_XHeightOfScreen, "x-height-of-screen screen"}, +}; + +LispModuleData x11LispModuleData = { + LISP_MODULE_VERSION, + x11LoadModule +}; + +static int x11Display_t, x11Screen_t, x11Window_t, x11GC_t; + +/* + * Implementation + */ +int +x11LoadModule(void) +{ + int i; + + x11Display_t = LispRegisterOpaqueType("Display*"); + x11Screen_t = LispRegisterOpaqueType("Screen*"); + x11Window_t = LispRegisterOpaqueType("Window"); + x11GC_t = LispRegisterOpaqueType("GC"); + + for (i = 0; i < sizeof(lispbuiltins) / sizeof(lispbuiltins[0]); i++) + LispAddBuiltinFunction(&lispbuiltins[i]); + + return (1); +} + +LispObj * +Lisp_XOpenDisplay(LispBuiltin *builtin) +/* +x-open-display &optional display-name + */ +{ + LispObj *display_name; + char *dname; + + display_name = ARGUMENT(0); + + if (display_name == UNSPEC) + dname = NULL; + else { + CHECK_STRING(display_name); + dname = THESTR(display_name); + } + + return (OPAQUE(XOpenDisplay(dname), x11Display_t)); +} + +LispObj * +Lisp_XCloseDisplay(LispBuiltin *builtin) +/* + x-close-display display + */ +{ + LispObj *display; + + display = ARGUMENT(0); + + if (!CHECKO(display, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(display)); + + XCloseDisplay((Display*)(display->data.opaque.data)); + + return (NIL); +} + +LispObj * +Lisp_XDefaultRootWindow(LispBuiltin *builtin) +/* + x-default-root-window display + */ +{ + LispObj *display; + + display = ARGUMENT(0); + + if (!CHECKO(display, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(display)); + + return (OPAQUE(DefaultRootWindow((Display*)(display->data.opaque.data)), + x11Window_t)); +} + +LispObj * +Lisp_XDefaultScreen(LispBuiltin *builtin) +/* + x-default-screen display + */ +{ + LispObj *display; + + display = ARGUMENT(0); + + if (!CHECKO(display, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(display)); + + return (INTEGER(DefaultScreen((Display*)(display->data.opaque.data)))); +} + +LispObj * +Lisp_XDefaultScreenOfDisplay(LispBuiltin *builtin) +/* + x-default-screen-of-display display + */ +{ + LispObj *display; + + display = ARGUMENT(0); + + if (!CHECKO(display, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(display)); + + return (OPAQUE(DefaultScreenOfDisplay((Display*)(display->data.opaque.data)), + x11Screen_t)); +} + +LispObj * +Lisp_XBlackPixel(LispBuiltin *builtin) +/* + x-black-pixel display &optional screen + */ +{ + Display *display; + int screen; + + LispObj *odisplay, *oscreen; + + oscreen = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (oscreen == UNSPEC) + screen = DefaultScreen(display); + else + CHECK_INDEX(oscreen); + else + screen = FIXNUM_VALUE(oscreen); + + if (screen >= ScreenCount(display)) + LispDestroy("%s: screen index %d too large, %d screens available", + STRFUN(builtin), screen, ScreenCount(display)); + + return (INTEGER(BlackPixel(display, screen))); +} + +LispObj * +Lisp_XBlackPixelOfScreen(LispBuiltin *builtin) +/* + x-black-pixel-of-screen screen + */ +{ + LispObj *screen; + + screen = ARGUMENT(0); + + if (!CHECKO(screen, x11Screen_t)) + LispDestroy("%s: cannot convert %s to Screen*", + STRFUN(builtin), STROBJ(screen)); + + return (INTEGER(XBlackPixelOfScreen((Screen*)(screen->data.opaque.data)))); +} + +LispObj * +Lisp_XWhitePixel(LispBuiltin *builtin) +/* + x-white-pixel display &optional screen + */ +{ + Display *display; + int screen; + + LispObj *odisplay, *oscreen; + + oscreen = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (oscreen == UNSPEC) + screen = DefaultScreen(display); + else + CHECK_FIXNUM(oscreen); + else + screen = FIXNUM_VALUE(oscreen); + + if (screen >= ScreenCount(display)) + LispDestroy("%s: screen index %d too large, %d screens available", + STRFUN(builtin), screen, ScreenCount(display)); + + return (INTEGER(WhitePixel(display, screen))); +} + +LispObj * +Lisp_XWhitePixelOfScreen(LispBuiltin *builtin) +/* + x-white-pixel-of-screen screen + */ +{ + LispObj *screen; + + screen = ARGUMENT(0); + + if (!CHECKO(screen, x11Screen_t)) + LispDestroy("%s: cannot convert %s to Screen*", + STRFUN(builtin), STROBJ(screen)); + + return (INTEGER(WhitePixelOfScreen((Screen*)(screen->data.opaque.data)))); +} + +LispObj * +Lisp_XDefaultGC(LispBuiltin *builtin) +/* + x-default-gc display &optional screen + */ +{ + Display *display; + int screen; + + LispObj *odisplay, *oscreen; + + oscreen = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (oscreen == UNSPEC) + screen = DefaultScreen(display); + else + CHECK_FIXNUM(oscreen); + else + screen = FIXNUM_VALUE(oscreen); + + if (screen >= ScreenCount(display)) + LispDestroy("%s: screen index %d too large, %d screens available", + STRFUN(builtin), screen, ScreenCount(display)); + + return (OPAQUE(DefaultGC(display, screen), x11GC_t)); +} + +LispObj * +Lisp_XDefaultGCOfScreen(LispBuiltin *builtin) +/* + x-default-gc-of-screen screen + */ +{ + LispObj *screen; + + screen = ARGUMENT(0); + + if (!CHECKO(screen, x11Screen_t)) + LispDestroy("%s: cannot convert %s to Screen*", + STRFUN(builtin), STROBJ(screen)); + + return (OPAQUE(DefaultGCOfScreen((Screen*)(screen->data.opaque.data)), + x11GC_t)); +} + +LispObj * +Lisp_XCreateSimpleWindow(LispBuiltin *builtin) +/* + x-create-simple-window display parent x y width height &optional border-width border background + */ +{ + Display *display; + Window parent; + int x, y; + unsigned int width, height, border_width; + unsigned long border, background; + + LispObj *odisplay, *oparent, *ox, *oy, *owidth, *oheight, + *oborder_width, *oborder, *obackground; + + obackground = ARGUMENT(8); + oborder = ARGUMENT(7); + oborder_width = ARGUMENT(6); + oheight = ARGUMENT(5); + owidth = ARGUMENT(4); + oy = ARGUMENT(3); + ox = ARGUMENT(2); + oparent = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (!CHECKO(oparent, x11Window_t)) + LispDestroy("%s: cannot convert %s to Window", + STRFUN(builtin), STROBJ(oparent)); + parent = (Window)(oparent->data.opaque.data); + + CHECK_FIXNUM(ox); + x = FIXNUM_VALUE(ox); + + CHECK_FIXNUM(oy); + y = FIXNUM_VALUE(oy); + + CHECK_INDEX(owidth); + width = FIXNUM_VALUE(owidth); + + CHECK_INDEX(oheight); + height = FIXNUM_VALUE(oheight); + + /* check &OPTIONAL parameters */ + if (oborder_width == UNSPEC) + border_width = 1; + else + CHECK_INDEX(oborder_width); + else + border_width = FIXNUM_VALUE(oborder_width); + + if (oborder == UNSPEC) + border = BlackPixel(display, DefaultScreen(display)); + else + CHECK_LONGINT(oborder); + else + border = LONGINT_VALUE(oborder); + + if (obackground == UNSPEC) + background = WhitePixel(display, DefaultScreen(display)); + else + CHECK_LONGINT(obackground); + else + background = LONGINT_VALUE(obackground); + + return (OPAQUE( + XCreateSimpleWindow(display, parent, x, y, width, height, + border_width, border, background), + x11Window_t)); +} + +LispObj * +Lisp_XMapWindow(LispBuiltin *builtin) +/* + x-map-window display window + */ +{ + Display *display; + Window window; + + LispObj *odisplay, *owindow; + + owindow = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (!CHECKO(owindow, x11Window_t)) + LispDestroy("%s: cannot convert %s to Window", + STRFUN(builtin), STROBJ(owindow)); + window = (Window)(owindow->data.opaque.data); + + XMapWindow(display, window); + + return (owindow); +} + +LispObj * +Lisp_XDestroyWindow(LispBuiltin *builtin) +/* + x-destroy-window display window + */ +{ + Display *display; + Window window; + + LispObj *odisplay, *owindow; + + owindow = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (!CHECKO(owindow, x11Window_t)) + LispDestroy("%s: cannot convert %s to Window", + STRFUN(builtin), STROBJ(owindow)); + window = (Window)(owindow->data.opaque.data); + + XDestroyWindow(display, window); + + return (NIL); +} + +LispObj * +Lisp_XFlush(LispBuiltin *builtin) +/* + x-flush display + */ +{ + Display *display; + + LispObj *odisplay; + + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + XFlush(display); + + return (odisplay); +} + +LispObj * +Lisp_XDrawLine(LispBuiltin *builtin) +/* + x-draw-line display drawable gc x1 y1 x2 y2 + */ +{ + Display *display; + Drawable drawable; + GC gc; + int x1, y1, x2, y2; + + LispObj *odisplay, *odrawable, *ogc, *ox1, *oy1, *ox2, *oy2; + + oy2 = ARGUMENT(6); + ox2 = ARGUMENT(5); + oy1 = ARGUMENT(4); + ox1 = ARGUMENT(3); + ogc = ARGUMENT(2); + odrawable = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + /* XXX correct check when drawing to pixmaps implemented */ + if (!CHECKO(odrawable, x11Window_t)) + LispDestroy("%s: cannot convert %s to Drawable", + STRFUN(builtin), STROBJ(odrawable)); + drawable = (Drawable)(odrawable->data.opaque.data); + + if (!CHECKO(ogc, x11GC_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(ogc)); + gc = (GC)(ogc->data.opaque.data); + + CHECK_FIXNUM(ox1); + x1 = FIXNUM_VALUE(ox1); + + CHECK_FIXNUM(oy1); + y1 = FIXNUM_VALUE(oy1); + + CHECK_FIXNUM(ox2); + x2 = FIXNUM_VALUE(ox2); + + CHECK_FIXNUM(oy2); + y2 = FIXNUM_VALUE(oy2); + + XDrawLine(display, drawable, gc, x1, y1, x2, y2); + + return (odrawable); +} + +LispObj * +Lisp_XBell(LispBuiltin *builtin) +/* + x-bell &optional percent + */ +{ + Display *display; + int percent; + + LispObj *odisplay, *opercent; + + opercent = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (opercent == UNSPEC) + percent = 0; + else + CHECK_FIXNUM(opercent); + else + percent = FIXNUM_VALUE(opercent); + + if (percent < -100 || percent > 100) + LispDestroy("%s: percent value %d out of range -100 to 100", + STRFUN(builtin), percent); + + XBell(display, percent); + + return (odisplay); +} + +LispObj * +Lisp_XRaiseWindow(LispBuiltin *builtin) +/* + x-raise-window display window + */ +{ + Display *display; + Window window; + + LispObj *odisplay, *owindow; + + owindow = ARGUMENT(1); + odisplay = ARGUMENT(0); + + if (!CHECKO(odisplay, x11Display_t)) + LispDestroy("%s: cannot convert %s to Display*", + STRFUN(builtin), STROBJ(odisplay)); + display = (Display*)(odisplay->data.opaque.data); + + if (!CHECKO(owindow, x11Window_t)) + LispDestroy("%s: cannot convert %s to Window", + STRFUN(builtin), STROBJ(owindow)); + window = (Window)(owindow->data.opaque.data); + + XRaiseWindow(display, window); + + return (owindow); +} + +LispObj * +Lisp_XWidthOfScreen(LispBuiltin *builtin) +/* + x-width-of-screen screen + */ +{ + LispObj *screen; + + screen = ARGUMENT(0); + + if (!CHECKO(screen, x11Screen_t)) + LispDestroy("%s: cannot convert %s to Screen*", + STRFUN(builtin), STROBJ(screen)); + + return (FIXNUM(WidthOfScreen((Screen*)(screen->data.opaque.data)))); +} + +LispObj * +Lisp_XHeightOfScreen(LispBuiltin *builtin) +/* + x-height-of-screen screen + */ +{ + LispObj *screen; + + screen = ARGUMENT(0); + + if (!CHECKO(screen, x11Screen_t)) + LispDestroy("%s: cannot convert %s to Screen*", + STRFUN(builtin), STROBJ(screen)); + + return (FIXNUM(HeightOfScreen((Screen*)(screen->data.opaque.data)))); +} diff --git a/lisp/modules/xaw.c b/lisp/modules/xaw.c new file mode 100644 index 0000000..c2b372b --- /dev/null +++ b/lisp/modules/xaw.c @@ -0,0 +1,665 @@ +/* + * Copyright (c) 2001 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/xaw.c,v 1.14 2002/11/23 08:26:52 paulo Exp $ */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "internal.h" +#include "private.h" + +/* + * Types + */ +typedef struct { + LispObj *object; + void *data; +} WidgetData; + +/* + * Prototypes + */ +int xawLoadModule(void); +void LispXawCleanupCallback(Widget, XtPointer, XtPointer); + +/* until a better/smarter interface be written... */ +LispObj *Lisp_XawCoerceToListReturnStruct(LispBuiltin*); +LispObj *Lisp_XawScrollbarCoerceToReal(LispBuiltin*); + +LispObj *Lisp_XawFormDoLayout(LispBuiltin*); +LispObj *Lisp_XawListChange(LispBuiltin*); +LispObj *Lisp_XawListHighlight(LispBuiltin*); +LispObj *Lisp_XawListUnhighlight(LispBuiltin*); +LispObj *Lisp_XawTextGetSource(LispBuiltin*); +LispObj *Lisp_XawTextLastPosition(LispBuiltin*); +LispObj *Lisp_XawTextReplace(LispBuiltin*); +LispObj *Lisp_XawTextSearch(LispBuiltin*); +LispObj *Lisp_XawTextGetInsertionPoint(LispBuiltin*); +LispObj *Lisp_XawTextSetInsertionPoint(LispBuiltin*); +LispObj *Lisp_XawScrollbarSetThumb(LispBuiltin*); + +/* + * Initialization + */ + +static LispBuiltin lispbuiltins[] = { + {LispFunction, Lisp_XawCoerceToListReturnStruct, "xaw-coerce-to-list-return-struct opaque"}, + {LispFunction, Lisp_XawScrollbarCoerceToReal, "xaw-scrollbar-coerce-to-real opaque"}, + + {LispFunction, Lisp_XawScrollbarSetThumb, "xaw-scrollbar-set-thumb widget top &optional shown"}, + {LispFunction, Lisp_XawFormDoLayout, "xaw-form-do-layout widget force"}, + {LispFunction, Lisp_XawListChange, "xaw-list-change widget list &optional longest resize"}, + {LispFunction, Lisp_XawListHighlight, "xaw-list-highlight widget index"}, + {LispFunction, Lisp_XawListUnhighlight, "xaw-list-unhighlight widget"}, + {LispFunction, Lisp_XawTextGetSource, "xaw-text-get-source widget"}, + {LispFunction, Lisp_XawTextLastPosition, "xaw-text-last-position widget"}, + {LispFunction, Lisp_XawTextReplace, "xaw-text-replace widget left right text"}, + {LispFunction, Lisp_XawTextSearch, "xaw-text-search widget direction text"}, + {LispFunction, Lisp_XawTextGetInsertionPoint, "xaw-text-get-insertion-point widget"}, + {LispFunction, Lisp_XawTextSetInsertionPoint, "xaw-text-set-insertion-point widget position"}, +}; + +LispModuleData xawLispModuleData = { + LISP_MODULE_VERSION, + xawLoadModule +}; + +static int xawWidget_t, xawWidgetClass_t, xawListReturnStruct_t, xawFloatp_t; +static WidgetData **list_data; +static int num_list_data; + +/* + * Implementation + */ +int +xawLoadModule(void) +{ + int i; + char *fname = "XAW-LOAD-MODULE"; + + xawWidget_t = LispRegisterOpaqueType("Widget"); + xawWidgetClass_t = LispRegisterOpaqueType("WidgetClass"); + xawListReturnStruct_t = LispRegisterOpaqueType("XawListReturnStruct"); + xawFloatp_t = LispRegisterOpaqueType("float*"); + + LispExecute("(DEFSTRUCT XAW-LIST-RETURN-STRUCT STRING INDEX)\n"); + + GCDisable(); + (void)LispSetVariable(ATOM2("ASCII-SINK-OBJECT-CLASS"), + OPAQUE(asciiSinkObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("ASCII-SRC-OBJECT-CLASS"), + OPAQUE(asciiSinkObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("ASCII-TEXT-WIDGET-CLASS"), + OPAQUE(asciiTextWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("BOX-WIDGET-CLASS"), + OPAQUE(boxWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("COMMAND-WIDGET-CLASS"), + OPAQUE(commandWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("DIALOG-WIDGET-CLASS"), + OPAQUE(dialogWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("FORM-WIDGET-CLASS"), + OPAQUE(formWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("GRIP-WIDGET-CLASS"), + OPAQUE(gripWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("LABEL-WIDGET-CLASS"), + OPAQUE(labelWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("LIST-WIDGET-CLASS"), + OPAQUE(listWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("MENU-BUTTON-WIDGET-CLASS"), + OPAQUE(menuButtonWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("MULTI-SINK-OBJEC-TCLASS"), + OPAQUE(multiSinkObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("MULTI-SRC-OBJECT-CLASS"), + OPAQUE(multiSrcObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("PANED-WIDGET-CLASS"), + OPAQUE(panedWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("PANNER-WIDGET-CLASS"), + OPAQUE(pannerWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("PORTHOLE-WIDGET-CLASS"), + OPAQUE(portholeWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("REPEATER-WIDGET-CLASS"), + OPAQUE(repeaterWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("SCROLLBAR-WIDGET-CLASS"), + OPAQUE(scrollbarWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("SIMPLE-MENU-WIDGET-CLASS"), + OPAQUE(simpleMenuWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("SIMPLE-WIDGET-CLASS"), + OPAQUE(simpleWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("SME-BSB-OBJECT-CLASS"), + OPAQUE(smeBSBObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("SME-LINE-OBJECT-CLASS"), + OPAQUE(smeLineObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("SME-OBJECT-CLASS"), + OPAQUE(smeObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("STRIP-CHART-WIDGET-CLASS"), + OPAQUE(stripChartWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TEXT-WIDGET-CLASS"), + OPAQUE(textWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TEXT-SINKOBJECT-CLASS"), + OPAQUE(textSinkObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TEXT-SRC-OBJECT-CLASS"), + OPAQUE(textSrcObjectClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TIP-WIDGET-CLASS"), + OPAQUE(tipWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TOGGLE-WIDGET-CLASS"), + OPAQUE(toggleWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TREE-WIDGET-CLASS"), + OPAQUE(treeWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("VIEWPORT-WIDGET-CLASS"), + OPAQUE(viewportWidgetClass, xawWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("VENDOR-SHELL-WIDGET-CLASS"), + OPAQUE(vendorShellWidgetClass, xawWidgetClass_t), + fname, 0); + + /* return codes of XawTextReplace */ + (void)LispSetVariable(ATOM2("XAW-REPLACE-ERROR"), + INTEGER(XawReplaceError), fname, 0); + (void)LispSetVariable(ATOM2("XAW-EDIT-DONE"), + INTEGER(XawEditDone), fname, 0); + (void)LispSetVariable(ATOM2("XAW-EDIT-ERROR"), + INTEGER(XawEditError), fname, 0); + (void)LispSetVariable(ATOM2("XAW-POSITION-ERROR"), + INTEGER(XawPositionError), fname, 0); + + /* return code of XawTextSearch */ + (void)LispSetVariable(ATOM2("XAW-TEXT-SEARCH-ERROR"), + INTEGER(XawTextSearchError), fname, 0); + + /* enum XawTextScanDirection */ + (void)LispSetVariable(ATOM2("XAWSD-LEFT"), + INTEGER(XawsdLeft), fname, 0); + (void)LispSetVariable(ATOM2("XAWSD-RIGHT"), + INTEGER(XawsdRight), fname, 0); + GCEnable(); + + for (i = 0; i < sizeof(lispbuiltins) / sizeof(lispbuiltins[0]); i++) + LispAddBuiltinFunction(&lispbuiltins[i]); + + return (1); +} + +void +LispXawCleanupCallback(Widget w, XtPointer user_data, XtPointer call_data) +{ + WidgetData *data = (WidgetData*)user_data; + + UPROTECT(CAR(data->object), data->object); + XtFree((XtPointer)data->data); + XtFree((XtPointer)data); +} + +LispObj * +Lisp_XawCoerceToListReturnStruct(LispBuiltin *builtin) +/* + xaw-coerce-to-list-return-struct opaque + */ +{ + LispObj *result, *code, *ocod = COD; + XawListReturnStruct *retlist; + + LispObj *opaque; + + opaque = ARGUMENT(0); + + if (!CHECKO(opaque, xawListReturnStruct_t)) + LispDestroy("%s: cannot convert %s to XawListReturnStruct", + STRFUN(builtin), STROBJ(opaque)); + + retlist = (XawListReturnStruct*)(opaque->data.opaque.data); + + GCDisable(); + code = CONS(ATOM("MAKE-XAW-LIST-RETURN-STRUCT"), + CONS(KEYWORD("STRING"), + CONS(STRING(retlist->string), + CONS(KEYWORD("INDEX"), + CONS(INTEGER(retlist->list_index), NIL))))); + COD = CONS(code, COD); + GCEnable(); + + result = EVAL(code); + COD = ocod; + + return (result); +} + +LispObj * +Lisp_XawScrollbarCoerceToReal(LispBuiltin *builtin) +/* + xaw-scrollbar-coerce-to-real opaque + */ +{ + LispObj *result; + float *floatp; + double real; + + LispObj *opaque; + + opaque = ARGUMENT(0); + + if (!CHECKO(opaque, xawFloatp_t)) + LispDestroy("%s: cannot convert %s to float*", + STRFUN(builtin), STROBJ(opaque)); + + floatp = (float*)(opaque->data.opaque.data); + real = *floatp; + + return (DFLOAT(real)); +} + +LispObj * +Lisp_XawFormDoLayout(LispBuiltin *builtin) +/* + xaw-form-do-layout widget force + */ +{ + int force; + + LispObj *owidget, *oforce; + + oforce = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + + force = oforce != NIL; + XawFormDoLayout((Widget)(owidget->data.opaque.data), force); + + return (oforce); +} + +LispObj * +Lisp_XawTextGetSource(LispBuiltin *builtin) +/* + xaw-text-get-source widget + */ +{ + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + + return (OPAQUE(XawTextGetSource((Widget)(owidget->data.opaque.data)), + xawWidget_t)); +} + +LispObj * +Lisp_XawTextLastPosition(LispBuiltin *builtin) +/* + xaw-text-last-position widget + */ +{ + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + + return (FIXNUM(XawTextLastPosition((Widget)(owidget->data.opaque.data)))); +} + +LispObj * +Lisp_XawTextGetInsertionPoint(LispBuiltin *builtin) +/* + xaw-text-get-insertion-point widget + */ +{ + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + + return (FIXNUM(XawTextGetInsertionPoint((Widget)(owidget->data.opaque.data)))); +} + +LispObj * +Lisp_XawTextSetInsertionPoint(LispBuiltin *builtin) +/* + xaw-text-set-insertion-point widget position + */ +{ + Widget widget; + XawTextPosition position; + + LispObj *owidget, *oposition; + + oposition = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + + CHECK_INDEX(oposition); + position = (XawTextPosition)FIXNUM_VALUE(oposition); + + XawTextSetInsertionPoint(widget, position); + + return (oposition); +} + +LispObj * +Lisp_XawTextReplace(LispBuiltin *builtin) +/* + xaw-text-replace widget left right text + */ +{ + Widget widget; + XawTextPosition left, right; + XawTextBlock block; + + LispObj *owidget, *oleft, *oright, *otext; + + otext = ARGUMENT(3); + oright = ARGUMENT(2); + oleft = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + + CHECK_INDEX(oleft); + left = (XawTextPosition)FIXNUM_VALUE(oleft); + + CHECK_INDEX(oright); + right = (XawTextPosition)FIXNUM_VALUE(oright); + + CHECK_STRING(otext); + block.firstPos = 0; + block.ptr = THESTR(otext); + block.length = strlen(block.ptr); + block.format = FMT8BIT; + + return (FIXNUM(XawTextReplace(widget, left, right, &block))); +} + +LispObj * +Lisp_XawTextSearch(LispBuiltin *builtin) +/* + xaw-text-search widget direction text + */ +{ + Widget widget; + XawTextScanDirection direction; + XawTextBlock block; + + LispObj *owidget, *odirection, *otext; + + otext = ARGUMENT(2); + odirection = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + + CHECK_INDEX(odirection); + direction = (XawTextPosition)FIXNUM_VALUE(odirection); + if (direction != XawsdLeft && direction != XawsdRight) + LispDestroy("%s: %d does not fit in XawTextScanDirection", + STRFUN(builtin), direction); + + CHECK_STRING(otext); + block.firstPos = 0; + block.ptr = THESTR(otext); + block.length = strlen(block.ptr); + block.format = FMT8BIT; + + return (FIXNUM(XawTextSearch(widget, direction, &block))); +} + +LispObj * +Lisp_XawListChange(LispBuiltin *builtin) +/* + xaw-list-change widget list &optional longest resize + */ +{ + Widget widget; + String *list; + int i, nitems; + int longest; + Boolean resize; + LispObj *object; + WidgetData *data; + + LispObj *owidget, *olist, *olongest, *oresize; + + oresize = ARGUMENT(3); + olongest = ARGUMENT(2); + olist = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + + CHECK_LIST(olist); + for (nitems = 0, object = olist; CONSP(object); + ++nitems, object = CDR(object)) + CHECK_STRING(CAR(object)); + + if (olongest != UNSPEC) { + CHECK_INDEX(olongest); + longest = FIXNUM_VALUE(olongest); + } + else + XtVaGetValues(widget, XtNlongest, &longest, NULL, 0); + resize = oresize != UNSPEC && oresize != NIL; + + /* No errors in arguments, build string list */ + list = (String*)XtMalloc(sizeof(String) * nitems); + for (i = 0, object = olist; CONSP(object); i++, object = CDR(object)) + list[i] = THESTR(CAR(object)); + + /* Check if xaw-list-change was already called + * for this widget and free previous data */ + for (i = 0; i < num_list_data; i++) + if ((Widget)CAR(list_data[i]->object)->data.opaque.data == widget) { + XtRemoveCallback(widget, XtNdestroyCallback, + LispXawCleanupCallback, list_data[i]); + LispXawCleanupCallback(widget, list_data[i], NULL); + break; + } + + if (i >= num_list_data) { + ++num_list_data; + list_data = (WidgetData**)XtRealloc((XtPointer)list_data, + sizeof(WidgetData*) * num_list_data); + } + + data = (WidgetData*)XtMalloc(sizeof(WidgetData)); + data->data = list; + list_data[i] = data; + data->object = CONS(owidget, olist); + PROTECT(owidget, data->object); + XtAddCallback(widget, XtNdestroyCallback, LispXawCleanupCallback, data); + + XawListChange(widget, list, nitems, longest, resize); + + return (olist); +} + +LispObj * +Lisp_XawListHighlight(LispBuiltin *builtin) +/* + xaw-list-highlight widget index + */ +{ + Widget widget; + int position; + + LispObj *owidget, *oindex; + + oindex = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + + CHECK_INDEX(oindex); + position = FIXNUM_VALUE(oindex); + + XawListHighlight(widget, position); + + return (oindex); +} + +LispObj * +Lisp_XawListUnhighlight(LispBuiltin *builtin) +/* + xaw-list-unhighlight widget + */ +{ + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + + XawListUnhighlight((Widget)(owidget->data.opaque.data)); + + return (NIL); +} + +LispObj * +Lisp_XawScrollbarSetThumb(LispBuiltin *builtin) +/* + xaw-scrollbar-set-thumb widget top &optional shown + */ +{ + Widget widget; + double top, shown; + + LispObj *owidget, *otop, *oshown; + + oshown = ARGUMENT(2); + otop = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xawWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + + CHECK_DFLOAT(otop); + top = DFLOAT_VALUE(otop); + + if (oshown == UNSPEC) + shown = 1.0; + else { + CHECK_DFLOAT(oshown); + shown = DFLOAT_VALUE(oshown); + } + + XawScrollbarSetThumb(widget, top, shown); + + return (oshown == UNSPEC ? DFLOAT(shown) : oshown); +} diff --git a/lisp/modules/xedit.lsp b/lisp/modules/xedit.lsp new file mode 100644 index 0000000..87a85c7 --- /dev/null +++ b/lisp/modules/xedit.lsp @@ -0,0 +1,560 @@ +;; +;; 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/xedit.lsp,v 1.10 2003/01/16 06:25:50 paulo Exp $ +;; + +(provide "xedit") + +#+debug (make-package "XEDIT" :use '("LISP" "EXT")) +(in-package "XEDIT") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; TODO The user should be able to define *auto-modes* prior to the +;; initialization here in a configuration file, since defvar only binds +;; the variable if it is unbound or doesn't have a value defined. +;; *auto-modes* is a list of conses where every car is compiled +;; to a regexp to match the name of the file being loaded. The caddr is +;; either a string, a pathname, or a syntax-p. +;; When loading a file, if the regexp in the car matches, it will check +;; the caddr value, and if it is a: +;; string: executes (load "progmodes/.lsp") +;; pathname: executes (load ) +;; syntax-p: does nothing, already loaded +;; +;; If it fails to load the file, or the returned value is not a +;; syntax-p, the entry is removed. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar *auto-modes* '( + ("\\.(c|cc|C|cxx|h|bm|xbm|xpm|l|y)$" + "C/C++" "c" . *c-mode*) + ("\\.(li?sp|scm)$" + "Lisp/Scheme" "lisp" . *lisp-mode*) + ("Imakefile|(\\.(cf|rules|tmpl|def|cpp)$)" + "X imake" "imake" . *imake-mode*) + ("[Mm]akefile.*|\\.mk$" + "Makefile" "make" . *make-mode*) + ("\\.sh$" + "Unix shell" "sh" . *sh-mode*) + ("\\.sgml?$" + "SGML" "sgml" . *sgml-mode*) + ("\\.html?$" + "HTML" "html" . *html-mode*) + ("\\.(man|\\d)$" + "Man page" "man" . *man-mode*) + ("app-defaults/\\w+|\\u[A-Za-z0-9_-]+\\.ad" + "X resource" "xrdb" . *xrdb-mode*) + ("\\bolditalic +;; would render "bold" using a bold version of the default font, +;; and "italic" using a bold and italic version of the default font +(defstruct xlfd + foundry + family + weight + slant + setwidth + addstyle + pixel-size + point-size + res-x + res-y + spacing + avgwidth + registry + encoding +) + + +;; At some time this structure should also hold information for at least: +;; o fontset +;; o foreground pixmap +;; o background pixmap +;; XXX This is also a TODO in Xaw. +(defstruct synprop + quark ;; XrmQuark identifier of the XawTextProperty + ;; structure. This field is filled when "compiling" + ;; the syntax-table. + + name ;; String name of property, must be unique per + ;; property list. + font ;; Optional font string name of property. + foreground ;; Optional string representation of foreground color. + background ;; Optional string representation of background color. + xlfd ;; Optional xlfd structure, when combining properties. + ;; Currently combining properties logic not implemented, + ;; but fonts may be specified using the xlfd definition. + + ;; Boolean properties. + underline ;; Draw a line below the text. + overstrike ;; Draw a line over the text. + + ;; XXX Are these working in Xaw? + subscript ;; Align text to the bottom of the line. + superscript ;; Align text to the top of the line. + ;; Note: subscript and superscript only have effect when the text + ;; line has different height fonts displayed. +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utility macro, to create a "special" variable holding +;; a synprop structure. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro defsynprop (variable name + &key font foreground background xlfd underline + overstrike subscript superscript) + `(progn + (proclaim '(special ,variable)) + (setq ,variable + (make-synprop + :name ,name + :font ,font + :foreground ,foreground + :background ,background + :xlfd ,xlfd + :underline ,underline + :overstrike ,overstrike + :subscript ,subscript + :superscript ,superscript + ) + ) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Convert a synprop structure to a string in the format +;; expected by Xaw. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun synprop-to-string (synprop &aux values booleans xlfd) + (if (setq xlfd (synprop-xlfd synprop)) + (dolist + (element + `( + ("foundry" ,(xlfd-foundry xlfd)) + ("family" ,(xlfd-family xlfd)) + ("weight" ,(xlfd-weight xlfd)) + ("slant" ,(xlfd-slant xlfd)) + ("setwidth" ,(xlfd-setwidth xlfd)) + ("addstyle" ,(xlfd-addstyle xlfd)) + ("pixelsize" ,(xlfd-pixel-size xlfd)) + ("pointsize" ,(xlfd-point-size xlfd)) + ("resx" ,(xlfd-res-x xlfd)) + ("resy" ,(xlfd-res-y xlfd)) + ("spacing" ,(xlfd-spacing xlfd)) + ("avgwidth" ,(xlfd-avgwidth xlfd)) + ("registry" ,(xlfd-registry xlfd)) + ("encoding" ,(xlfd-encoding xlfd)) + ) + ) + (if (cadr element) + (setq values (append values element)) + ) + ) + ) + (dolist + (element + `( + ("font" ,(synprop-font synprop)) + ("foreground" ,(synprop-foreground synprop)) + ("background" ,(synprop-background synprop)) + ) + ) + (if (cadr element) + (setq values (append values element)) + ) + ) + + ;; Boolean attributes. These can be specified in the format + ;; =, but do a nicer output as the format + ;; is accepted. + (dolist + (element + `( + ("underline" ,(synprop-underline synprop)) + ("overstrike" ,(synprop-overstrike synprop)) + ("subscript" ,(synprop-subscript synprop)) + ("superscript" ,(synprop-superscript synprop)) + ) + ) + (if (cadr element) + (setq booleans (append booleans element)) + ) + ) + + ;; Play with format conditionals, list iteration, and goto, to + ;; make resulting string. + (format + nil + "~A~:[~;?~]~:[~3*~;~A=~A~{&~A=~A~}~]~:[~;&~]~:[~2*~;~A~{&~A~*~}~]" + + (synprop-name synprop) ;; ~A + (or values booleans) ;; ~:[~;?~] + values ;; ~:[ + (car values) (cadr values) (cddr values) ;; ~A=~A~{&~A=~A~} + (and values booleans) ;; ~:[~;&~] + booleans ;; ~:[ + (car booleans) (cddr booleans) ;; ~A~{&~A~*~} + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Use xedit protocol to create a XawTextPropertyList with the +;; given arguments. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compile-syntax-property-list (name properties + &aux string-properties quark) + + ;; Create a string representation of the properties. + (dolist (property properties) + (setq + string-properties + (append + string-properties + (list (synprop-to-string property)) + ) + ) + ) + + (setq + string-properties + (case (length string-properties) + (0 "") + (1 (car string-properties)) + (t (format nil "~A~{,~A~}" + (car string-properties) + (cdr string-properties) + ) + ) + ) + ) + +#+debug + (format *output* "~Cconvert-property-list ~S ~S~%" + *escape* + name + string-properties + ) + (setq quark #-debug (convert-property-list name string-properties) + #+debug 0) + + ;; Store the quark for properties not yet "initialized". + ;; XXX This is just a call to Xrm{Perm,}StringToQuark, and should + ;; be made available if there were a wrapper/interface to + ;; that Xlib function. + (dolist (property properties) + (unless (integerp (synprop-quark property)) +#+debug + (format *output* "~Cxrm-string-to-quark ~S~%" + *escape* + (synprop-name property) + ) + (setf + (synprop-quark property) +#-debug (xrm-string-to-quark (synprop-name property)) +#+debug 0 + ) + ) + ) + + quark +) + + + + +#+debug +(progn + (defconstant *escape* #\$) + + (defconstant *output* *standard-output*) + + ;; Recognized identifiers for wrap mode. + (defconstant *wrap-modes* '(:never :line :word)) + + ;; Recognized identifiers for justification. + (defconstant *justifications* '(:left :right :center :full)) + + ;; XawTextScanType + (defconstant *scan-type* + '(:positions :white-space :eol :paragraph :all :alpha-numeric)) + + ;; XawTextScanDirection + (defconstant *scan-direction* '(:left :right)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Debugging version of xedit functions. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defun clear-entities (left right) + (format *output* "~Cclear-entities ~D ~D~%" + *escape* left right)) + + (defun add-entity (offset length identifier) + (format *output* "~Cadd-entity ~D ~D ~D~%" + *escape* offset length identifier)) + + (defun background (&optional (value nil specified)) + (if specified + (format *output* "~Cset-background ~S~%" *escape* value) + (format *output* "~Cget-background~%" *escape*))) + + (defun foreground (&optional (value nil specified)) + (if specified + (format *output* "~Cset-foreground ~S~%" *escape* value) + (format *output* "~Cget-foreground~%" *escape*))) + + (defun font (&optional (value nil specified)) + (if specified + (format *output* "~Cset-font ~S~%" *escape* value) + (format *output* "~Cget-font~%" *escape*))) + + (defun point (&optional (value nil specified)) + (if specified + (format *output* "~Cset-point ~D~%" *escape* value) + (format *output* "~Cget-point~%" *escape*))) + + (defun point-min () + (format *output* "~Cpoint-min~%" *escape*)) + + (defun point-max () + (format *output* "~Cpoint-max~%" *escape*)) + + (defun property-list (&optional (quark nil specified)) + (format *output* "~property-list ~D~%" *escape* quark)) + + (defun insert (string) + (format *output* "~Cinsert ~S~%" *escape* string)) + + (defun read-text (offset length) + (format *output* "~Cread-text ~D ~D~%" + *escape* offset length)) + + (defun replace-text (left right string) + (format *output* "~Creplace-text ~D ~D ~S~%" + *escape* left right string)) + + (defun scan (offset type direction &key (count 1) include) + (unless (setq type (position type *scan-type*)) + (error "SCAN: type must be one of ~A, not ~A" + *scan-type* type)) + (unless (setq direction (position direction *scan-direction*)) + (error "SCAN: direction must be one of ~A, not ~A" + *scan-direction* direction)) + (format *output* "~Cscan ~D ~D ~D ~D ~D~%" + *escape* offset type direction count (if include 1 0))) + + (defun search-forward (string &optional case-sensitive) + (format *output* "~Csearch-forward ~S ~D~%" + *escape* string (if case-sensitive 1 0))) + + (defun search-backward (string &optional case-sensitive) + (format *output* "~Csearch-backward ~S ~D~%" + *escape* string (if case-sensitive 1 0))) + + (defun wrap-mode (&optional (value nil specified)) + (if specified + (progn + (unless (member value *wrap-modes*) + (error "WRAP-MODE: argument must be one of ~A, not ~A" + *wrap-modes* value)) + (format *output* "~Cset-wrap-mode ~S~%" + *escape* (string value))) + (format *output* "~Cget-wrap-mode~%" *escape*))) + + (defun auto-fill (&optional (value nil specified)) + (if specified + (format *output* "~Cset-auto-fill ~S~%" + *escape* (if value "true" "false")) + (format *output* "~Cget-auto-fill~%" *escape*))) + + (defun justification (&optional (value nil specified)) + (if specified + (progn + (unless (member value *justifications*) + (error "JUSTIFICATION: argument must be one of ~A, not ~A" + *justifications* value)) + (format *output* "~Cset-justification ~S~%" + *escape* (string value))) + (format *output* "~Cget-justification~%" *escape*))) + + (defun left-column (&optional (value nil specified)) + (if specified + (format *output* "~Cset-left-column ~D~%" *escape* value) + (format *output* "~Cget-left-column~%" *escape*))) + + (defun right-column (&optional (value nil specified)) + (if specified + (format *output* "~Cset-right-column ~D~%" *escape* value) + (format *output* "~Cget-right-column~%" *escape*))) + + (defun vertical-scrollbar (&optional (value nil specified)) + (if specified + (format *output* "~Cset-vert-scrollbar ~S~%" + *escape* (if value "always" "never")) + (format *output* "~Cget-vert-scrollbar~%" *escape*))) + + (defun horizontal-scrollbar (&optional (value nil specified)) + (if specified + (format *output* "~Cset-horiz-scrollbar ~S~%" + *escape* (if value "always" "never")) + (format *output* "~Cget-horiz-scrollbar~%" *escape*))) + + #||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + (defun create-buffer (name) + (format *output* "~Ccreate-buffer ~S~%" *escape* name)) + + (defun remove-buffer (name) + (format *output* "~Cremove-buffer ~S~%" *escape* name)) + + (defun buffer-name (&optional (value nil specified)) + (if specified + (format *output* "~Cset-buffer-name ~S~%" *escape* value) + (format *output* "~Cget-buffer-name~%" *escape*))) + + (defun buffer-filename (&optional (value nil specified)) + (if specified + (format *output* "~Cset-buffer-filename ~S~%" + *escape* (namestring value)) + (format *output* "~Cget-buffer-filename~%" *escape*))) + + (defun current-buffer (&optional (value nil specified)) + (if specified + (format *output* "~Cset-current-buffer ~S~%" *escape* value) + (format *output* "~Cget-current-buffer~%" *escape*))) + + (defun other-buffer (&optional (value nil specified)) + (if specified + (format *output* "~Cset-other-buffer ~S~%" *escape* value) + (format *output* "~Cget-other-buffer~%" *escape*))) + |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||# +) diff --git a/lisp/modules/xt.c b/lisp/modules/xt.c new file mode 100644 index 0000000..13c7ae7 --- /dev/null +++ b/lisp/modules/xt.c @@ -0,0 +1,1797 @@ +/* + * Copyright (c) 2001 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/xt.c,v 1.19 2002/11/23 08:26:52 paulo Exp $ */ + +#include +#include +#include +#include +#include +#include +#include "internal.h" +#include "private.h" + +/* + * Types + */ +typedef struct { + XrmQuark qname; + XrmQuark qtype; + Cardinal size; +} ResourceInfo; + +typedef struct { + WidgetClass widget_class; + ResourceInfo **resources; + Cardinal num_resources; + Cardinal num_cons_resources; +} ResourceList; + +typedef struct { + Arg *args; + Cardinal num_args; +} Resources; + +typedef struct { + LispObj *data; + /* data is => (list* widget callback argument) */ +} CallbackArgs; + +/* + * Prototypes + */ +int xtLoadModule(LispMac*); +void LispXtCleanupCallback(Widget, XtPointer, XtPointer); + +void LispXtCallback(Widget, XtPointer, XtPointer); +void LispXtInputCallback(XtPointer, int*, XtInputId*); + +/* a hack... */ +LispObj *Lisp_XtCoerceToWidgetList(LispBuiltin*); + +LispObj *Lisp_XtAddCallback(LispBuiltin*); +LispObj *Lisp_XtAppInitialize(LispBuiltin*); +LispObj *Lisp_XtAppMainLoop(LispBuiltin*); +LispObj *Lisp_XtAppAddInput(LispBuiltin*); +LispObj *Lisp_XtAppPending(LispBuiltin*); +LispObj *Lisp_XtAppProcessEvent(LispBuiltin*); +LispObj *Lisp_XtCreateWidget(LispBuiltin*); +LispObj *Lisp_XtCreateManagedWidget(LispBuiltin*); +LispObj *Lisp_XtCreatePopupShell(LispBuiltin*); +LispObj *Lisp_XtDestroyWidget(LispBuiltin*); +LispObj *Lisp_XtGetKeyboardFocusWidget(LispBuiltin*); +LispObj *Lisp_XtGetValues(LispBuiltin*); +LispObj *Lisp_XtManageChild(LispBuiltin*); +LispObj *Lisp_XtUnmanageChild(LispBuiltin*); +LispObj *Lisp_XtSetMappedWhenManaged(LispBuiltin*); +LispObj *Lisp_XtMapWidget(LispBuiltin*); +LispObj *Lisp_XtName(LispBuiltin*); +LispObj *Lisp_XtParent(LispBuiltin*); +LispObj *Lisp_XtUnmapWidget(LispBuiltin*); +LispObj *Lisp_XtPopup(LispBuiltin*); +LispObj *Lisp_XtPopdown(LispBuiltin*); +LispObj *Lisp_XtIsRealized(LispBuiltin*); +LispObj *Lisp_XtRealizeWidget(LispBuiltin*); +LispObj *Lisp_XtUnrealizeWidget(LispBuiltin*); +LispObj *Lisp_XtRemoveInput(LispBuiltin*); +LispObj *Lisp_XtSetSensitive(LispBuiltin*); +LispObj *Lisp_XtSetValues(LispBuiltin*); +LispObj *Lisp_XtWidgetToApplicationContext(LispBuiltin*); +LispObj *Lisp_XtDisplay(LispBuiltin*); +LispObj *Lisp_XtDisplayOfObject(LispBuiltin*); +LispObj *Lisp_XtScreen(LispBuiltin*); +LispObj *Lisp_XtScreenOfObject(LispBuiltin*); +LispObj *Lisp_XtSetKeyboardFocus(LispBuiltin*); +LispObj *Lisp_XtWindow(LispBuiltin*); +LispObj *Lisp_XtWindowOfObject(LispBuiltin*); +LispObj *Lisp_XtAddGrab(LispBuiltin*); +LispObj *Lisp_XtRemoveGrab(LispBuiltin*); +LispObj *Lisp_XtAppGetExitFlag(LispBuiltin*); +LispObj *Lisp_XtAppSetExitFlag(LispBuiltin*); + +LispObj *LispXtCreateWidget(LispBuiltin*, int); + +static Resources *LispConvertResources(LispObj*, Widget, + ResourceList*, ResourceList*); +static void LispFreeResources(Resources*); + +static int bcmp_action_resource(_Xconst void*, _Xconst void*); +static ResourceInfo *GetResourceInfo(char*, ResourceList*, ResourceList*); +static ResourceList *GetResourceList(WidgetClass); +static int bcmp_action_resource_list(_Xconst void*, _Xconst void*); +static ResourceList *FindResourceList(WidgetClass); +static int qcmp_action_resource_list(_Xconst void*, _Xconst void*); +static ResourceList *CreateResourceList(WidgetClass); +static int qcmp_action_resource(_Xconst void*, _Xconst void*); +static void BindResourceList(ResourceList*); + +static void PopdownAction(Widget, XEvent*, String*, Cardinal*); +static void QuitAction(Widget, XEvent*, String*, Cardinal*); + +/* + * Initialization + */ +static LispBuiltin lispbuiltins[] = { + {LispFunction, Lisp_XtCoerceToWidgetList, "xt-coerce-to-widget-list number opaque"}, + + {LispFunction, Lisp_XtAddGrab, "xt-add-grab widget exclusive spring-loaded"}, + {LispFunction, Lisp_XtAddCallback, "xt-add-callback widget callback-name callback &optional client-data"}, + {LispFunction, Lisp_XtAppAddInput, "xt-app-add-input app-context fileno condition function &optional client-data"}, + {LispFunction, Lisp_XtAppInitialize, "xt-app-initialize app-context-return application-class &optional options fallback-resources"}, + {LispFunction, Lisp_XtAppPending, "xt-app-pending app-context"}, + {LispFunction, Lisp_XtAppMainLoop, "xt-app-main-loop app-context"}, + {LispFunction, Lisp_XtAppProcessEvent, "xt-app-process-event app-context &optional mask"}, + {LispFunction, Lisp_XtAppGetExitFlag, "xt-app-get-exit-flag app-context"}, + {LispFunction, Lisp_XtAppSetExitFlag, "xt-app-set-exit-flag app-context"}, + {LispFunction, Lisp_XtCreateManagedWidget, "xt-create-managed-widget name widget-class parent &optional arguments"}, + {LispFunction, Lisp_XtCreateWidget, "xt-create-widget name widget-class parent &optional arguments"}, + {LispFunction, Lisp_XtCreatePopupShell, "xt-create-popup-shell name widget-class parent &optional arguments"}, + {LispFunction, Lisp_XtDestroyWidget, "xt-destroy-widget widget"}, + {LispFunction, Lisp_XtGetKeyboardFocusWidget, "xt-get-keyboard-focus-widget widget"}, + {LispFunction, Lisp_XtGetValues, "xt-get-values widget arguments"}, + {LispFunction, Lisp_XtManageChild, "xt-manage-child widget"}, + {LispFunction, Lisp_XtName, "xt-name widget"}, + {LispFunction, Lisp_XtUnmanageChild, "xt-unmanage-child widget"}, + {LispFunction, Lisp_XtMapWidget, "xt-map-widget widget"}, + {LispFunction, Lisp_XtUnmapWidget, "xt-unmap-widget widget"}, + {LispFunction, Lisp_XtSetMappedWhenManaged, "xt-set-mapped-when-managed widget map-when-managed"}, + {LispFunction, Lisp_XtParent, "xt-parent widget"}, + {LispFunction, Lisp_XtPopup, "xt-popup widget grab-kind"}, + {LispFunction, Lisp_XtPopdown, "xt-popdown widget"}, + {LispFunction, Lisp_XtIsRealized, "xt-is-realized widget"}, + {LispFunction, Lisp_XtRealizeWidget, "xt-realize-widget widget"}, + {LispFunction, Lisp_XtUnrealizeWidget, "xt-unrealize-widget widget"}, + {LispFunction, Lisp_XtRemoveInput, "xt-remove-input input"}, + {LispFunction, Lisp_XtRemoveGrab, "xt-remove-grab widget"}, + {LispFunction, Lisp_XtSetKeyboardFocus, "xt-set-keyboard-focus widget descendant"}, + {LispFunction, Lisp_XtSetSensitive, "xt-set-sensitive widget sensitive"}, + {LispFunction, Lisp_XtSetValues, "xt-set-values widget arguments"}, + {LispFunction, Lisp_XtWidgetToApplicationContext, "xt-widget-to-application-context widget"}, + {LispFunction, Lisp_XtDisplay, "xt-display widget"}, + {LispFunction, Lisp_XtDisplayOfObject, "xt-display-of-object object"}, + {LispFunction, Lisp_XtScreen, "xt-screen widget"}, + {LispFunction, Lisp_XtScreenOfObject, "xt-screen-of-object object"}, + {LispFunction, Lisp_XtWindow, "xt-window widget"}, + {LispFunction, Lisp_XtWindowOfObject, "xt-window-of-object object"}, +}; + +LispModuleData xtLispModuleData = { + LISP_MODULE_VERSION, + xtLoadModule, +}; + +static ResourceList **resource_list; +static Cardinal num_resource_list; + +static Atom delete_window; +static int xtAppContext_t, xtWidget_t, xtWidgetClass_t, xtWidgetList_t, + xtInputId_t, xtDisplay_t, xtScreen_t, xtWindow_t; + +static XtActionsRec actions[] = { + {"xt-popdown", PopdownAction}, + {"xt-quit", QuitAction}, +}; + +static XrmQuark qCardinal, qInt, qString, qWidget, qFloat; + +static CallbackArgs **input_list; +static Cardinal num_input_list, size_input_list; + +/* + * Implementation + */ +int +xtLoadModule(void) +{ + int i; + char *fname = "XT-LOAD-MODULE"; + + xtAppContext_t = LispRegisterOpaqueType("XtAppContext"); + xtWidget_t = LispRegisterOpaqueType("Widget"); + xtWidgetClass_t = LispRegisterOpaqueType("WidgetClass"); + xtWidgetList_t = LispRegisterOpaqueType("WidgetList"); + xtInputId_t = LispRegisterOpaqueType("XtInputId"); + xtDisplay_t = LispRegisterOpaqueType("Display*"); + xtScreen_t = LispRegisterOpaqueType("Screen*"); + xtWindow_t = LispRegisterOpaqueType("Window"); + + LispExecute("(DEFSTRUCT XT-WIDGET-LIST NUM-CHILDREN CHILDREN)\n"); + + GCDisable(); + (void)LispSetVariable(ATOM2("CORE-WIDGET-CLASS"), + OPAQUE(coreWidgetClass, xtWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("COMPOSITE-WIDGET-CLASS"), + OPAQUE(compositeWidgetClass, xtWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("CONSTRAINT-WIDGET-CLASS"), + OPAQUE(constraintWidgetClass, xtWidgetClass_t), + fname, 0); + (void)LispSetVariable(ATOM2("TRANSIENT-SHELL-WIDGET-CLASS"), + OPAQUE(transientShellWidgetClass, xtWidgetClass_t), + fname, 0); + + /* parameters for XtPopup */ + (void)LispSetVariable(ATOM2("XT-GRAB-EXCLUSIVE"), + INTEGER(XtGrabExclusive), fname, 0); + (void)LispSetVariable(ATOM2("XT-GRAB-NONE"), + INTEGER(XtGrabNone), fname, 0); + (void)LispSetVariable(ATOM2("XT-GRAB-NONE-EXCLUSIVE"), + INTEGER(XtGrabNonexclusive), fname, 0); + + /* parameters for XtAppProcessEvent */ + (void)LispSetVariable(ATOM2("XT-IM-XEVENT"), + INTEGER(XtIMXEvent), fname, 0); + (void)LispSetVariable(ATOM2("XT-IM-TIMER"), + INTEGER(XtIMTimer), fname, 0); + (void)LispSetVariable(ATOM2("XT-IM-ALTERNATE-INPUT"), + INTEGER(XtIMAlternateInput), fname, 0); + (void)LispSetVariable(ATOM2("XT-IM-SIGNAL"), + INTEGER(XtIMSignal), fname, 0); + (void)LispSetVariable(ATOM2("XT-IM-ALL"), + INTEGER(XtIMAll), fname, 0); + + /* parameters for XtAppAddInput */ + (void)LispSetVariable(ATOM2("XT-INPUT-READ-MASK"), + INTEGER(XtInputReadMask), fname, 0); + (void)LispSetVariable(ATOM2("XT-INPUT-WRITE-MASK"), + INTEGER(XtInputWriteMask), fname, 0); + (void)LispSetVariable(ATOM2("XT-INPUT-EXCEPT-MASK"), + INTEGER(XtInputExceptMask), fname, 0); + GCEnable(); + + qCardinal = XrmPermStringToQuark(XtRCardinal); + qInt = XrmPermStringToQuark(XtRInt); + qString = XrmPermStringToQuark(XtRString); + qWidget = XrmPermStringToQuark(XtRWidget); + qFloat = XrmPermStringToQuark(XtRFloat); + + for (i = 0; i < sizeof(lispbuiltins) / sizeof(lispbuiltins[0]); i++) + LispAddBuiltinFunction(&lispbuiltins[i]); + + return (1); +} + +void +LispXtCallback(Widget w, XtPointer user_data, XtPointer call_data) +{ + CallbackArgs *args = (CallbackArgs*)user_data; + LispObj *code, *ocod = COD; + + GCDisable(); + /* callback name */ /* reall caller */ + code = CONS(CDR(CDR(args->data)), CONS(OPAQUE(w, xtWidget_t), + CONS(CAR(CDR(args->data)), CONS(OPAQUE(call_data, 0), NIL)))); + /* user arguments */ + COD = CONS(code, COD); + GCEnable(); + + (void)EVAL(code); + COD = ocod; +} + + +void +LispXtCleanupCallback(Widget w, XtPointer user_data, XtPointer call_data) +{ + CallbackArgs *args = (CallbackArgs*)user_data; + + UPROTECT(CAR(args->data), args->data); + XtFree((XtPointer)args); +} + +void +LispXtInputCallback(XtPointer closure, int *source, XtInputId *id) +{ + CallbackArgs *args = (CallbackArgs*)closure; + LispObj *code, *ocod = COD; + + GCDisable(); + /* callback name */ /* user arguments */ + code = CONS(CDR(CDR(args->data)), CONS(CAR(CDR(args->data)), + CONS(INTEGER(*source), CONS(CAR(args->data), NIL)))); + /* input source */ /* input id */ + COD = CONS(code, COD); + GCEnable(); + + (void)EVAL(code); + COD = ocod; +} + +LispObj * +Lisp_XtCoerceToWidgetList(LispBuiltin *builtin) +/* + xt-coerce-to-widget-list number opaque + */ +{ + int i; + WidgetList children; + Cardinal num_children; + LispObj *cons, *widget_list, *result; + + LispObj *onumber, *opaque; + + opaque = ARGUMENT(1); + onumber = ARGUMENT(0); + + CHECK_INDEX(onumber); + num_children = FIXNUM_VALUE(onumber); + + if (!CHECKO(opaque, xtWidgetList_t)) + LispDestroy("%s: cannot convert %s to WidgetList", + STRFUN(builtin), STROBJ(opaque)); + children = (WidgetList)(opaque->data.opaque.data); + + GCDisable(); + widget_list = cons = NIL; + for (i = 0; i < num_children; i++) { + result = CONS(OPAQUE(children[i], xtWidget_t), NIL); + if (widget_list == NIL) + widget_list = cons = result; + else { + RPLACD(cons, result); + cons = CDR(cons); + } + } + + result = APPLY(ATOM("MAKE-XT-WIDGET-LIST"), + CONS(KEYWORD("NUM-CHILDREN"), + CONS(INTEGER(num_children), + CONS(KEYWORD("CHILDREN"), + CONS(widget_list, NIL))))); + GCEnable(); + + return (result); +} + +LispObj * +Lisp_XtAddCallback(LispBuiltin *builtin) +/* + xt-add-callback widget callback-name callback &optional client-data + */ +{ + CallbackArgs *arguments; + LispObj *data; + + LispObj *widget, *callback_name, *callback, *client_data; + + client_data = ARGUMENT(3); + callback = ARGUMENT(2); + callback_name = ARGUMENT(1); + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + CHECK_STRING(callback_name); + if (!SYMBOLP(callback) && callback->type != LispLambda_t) + LispDestroy("%s: %s cannot be used as a callback", + STRFUN(builtin), STROBJ(callback)); + + if (client_data == UNSPEC) + client_data = NIL; + + data = CONS(widget, CONS(client_data, callback)); + PROTECT(widget, data); + + arguments = XtNew(CallbackArgs); + arguments->data = data; + + XtAddCallback((Widget)(widget->data.opaque.data), THESTR(callback_name), + LispXtCallback, (XtPointer)arguments); + XtAddCallback((Widget)(widget->data.opaque.data), XtNdestroyCallback, + LispXtCleanupCallback, (XtPointer)arguments); + + return (client_data); +} + +LispObj * +Lisp_XtAppAddInput(LispBuiltin *builtin) +/* + xt-app-add-input app-context fileno condition function &optional client-data + */ +{ + LispObj *data, *input; + XtAppContext appcon; + int source, condition; + CallbackArgs *arguments; + XtInputId id; + + LispObj *app_context, *fileno, *ocondition, *function, *client_data; + + client_data = ARGUMENT(4); + function = ARGUMENT(3); + ocondition = ARGUMENT(2); + fileno = ARGUMENT(1); + app_context = ARGUMENT(0); + + if (!CHECKO(app_context, xtAppContext_t)) + LispDestroy("%s: cannot convert %s to XtAppContext", + STRFUN(builtin), STROBJ(app_context)); + appcon = (XtAppContext)(app_context->data.opaque.data); + + CHECK_LONGINT(fileno); + source = LONGINT_VALUE(fileno); + + CHECK_FIXNUM(ocondition); + condition = FIXNUM_VALUE(ocondition); + + if (!SYMBOLP(function) && function->type != LispLambda_t) + LispDestroy("%s: %s cannot be used as a callback", + STRFUN(builtin), STROBJ(function)); + + /* client data optional */ + if (client_data == UNSPEC) + client_data = NIL; + + data = CONS(NIL, CONS(client_data, function)); + + arguments = XtNew(CallbackArgs); + arguments->data = data; + + id = XtAppAddInput(appcon, source, (XtPointer)condition, + LispXtInputCallback, (XtPointer)arguments); + GCDisable(); + input = OPAQUE(id, xtInputId_t); + GCEnable(); + RPLACA(data, input); + PROTECT(input, data); + + if (num_input_list + 1 >= size_input_list) { + ++size_input_list; + input_list = (CallbackArgs**) + XtRealloc((XtPointer)input_list, + sizeof(CallbackArgs*) * size_input_list); + } + input_list[num_input_list++] = arguments; + + return (input); +} + +LispObj * +Lisp_XtRemoveInput(LispBuiltin *builtin) +/* + xt-remove-input input + */ +{ + int i; + XtInputId id; + CallbackArgs *args; + + LispObj *input; + + input = ARGUMENT(0); + + if (!CHECKO(input, xtInputId_t)) + LispDestroy("%s: cannot convert %s to XtInputId", + STRFUN(builtin), STROBJ(input)); + + id = (XtInputId)(input->data.opaque.data); + for (i = 0; i < num_input_list; i++) { + args = input_list[i]; + if (id == (XtInputId)(CAR(args->data)->data.opaque.data)) { + UPROTECT(CAR(args->data), args->data); + XtFree((XtPointer)args); + + if (i + 1 < num_input_list) + memmove(input_list + i, input_list + i + 1, + sizeof(CallbackArgs*) * (num_input_list - i - 1)); + --num_input_list; + + XtRemoveInput(id); + + return (T); + } + } + + return (NIL); +} + +LispObj * +Lisp_XtAppInitialize(LispBuiltin *builtin) +/* + xt-app-initialize app-context-return application-class &optional options fallback-resources + */ +{ + XtAppContext appcon; + Widget shell; + int zero = 0; + Resources *resources = NULL; + String *fallback = NULL; + + LispObj *app_context_return, *application_class, + *options, *fallback_resources; + + fallback_resources = ARGUMENT(3); + options = ARGUMENT(2); + application_class = ARGUMENT(1); + app_context_return = ARGUMENT(0); + + CHECK_SYMBOL(app_context_return); + CHECK_STRING(application_class); + CHECK_LIST(options); + + /* check fallback resources, if given */ + if (fallback_resources != UNSPEC) { + LispObj *string; + int count; + + CHECK_CONS(fallback_resources); + for (string = fallback_resources, count = 0; CONS_P(string); + string = CDR(string), count++) + CHECK_STRING(CAR(string)); + + /* fallback resources was correctly specified */ + fallback = LispMalloc(sizeof(String) * (count + 1)); + for (string = fallback_resources, count = 0; CONS_P(string); + string = CDR(string), count++) + fallback[count] = THESTR(CAR(string)); + fallback[count] = NULL; + } + + shell = XtAppInitialize(&appcon, THESTR(application_class), NULL, + 0, &zero, NULL, fallback, NULL, 0); + if (fallback) + LispFree(fallback); + (void)LispSetVariable(app_context_return, + OPAQUE(appcon, xtAppContext_t), + STRFUN(builtin), 0); + + XtAppAddActions(appcon, actions, XtNumber(actions)); + + if (options != UNSPEC) { + resources = LispConvertResources(options, shell, + GetResourceList(XtClass(shell)), + NULL); + if (resources) { + XtSetValues(shell, resources->args, resources->num_args); + LispFreeResources(resources); + } + } + + return (OPAQUE(shell, xtWidget_t)); +} + +LispObj * +Lisp_XtAppMainLoop(LispBuiltin *builtin) +/* + xt-app-main-loop app-context + */ +{ + LispObj *app_context; + + app_context = ARGUMENT(0); + + if (!CHECKO(app_context, xtAppContext_t)) + LispDestroy("%s: cannot convert %s to XtAppContext", + STRFUN(builtin), STROBJ(app_context)); + + XtAppMainLoop((XtAppContext)(app_context->data.opaque.data)); + + return (NIL); +} + +LispObj * +Lisp_XtAppPending(LispBuiltin *builtin) +/* + xt-app-pending app-context + */ +{ + LispObj *app_context; + + app_context = ARGUMENT(0); + + if (!CHECKO(app_context, xtAppContext_t)) + LispDestroy("%s: cannot convert %s to XtAppContext", + STRFUN(builtin), STROBJ(app_context)); + + return (INTEGER( + XtAppPending((XtAppContext)(app_context->data.opaque.data)))); +} + +LispObj * +Lisp_XtAppProcessEvent(LispBuiltin *builtin) +/* + xt-app-process-event app-context &optional mask + */ +{ + XtInputMask mask; + XtAppContext appcon; + + LispObj *app_context, *omask; + + omask = ARGUMENT(1); + app_context = ARGUMENT(0); + + if (!CHECKO(app_context, xtAppContext_t)) + LispDestroy("%s: cannot convert %s to XtAppContext", + STRFUN(builtin), STROBJ(app_context)); + + appcon = (XtAppContext)(app_context->data.opaque.data); + if (omask == UNSPEC) + mask = XtIMAll; + else { + CHECK_FIXNUM(omask); + mask = FIXNUM_VALUE(omask); + } + + if (mask != (mask & XtIMAll)) + LispDestroy("%s: %d does not fit in XtInputMask %d", + STRFUN(builtin), mask); + + if (mask) + XtAppProcessEvent(appcon, mask); + + return (omask == NIL ? FIXNUM(mask) : omask); +} + +LispObj * +Lisp_XtRealizeWidget(LispBuiltin *builtin) +/* + xt-realize-widget widget + */ +{ + Widget widget; + + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + XtRealizeWidget(widget); + + if (XtIsSubclass(widget, shellWidgetClass)) { + if (!delete_window) + delete_window = XInternAtom(XtDisplay(widget), + "WM_DELETE_WINDOW", False); + (void)XSetWMProtocols(XtDisplay(widget), XtWindow(widget), + &delete_window, 1); + } + + return (owidget); +} + +LispObj * +Lisp_XtUnrealizeWidget(LispBuiltin *builtin) +/* + xt-unrealize-widget widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + XtUnrealizeWidget((Widget)(widget->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtIsRealized(LispBuiltin *builtin) +/* + xt-is-realized widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + return (XtIsRealized((Widget)(widget->data.opaque.data)) ? T : NIL); +} + +LispObj * +Lisp_XtDestroyWidget(LispBuiltin *builtin) +/* + xt-destroy-widget widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + XtDestroyWidget((Widget)(widget->data.opaque.data)); + + return (NIL); +} + +#define UNMANAGED 0 +#define MANAGED 1 +#define SHELL 2 +LispObj * +Lisp_XtCreateWidget(LispBuiltin *builtin) +/* + xt-create-widget name widget-class parent &optional arguments + */ +{ + return (LispXtCreateWidget(builtin, UNMANAGED)); +} + +LispObj * +Lisp_XtCreateManagedWidget(LispBuiltin *builtin) +/* + xt-create-managed-widget name widget-class parent &optional arguments + */ +{ + return (LispXtCreateWidget(builtin, MANAGED)); +} + +LispObj * +Lisp_XtCreatePopupShell(LispBuiltin *builtin) +/* + xt-create-popup-shell name widget-class parent &optional arguments + */ +{ + return (LispXtCreateWidget(builtin, SHELL)); +} + +LispObj * +LispXtCreateWidget(LispBuiltin *builtin, int options) +/* + xt-create-widget name widget-class parent &optional arguments + xt-create-managed-widget name widget-class parent &optional arguments + xt-create-popup-shell name widget-class parent &optional arguments + */ +{ + char *name; + WidgetClass widget_class; + Widget widget, parent; + Resources *resources = NULL; + + LispObj *oname, *owidget_class, *oparent, *arguments; + + arguments = ARGUMENT(3); + oparent = ARGUMENT(2); + owidget_class = ARGUMENT(1); + oname = ARGUMENT(0); + + CHECK_STRING(oname); + name = THESTR(oname); + + if (!CHECKO(owidget_class, xtWidgetClass_t)) + LispDestroy("%s: cannot convert %s to WidgetClass", + STRFUN(builtin), STROBJ(owidget_class)); + widget_class = (WidgetClass)(owidget_class->data.opaque.data); + + if (!CHECKO(oparent, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(oparent)); + parent = (Widget)(oparent->data.opaque.data); + + CHECK_LIST(arguments); + + if (options == SHELL) + widget = XtCreatePopupShell(name, widget_class, parent, NULL, 0); + else + widget = XtCreateWidget(name, widget_class, parent, NULL, 0); + + if (arguments == UNSPEC || arguments == NIL) + resources = NULL; + else { + resources = LispConvertResources(arguments, widget, + GetResourceList(widget_class), + GetResourceList(XtClass(parent))); + XtSetValues(widget, resources->args, resources->num_args); + } + if (options == MANAGED) + XtManageChild(widget); + if (resources) + LispFreeResources(resources); + + return (OPAQUE(widget, xtWidget_t)); +} + +LispObj * +Lisp_XtGetKeyboardFocusWidget(LispBuiltin *builtin) +/* + xt-get-keyboard-focus-widget widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + return (OPAQUE(XtGetKeyboardFocusWidget((Widget)(widget->data.opaque.data)), + xtWidget_t)); +} + +LispObj * +Lisp_XtGetValues(LispBuiltin *builtin) +/* + xt-get-values widget arguments + */ +{ + Arg args[1]; + Widget widget; + ResourceList *rlist, *plist; + ResourceInfo *resource; + LispObj *list, *object = NIL, *result, *cons = NIL; + char c1; + short c2; + int c4; +#ifdef LONG64 + long c8; +#endif + + LispObj *owidget, *arguments; + + arguments = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (arguments == NIL) + return (NIL); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + CHECK_CONS(arguments); + + rlist = GetResourceList(XtClass(widget)); + plist = XtParent(widget) ? + GetResourceList(XtClass(XtParent(widget))) : NULL; + + GCDisable(); + result = NIL; + for (list = arguments; CONS_P(list); list = CDR(list)) { + CHECK_STRING(CAR(list)); + if ((resource = GetResourceInfo(THESTR(CAR(list)), rlist, plist)) + == NULL) { + int i; + Widget child; + + for (i = 0; i < rlist->num_resources; i++) { + if (rlist->resources[i]->qtype == qWidget) { + XtSetArg(args[0], + XrmQuarkToString(rlist->resources[i]->qname), + &child); + XtGetValues(widget, args, 1); + if (child && XtParent(child) == widget) { + resource = + GetResourceInfo(THESTR(CAR(list)), + GetResourceList(XtClass(child)), + NULL); + if (resource) + break; + } + } + } + if (resource == NULL) { + LispMessage("%s: resource %s not available", + STRFUN(builtin), THESTR(CAR(list))); + continue; + } + } + switch (resource->size) { + case 1: + XtSetArg(args[0], THESTR(CAR(list)), &c1); + break; + case 2: + XtSetArg(args[0], THESTR(CAR(list)), &c2); + break; + case 4: + XtSetArg(args[0], THESTR(CAR(list)), &c4); + break; +#ifdef LONG64 + case 1: + XtSetArg(args[0], THESTR(CAR(list)), &c8); + break; +#endif + } + XtGetValues(widget, args, 1); + + /* special resources */ + if (resource->qtype == qString) { +#ifdef LONG64 + object = CONS(CAR(list), STRING(c8)); +#else + object = CONS(CAR(list), STRING(c4)); +#endif + } + else if (resource->qtype == qCardinal || resource->qtype == qInt) { +#ifdef LONG64 + if (sizeof(int) == 8) + object = CONS(CAR(list), INTEGER(c8)); + else +#endif + object = CONS(CAR(list), INTEGER(c4)); + } + else { + switch (resource->size) { + case 1: + object = CONS(CAR(list), OPAQUE(c1, 0)); + break; + case 2: + object = CONS(CAR(list), OPAQUE(c2, 0)); + break; + case 4: + object = CONS(CAR(list), OPAQUE(c4, 0)); + break; +#ifdef LONG64 + case 8: + object = CONS(CAR(list), OPAQUE(c8, 0)); + break; +#endif + } + } + + if (result == NIL) + result = cons = CONS(object, NIL); + else { + RPLACD(cons, CONS(object, NIL)); + cons = CDR(cons); + } + } + GCEnable(); + + return (result); +} + +LispObj * +Lisp_XtManageChild(LispBuiltin *builtin) +/* + xt-manage-child widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + XtManageChild((Widget)(widget->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtUnmanageChild(LispBuiltin *builtin) +/* + xt-unmanage-child widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + XtUnmanageChild((Widget)(widget->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtMapWidget(LispBuiltin *builtin) +/* + xt-map-widget widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + XtMapWidget((Widget)(widget->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtUnmapWidget(LispBuiltin *builtin) +/* + xt-unmap-widget widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + XtUnmapWidget((Widget)(widget->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtSetMappedWhenManaged(LispBuiltin *builtin) +/* + xt-set-mapped-when-managed widget map-when-managed + */ +{ + LispObj *widget, *map_when_managed; + + map_when_managed = ARGUMENT(1); + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + XtSetMappedWhenManaged((Widget)(widget->data.opaque.data), + map_when_managed != NIL); + + return (map_when_managed); +} + +LispObj * +Lisp_XtPopup(LispBuiltin *builtin) +/* + xt-popup widget grab-kind + */ +{ + XtGrabKind kind; + + LispObj *widget, *grab_kind; + + grab_kind = ARGUMENT(1); + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + CHECK_INDEX(grab_kind); + kind = (XtGrabKind)FIXNUM_VALUE(grab_kind); + if (kind != XtGrabExclusive && kind != XtGrabNone && + kind != XtGrabNonexclusive) + LispDestroy("%s: %d does not fit in XtGrabKind", + STRFUN(builtin), kind); + XtPopup((Widget)(widget->data.opaque.data), kind); + + return (grab_kind); +} + +LispObj * +Lisp_XtPopdown(LispBuiltin *builtin) +/* + xt-popdown widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + XtPopdown((Widget)(widget->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtSetKeyboardFocus(LispBuiltin *builtin) +/* + xt-set-keyboard-focus widget descendant + */ +{ + LispObj *widget, *descendant; + + descendant = ARGUMENT(1); + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + if (!CHECKO(descendant, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(descendant)); + XtSetKeyboardFocus((Widget)(widget->data.opaque.data), + (Widget)(descendant->data.opaque.data)); + + return (widget); +} + +LispObj * +Lisp_XtSetSensitive(LispBuiltin *builtin) +/* + xt-set-sensitive widget sensitive + */ +{ + LispObj *widget, *sensitive; + + sensitive = ARGUMENT(1); + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + XtSetSensitive((Widget)(widget->data.opaque.data), sensitive != NIL); + + return (sensitive); +} + +LispObj * +Lisp_XtSetValues(LispBuiltin *builtin) +/* + xt-set-values widget arguments + */ +{ + Widget widget; + Resources *resources; + + LispObj *owidget, *arguments; + + arguments = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (arguments == NIL) + return (owidget); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + CHECK_CONS(arguments); + resources = LispConvertResources(arguments, widget, + GetResourceList(XtClass(widget)), + XtParent(widget) ? + GetResourceList(XtClass(XtParent(widget))) : + NULL); + XtSetValues(widget, resources->args, resources->num_args); + LispFreeResources(resources); + + return (owidget); +} + +LispObj * +Lisp_XtWidgetToApplicationContext(LispBuiltin *builtin) +/* + xt-widget-to-application-context widget + */ +{ + Widget widget; + XtAppContext appcon; + + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + appcon = XtWidgetToApplicationContext(widget); + + return (OPAQUE(appcon, xtAppContext_t)); +} + +LispObj * +Lisp_XtDisplay(LispBuiltin *builtin) +/* + xt-display widget + */ +{ + Widget widget; + Display *display; + + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + display = XtDisplay(widget); + + return (OPAQUE(display, xtDisplay_t)); +} + +LispObj * +Lisp_XtDisplayOfObject(LispBuiltin *builtin) +/* + xt-display-of-object object + */ +{ + Widget widget; + Display *display; + + LispObj *object; + + object = ARGUMENT(0); + + if (!CHECKO(object, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(object)); + widget = (Widget)(object->data.opaque.data); + display = XtDisplayOfObject(widget); + + return (OPAQUE(display, xtDisplay_t)); +} + +LispObj * +Lisp_XtScreen(LispBuiltin *builtin) +/* + xt-screen widget + */ +{ + Widget widget; + Screen *screen; + + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + screen = XtScreen(widget); + + return (OPAQUE(screen, xtScreen_t)); +} + +LispObj * +Lisp_XtScreenOfObject(LispBuiltin *builtin) +/* + xt-screen-of-object object + */ +{ + Widget widget; + Screen *screen; + + LispObj *object; + + object = ARGUMENT(0); + + if (!CHECKO(object, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(object)); + widget = (Widget)(object->data.opaque.data); + screen = XtScreenOfObject(widget); + + return (OPAQUE(screen, xtScreen_t)); +} + +LispObj * +Lisp_XtWindow(LispBuiltin *builtin) +/* + xt-window widget + */ +{ + Widget widget; + Window window; + + LispObj *owidget; + + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + window = XtWindow(widget); + + return (OPAQUE(window, xtWindow_t)); +} + +LispObj * +Lisp_XtWindowOfObject(LispBuiltin *builtin) +/* + xt-window-of-object widget + */ +{ + Widget widget; + Window window; + + LispObj *object; + + object = ARGUMENT(0); + + if (!CHECKO(object, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(object)); + widget = (Widget)(object->data.opaque.data); + window = XtWindowOfObject(widget); + + return (OPAQUE(window, xtWindow_t)); +} + +LispObj * +Lisp_XtAddGrab(LispBuiltin *builtin) +/* + xt-add-grab widget exclusive spring-loaded + */ +{ + Widget widget; + Bool exclusive, spring_loaded; + + LispObj *owidget, *oexclusive, *ospring_loaded; + + ospring_loaded = ARGUMENT(2); + oexclusive = ARGUMENT(1); + owidget = ARGUMENT(0); + + if (!CHECKO(owidget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(owidget)); + widget = (Widget)(owidget->data.opaque.data); + exclusive = oexclusive != NIL; + spring_loaded = ospring_loaded != NIL; + + XtAddGrab(widget, exclusive, spring_loaded); + + return (T); +} + +LispObj * +Lisp_XtRemoveGrab(LispBuiltin *builtin) +/* + xt-remove-grab widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + XtRemoveGrab((Widget)(widget->data.opaque.data)); + + return (NIL); +} + +LispObj * +Lisp_XtName(LispBuiltin *builtin) +/* + xt-name widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + return (STRING(XtName((Widget)(widget->data.opaque.data)))); +} + +LispObj * +Lisp_XtParent(LispBuiltin *builtin) +/* + xt-parent widget + */ +{ + LispObj *widget; + + widget = ARGUMENT(0); + + if (!CHECKO(widget, xtWidget_t)) + LispDestroy("%s: cannot convert %s to Widget", + STRFUN(builtin), STROBJ(widget)); + + return (OPAQUE(XtParent((Widget)widget->data.opaque.data), xtWidget_t)); +} + +LispObj * +Lisp_XtAppGetExitFlag(LispBuiltin *builtin) +/* + xt-app-get-exit-flag app-context + */ +{ + LispObj *app_context; + + app_context = ARGUMENT(0); + + if (!CHECKO(app_context, xtAppContext_t)) + LispDestroy("%s: cannot convert %s to XtAppContext", + STRFUN(builtin), STROBJ(app_context)); + + return (XtAppGetExitFlag((XtAppContext)(app_context->data.opaque.data)) ? + T : NIL); +} + +LispObj * +Lisp_XtAppSetExitFlag(LispBuiltin *builtin) +/* + xt-app-get-exit-flag app-context + */ +{ + LispObj *app_context; + + app_context = ARGUMENT(0); + + if (!CHECKO(app_context, xtAppContext_t)) + LispDestroy("%s: cannot convert %s to XtAppContext", + STRFUN(builtin), STROBJ(app_context)); + + XtAppSetExitFlag((XtAppContext)(app_context->data.opaque.data)); + + return (T); +} + +static Resources * +LispConvertResources(LispObj *list, Widget widget, + ResourceList *rlist, ResourceList *plist) +{ + char c1; + short c2; + int c4; +#ifdef LONG64 + long c8; +#endif + XrmValue from, to; + LispObj *arg, *val; + ResourceInfo *resource; + char *fname = "XT-CONVERT-RESOURCES"; + Resources *resources = (Resources*)XtCalloc(1, sizeof(Resources)); + + for (; CONSP(list); list = CDR(list)) { + if (!CONSP(CAR(list))) { + XtFree((XtPointer)resources); + LispDestroy("%s: %s is not a cons", fname, STROBJ(CAR(list))); + } + arg = CAR(CAR(list)); + val = CDR(CAR(list)); + + if (!STRINGP(arg)) { + XtFree((XtPointer)resources); + LispDestroy("%s: %s is not a string", fname, STROBJ(arg)); + } + + if ((resource = GetResourceInfo(THESTR(arg), rlist, plist)) == NULL) { + int i; + Arg args[1]; + Widget child; + + for (i = 0; i < rlist->num_resources; i++) { + if (rlist->resources[i]->qtype == qWidget) { + XtSetArg(args[0], + XrmQuarkToString(rlist->resources[i]->qname), + &child); + XtGetValues(widget, args, 1); + if (child && XtParent(child) == widget) { + resource = + GetResourceInfo(THESTR(arg), + GetResourceList(XtClass(child)), + NULL); + if (resource) + break; + } + } + } + if (resource == NULL) { + LispMessage("%s: resource %s not available", + fname, THESTR(arg)); + continue; + } + } + + if (LONGINTP(val) || DFLOATP(val) || OPAQUEP(val)) { + resources->args = (Arg*) + XtRealloc((XtPointer)resources->args, + sizeof(Arg) * (resources->num_args + 1)); + if (!OPAQUEP(val)) { + float fvalue; + + if (DFLOATP(val)) + fvalue = DFLOAT_VALUE(val); + else + fvalue = LONGINT_VALUE(val); + if (resource->qtype == qFloat) { + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), fvalue); + } + else + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), + (int)fvalue); + } + else + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), val->data.opaque.data); + ++resources->num_args; + continue; + } + else if (val == NIL) { + /* XXX assume it is a pointer or a boolean */ +#ifdef DEBUG + LispWarning("%s: assuming %s is a pointer or boolean", + fname, XrmQuarkToString(resource->qname)); +#endif + resources->args = (Arg*) + XtRealloc((XtPointer)resources->args, + sizeof(Arg) * (resources->num_args + 1)); + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), NULL); + ++resources->num_args; + continue; + } + else if (val == T) { + /* XXX assume it is a boolean */ +#ifdef DEBUG + LispWarning("%s: assuming %s is a boolean", + fname, XrmQuarkToString(resource->qname)); +#endif + resources->args = (Arg*) + XtRealloc((XtPointer)resources->args, + sizeof(Arg) * (resources->num_args + 1)); + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), True); + ++resources->num_args; + continue; + } + else if (!STRINGP(val)) { + XtFree((XtPointer)resources); + LispDestroy("%s: resource value must be string, number or opaque, not %s", + fname, STROBJ(val)); + } + + from.size = val == NIL ? 1 : strlen(THESTR(val)) + 1; + from.addr = val == NIL ? "" : THESTR(val); + switch (to.size = resource->size) { + case 1: + to.addr = (XtPointer)&c1; + break; + case 2: + to.addr = (XtPointer)&c2; + break; + case 4: + to.addr = (XtPointer)&c4; + break; +#ifdef LONG64 + case 8: + to.addr = (XtPointer)&c8; + break; +#endif + default: + LispWarning("%s: bad resource size %d for %s", + fname, to.size, THESTR(arg)); + continue; + } + + if (qString == resource->qtype) +#ifdef LONG64 + c8 = (long)from.addr; +#else + c4 = (long)from.addr; +#endif + else if (!XtConvertAndStore(widget, XtRString, &from, + XrmQuarkToString(resource->qtype), &to)) + /* The type converter already have printed an error message */ + continue; + + resources->args = (Arg*) + XtRealloc((XtPointer)resources->args, + sizeof(Arg) * (resources->num_args + 1)); + switch (to.size) { + case 1: + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), c1); + break; + case 2: + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), c2); + break; + case 4: + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), c4); + break; +#ifdef LONG64 + case 8: + XtSetArg(resources->args[resources->num_args], + XrmQuarkToString(resource->qname), c8); + break; +#endif + } + ++resources->num_args; + } + + return (resources); +} + +static void +LispFreeResources(Resources *resources) +{ + if (resources) { + XtFree((XtPointer)resources->args); + XtFree((XtPointer)resources); + } +} + +static int +bcmp_action_resource(_Xconst void *string, _Xconst void *resource) +{ + return (strcmp((String)string, + XrmQuarkToString((*(ResourceInfo**)resource)->qname))); +} + +static ResourceInfo * +GetResourceInfo(char *name, ResourceList *rlist, ResourceList *plist) +{ + ResourceInfo **resource = NULL; + + if (rlist->resources) + resource = (ResourceInfo**) + bsearch(name, rlist->resources, rlist->num_resources, + sizeof(ResourceInfo*), bcmp_action_resource); + + if (resource == NULL && plist) { + resource = (ResourceInfo**) + bsearch(name, &plist->resources[plist->num_resources], + plist->num_cons_resources, sizeof(ResourceInfo*), + bcmp_action_resource); + } + + return (resource ? *resource : NULL); +} + +static ResourceList * +GetResourceList(WidgetClass wc) +{ + ResourceList *list; + + if ((list = FindResourceList(wc)) == NULL) + list = CreateResourceList(wc); + + return (list); +} + +static int +bcmp_action_resource_list(_Xconst void *wc, _Xconst void *list) +{ + return ((char*)wc - (char*)((*(ResourceList**)list)->widget_class)); +} + +static ResourceList * +FindResourceList(WidgetClass wc) +{ + ResourceList **list; + + if (!resource_list) + return (NULL); + + list = (ResourceList**) + bsearch(wc, resource_list, num_resource_list, + sizeof(ResourceList*), bcmp_action_resource_list); + + return (list ? *list : NULL); +} + +static int +qcmp_action_resource_list(_Xconst void *left, _Xconst void *right) +{ + return ((char*)((*(ResourceList**)left)->widget_class) - + (char*)((*(ResourceList**)right)->widget_class)); +} + +static ResourceList * +CreateResourceList(WidgetClass wc) +{ + ResourceList *list; + + list = (ResourceList*)XtMalloc(sizeof(ResourceList)); + list->widget_class = wc; + list->num_resources = list->num_cons_resources = 0; + list->resources = NULL; + + resource_list = (ResourceList**) + XtRealloc((XtPointer)resource_list, sizeof(ResourceList*) * + (num_resource_list + 1)); + resource_list[num_resource_list++] = list; + qsort(resource_list, num_resource_list, sizeof(ResourceList*), + qcmp_action_resource_list); + BindResourceList(list); + + return (list); +} + +static int +qcmp_action_resource(_Xconst void *left, _Xconst void *right) +{ + return (strcmp(XrmQuarkToString((*(ResourceInfo**)left)->qname), + XrmQuarkToString((*(ResourceInfo**)right)->qname))); +} + +static void +BindResourceList(ResourceList *list) +{ + XtResourceList xt_list, cons_list; + Cardinal i, num_xt, num_cons; + + XtGetResourceList(list->widget_class, &xt_list, &num_xt); + XtGetConstraintResourceList(list->widget_class, &cons_list, &num_cons); + list->num_resources = num_xt; + list->num_cons_resources = num_cons; + + list->resources = (ResourceInfo**) + XtMalloc(sizeof(ResourceInfo*) * (num_xt + num_cons)); + + for (i = 0; i < num_xt; i++) { + list->resources[i] = (ResourceInfo*)XtMalloc(sizeof(ResourceInfo)); + list->resources[i]->qname = + XrmPermStringToQuark(xt_list[i].resource_name); + list->resources[i]->qtype = + XrmPermStringToQuark(xt_list[i].resource_type); + list->resources[i]->size = xt_list[i].resource_size; + } + + for (; i < num_xt + num_cons; i++) { + list->resources[i] = (ResourceInfo*)XtMalloc(sizeof(ResourceInfo)); + list->resources[i]->qname = + XrmPermStringToQuark(cons_list[i - num_xt].resource_name); + list->resources[i]->qtype = + XrmPermStringToQuark(cons_list[i - num_xt].resource_type); + list->resources[i]->size = cons_list[i - num_xt].resource_size; + } + + XtFree((XtPointer)xt_list); + if (cons_list) + XtFree((XtPointer)cons_list); + + qsort(list->resources, list->num_resources, sizeof(ResourceInfo*), + qcmp_action_resource); + if (num_cons) + qsort(&list->resources[num_xt], list->num_cons_resources, + sizeof(ResourceInfo*), qcmp_action_resource); +} + +/*ARGSUSED*/ +static void +PopdownAction(Widget w, XEvent *event, String *params, Cardinal *num_params) +{ + XtPopdown(w); +} + +/*ARGSUSED*/ +static void +QuitAction(Widget w, XEvent *event, String *params, Cardinal *num_params) +{ + XtAppSetExitFlag(XtWidgetToApplicationContext(w)); +} -- cgit v1.2.3