Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28674
Modified Files: syntax.lisp packages.lisp misc-commands.lisp lisp-syntax.lisp file-commands.lisp climacs.asd Log Message: Added support for local options lines (the -*- ... -*- stuff), the generic option Syntax/Mode and Base and Package options for Lisp syntax.
--- /project/climacs/cvsroot/climacs/syntax.lisp 2005/11/14 16:30:13 1.61 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/04/23 12:11:26 1.62 @@ -208,6 +208,38 @@ (:default-initargs :command-table ',command-table ,@default-initargs) ,@defclass-options))))
+(defgeneric eval-option (syntax name value) + (:documentation "Evaluate the option `name' with the specified + `value' for `syntax'.") + (:method (syntax name value) + ;; We do not want to error out if an invalid option is + ;; specified. Signal a condition? For now, silently ignore. + (declare (ignore syntax name value)))) + +(defmethod eval-option :around (syntax (name string) value) + ;; Convert the name to a keyword symbol... + (eval-option syntax (intern name (find-package :keyword)) + value)) + +(defmacro define-option-for-syntax + (syntax option-name (syntax-symbol value-symbol) &body body) + "Define an option for the syntax specified by the symbol + `syntax'. `Option-name' should be a string that will be the + name of the option. The name will automatically be converted to + uppercase. When the option is being evaluated, `body' will be + run, with `syntax-symbol' bound to the syntax object the option + is being evaluated for, and `value-symbol' bound to the value + of the option." + ;; The name is converted to a keyword symbol which is used for all + ;; further identification. + (let ((name-symbol (gensym)) + (symbol (intern (string-upcase option-name) + (find-package :keyword)))) + `(defmethod eval-option ((,syntax-symbol ,syntax) + (,name-symbol (eql ,symbol)) + ,value-symbol) + ,@body))) + #+nil (defmacro define-syntax (class-name (name superclasses) &body body) `(progn (push '(,name . ,class-name) *syntaxes*) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/03/26 14:14:48 1.87 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/04/23 12:11:26 1.88 @@ -94,6 +94,8 @@ (defpackage :climacs-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:define-syntax + #:eval-option + #:define-option-for-syntax #:syntax-from-name #:basic-syntax #:update-syntax #:update-syntax-for-display --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/03/26 14:14:48 1.5 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/04/23 12:11:26 1.6 @@ -28,6 +28,13 @@
(in-package :climacs-gui)
+(define-command (com-reload-local-options-line + :name t + :command-table buffer-table) + () + "Reload the local options line." + (evaluate-local-options-line (current-buffer))) + (define-command (com-overwrite-mode :name t :command-table editing-table) () (with-slots (overwrite-mode) (current-window) (setf overwrite-mode (not overwrite-mode)))) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/13 10:47:48 1.51 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 12:11:26 1.52 @@ -42,11 +42,31 @@ (current-start-mark) (current-size) (scan) - (package)) + (package) + (base :accessor base + :initform 10 + :documentation "The base which numbers in the buffer are + expected to be in.") + (option-specified-package :accessor option-specified-package + :initform nil + :documentation "The package + specified in the local options + line (may be overridden + by (in-package) forms).")) (:name "Lisp") (:pathname-types "lisp" "lsp" "cl") (:command-table lisp-table))
+(define-option-for-syntax lisp-syntax "Package" (syntax package-name) + (let ((specified-package (find-package package-name))) + (when specified-package + (setf (option-specified-package syntax) specified-package)))) + +(define-option-for-syntax lisp-syntax "Base" (syntax base) + (let ((integer-base (parse-integer base :junk-allowed t))) + (when integer-base + (setf (base syntax) integer-base)))) + (defmethod initialize-instance :after ((syntax lisp-syntax) &rest args) (declare (ignore args)) (with-slots (buffer scan) syntax --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/03/27 15:43:17 1.5 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 12:11:26 1.6 @@ -129,6 +129,67 @@ :key #'climacs-syntax::syntax-description-pathname-types)) 'basic-syntax))
+(defun parse-local-options-line (line) + "Parse the local options line `line' and return an alist + mapping options to values. All option names will be coerced to + uppercase. `Line' must be stripped of the leading and + terminating -*- tokens." + (loop for pair in (split-sequence:split-sequence #; line) + when (find #: pair) + collect (destructuring-bind (key value) + (loop for elem in (split-sequence:split-sequence #: pair) + collecting (string-trim " " elem)) + (list (string-upcase key) value)))) + +(defun evaluate-local-options (buffer options) + "Evaluate the local options `options' and modify `buffer' as + appropriate. `Options' should be an alist mapping option names + to their values." + ;; First, check whether we need to change the syntax (via the SYNTAX + ;; option). MODE is an alias for SYNTAX for compatibility with + ;; Emacs. If there is more than one option with one of these names, + ;; only the first will be acted upon. + (let ((specified-syntax + (syntax-from-name + (second (find-if #'(lambda (name) + (or (string= name "SYNTAX") + (string= name "MODE"))) + options + :key #'first))))) + (when specified-syntax + (setf (syntax buffer) + (make-instance specified-syntax + :buffer buffer)))) + ;; Now we iterate through the options (discarding SYNTAX and MODE + ;; options). + (loop for (name value) in options + unless (or (string= name "SYNTAX") + (string= name "MODE")) + do (eval-option (syntax buffer) name value))) + +(defun evaluate-local-options-line (buffer) + "Evaluate the local options line of `buffer'. If `buffer' does + not have a local options line, this function is a no-op." + ;; This could be simplified a bit by using regexps. + (let* ((beginning-mark (beginning-of-buffer + (clone-mark (point buffer)))) + (end-mark (end-of-line (clone-mark beginning-mark))) + (line (buffer-sequence buffer (offset beginning-mark) (offset end-mark))) + (first-occurence (search "-*-" line)) + (second-occurence + (when first-occurence + (search "-*-" line :start2 (1+ first-occurence))))) + (when (and first-occurence + second-occurence) + ;; Strip away the -*-s. + (let ((cleaned-options-line (coerce (subseq line + (+ first-occurence 3) + second-occurence) + 'string))) + (evaluate-local-options + buffer + (parse-local-options-line cleaned-options-line)))))) + ;; Adapted from cl-fad/PCL (defun directory-pathname-p (pathspec) "Returns NIL if PATHSPEC does not designate a directory." @@ -153,13 +214,19 @@ (pane (current-window))) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer (current-window)) buffer) - (setf (syntax buffer) - (make-instance (syntax-class-name-for-filepath filepath) - :buffer buffer)) ;; Don't want to create the file if it doesn't exist. (when (probe-file filepath) (with-open-file (stream filepath :direction :input) - (input-from-stream stream buffer 0))) + (input-from-stream stream buffer 0)) + ;; A file! That means we may have a local options + ;; line to parse. + (evaluate-local-options-line buffer)) + ;; If the local options line didn't set a syntax, do + ;; it now. + (when (null (syntax buffer)) + (setf (syntax buffer) + (make-instance (syntax-class-name-for-filepath filepath) + :buffer buffer))) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (needs-saving buffer) nil) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/03/25 21:15:21 1.43 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/04/23 12:11:26 1.44 @@ -28,7 +28,7 @@ (defparameter *climacs-directory* (directory-namestring *load-truename*))
(defsystem :climacs - :depends-on (:mcclim :flexichain :esa) + :depends-on (:mcclim :flexichain :esa :split-sequence) :components ((:module "cl-automaton" :components ((:file "automaton-package")