;;
;; 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
;;
;;
;; $XdotOrg: app/xedit/lisp/modules/xedit.lsp,v 1.3 2004/12/04 00:43:14 kuhn Exp $
;; $XFree86: xc/programs/xedit/lisp/modules/xedit.lsp,v 1.9 2003/01/16 03:50:46 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*)
("\\.(diff|patch)"
"Patch file" "patch" . *patch-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*)))
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||#
)