diff options
Diffstat (limited to 'lisp/modules/xedit.lsp')
| -rw-r--r-- | lisp/modules/xedit.lsp | 560 |
1 files changed, 560 insertions, 0 deletions
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/<the-string>.lsp") +;; pathname: executes (load <the-pathhame>) +;; 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*) + ("\\<XF86Config[^/]*" + "XF86Config" "xconf" . *xconf-mode*) + ("\\.spec$" + "RPM spec" "rpm" . *rpm-mode*) + ("\\<XFree86\\.\\d+\\.log$" + "XFree86 log" "xlog" . *xlog-mode*) +)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Compile the regexps in the *auto-modes* list. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(dolist (mode *auto-modes*) + (rplaca mode (re-comp (car mode) :nosub t)) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Find the progmode associated with the given filename. +;; Returns nil if nothing matches. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun auto-mode (filename &optional symbol &aux syntax) + (if (and symbol (symbolp symbol)) + (if (boundp symbol) + (return-from auto-mode (symbol-value symbol)) + (setq syntax (cddr (find symbol *auto-modes* :key #'cdddr))) + ) + ;; symbol optional argument is not a symbol + (do* + ( + (mode *auto-modes* (cdr mode)) + (regex (caar mode) (caar mode)) + ) + ((endp mode)) + + ;; only wants to know if the regex match. + (when (listp (re-exec regex filename :count 0)) + (setq syntax (cddar mode) symbol (cdr syntax)) + (return) + ) + ) + ) + + ;; if file was already loaded + (if (and symbol (boundp symbol)) + (return-from auto-mode (symbol-value symbol)) + ) + + (when (consp syntax) + ;; point to the syntax file specification + (setq syntax (car syntax)) + + ;; try to load the syntax definition file + (if (stringp syntax) + (load + (string-concat + (namestring *default-pathname-defaults*) + "progmodes/" + syntax + ".lsp" + ) + ) + (load syntax) + ) + + (and symbol (boundp symbol) (symbol-value symbol)) + ) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Data types. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The main syntax structure, normally, only one should exist per +;; syntax highlight module. +;; The structure is defined here so it is not required to load all +;; the extra data associated with syntax-highlight at initialization +;; time, and will never be loaded if no syntax-highlight mode is +;; defined to the files being edited. +(defstruct syntax + name ;; A unique string to identify the syntax mode. + ;; Should be the name of the language/file type. + options ;; A hash table of options specified for the + ;; language. + + ;; Field(s) defined at "compile time" + labels ;; Not exactly a list of labels, but all syntax + ;; tables for the module. + quark ;; A XrmQuark associated with the XawTextPropertyList + ;; used by this syntax mode. + token-count ;; Number of distinct syntoken structures in + ;; the syntax table. +) + +;; Xlfd description, used when combining properties. +;; Field names are self descriptive. +;; XXX Fields should be initialized as strings, but fields +;; that have an integer value should be allowed to +;; be initialized as such. +;; Combining properties in supported in Xaw, but not yet in the +;; syntax highlight code interface. Combining properties allow easier +;; implementation for markup languages, for example: +;; <b>bold<i>italic</i></b> +;; 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 + ;; <name>=<anything>, but do a nicer output as the format + ;; <name> 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*))) + |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||# +) |