Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv14328
Modified Files: syntax.lisp packages.lisp lisp-syntax.lisp lisp-syntax-commands.lisp file-commands.lisp core.lisp Log Message: Yet another big patch:
* Added Set Package and Set Syntax commands to Lisp syntax.
* Added Update Attribute List command (and associated functions).
* Fixed issue in Lisp syntax where deletion of `(in-package)' forms was not properly picked up.
--- /project/climacs/cvsroot/climacs/syntax.lisp 2006/07/07 23:23:10 1.67 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/08/01 16:06:37 1.68 @@ -201,6 +201,19 @@ ,value-symbol) ,@body)))
+(defgeneric current-attributes-for-syntax (syntax) + (:method-combination append) + (:method append (syntax) + (list (cons :syntax (name syntax))))) + +(defun make-attribute-line (syntax) + (apply #'concatenate 'string + (loop for (name . value) in (current-attributes-for-syntax syntax) + collect (string-downcase (symbol-name name) :start 1) + collect ": " + collect value + collect "; "))) + #+nil (defmacro define-syntax (class-name (name superclasses) &body body) `(progn (push '(,name . ,class-name) *syntaxes*) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/27 10:39:32 1.109 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/08/01 16:06:37 1.110 @@ -122,6 +122,8 @@ (:export #:syntax #:define-syntax #:eval-option #:define-option-for-syntax + #:current-attributes-for-syntax + #:make-attribute-line #:syntax-from-name #:basic-syntax #:update-syntax #:update-syntax-for-display @@ -399,7 +401,8 @@ #:kill-buffer
#:filepath-filename - #:evaluate-attributes-line + #:update-attribute-line + #:evaluate-attribute-line #:directory-pathname-p #:find-file #:directory-of-buffer --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/31 19:35:36 1.105 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/01 16:06:37 1.106 @@ -113,6 +113,16 @@ (setf (base syntax) integer-base) (esa:display-message "Invalid base specified: outside the interval 2 to 36.")))))
+(defmethod current-attributes-for-syntax append ((syntax lisp-syntax)) + (list (cons :package (or (if (packagep (option-specified-package syntax)) + (package-name (option-specified-package syntax)) + (option-specified-package syntax)) + (package-name (package-at-mark + syntax + (or (caar (last (package-list syntax))) + 0))))) + (cons :base (format nil "~A" (base syntax))))) + (defmethod initialize-instance :after ((syntax lisp-syntax) &rest args) (declare (ignore args)) (with-slots (buffer scan) syntax @@ -1366,8 +1376,14 @@ 'cl:in-package))))))) (with-slots (stack-top) syntax (or (not (slot-boundp syntax 'package-list)) - (loop for child in (children stack-top) + (loop + for child in (children stack-top) when (test child) + do (return t)) + (loop + for (offset . nil) in (package-list syntax) + unless (let ((form (form-around syntax offset))) + (and form (typep form 'complete-list-form))) do (return t)))))))
(defun update-package-list (buffer syntax) @@ -1409,9 +1425,9 @@ (new-state syntax (parser-state stack-top) stack-top))) - (loop do (parse-patch syntax)))))) - (when (need-to-update-package-list-p buffer syntax) - (update-package-list buffer syntax))) + (loop do (parse-patch syntax))))) + (when (need-to-update-package-list-p buffer syntax) + (update-package-list buffer syntax))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/27 19:55:27 1.13 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/08/01 16:06:37 1.14 @@ -85,6 +85,18 @@ syntax t)))))
+(define-command (com-set-base :name t :command-table lisp-table) + ((base '(integer 2 36))) + "Set the base for the current buffer." + (setf (base (syntax (current-buffer))) + base)) + +(define-command (com-set-package :name t :command-table lisp-table) + ((package 'package)) + "Set the package for the current buffer." + (setf (option-specified-package (syntax (current-buffer))) + package)) + (define-command (com-indent-expression :name t :command-table lisp-table) ((count 'integer :prompt "Number of expressions")) (let* ((pane (current-window)) --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/07/25 11:38:05 1.22 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/08/01 16:06:37 1.23 @@ -113,7 +113,8 @@ (values default default-type)) (t (values string 'string)))))
-(define-command (com-reparse-attribute-list :name t :command-table buffer-table) () +(define-command (com-reparse-attribute-list :name t :command-table buffer-table) + () "Reparse the current buffer's attribute list. An attribute list is a line of keyword-value pairs, each keyword separated from the corresponding value by a colon. If another keyword-value pair @@ -125,7 +126,30 @@ An example attribute-list is:
;; -*- Syntax: Lisp; Base: 10 -*- " - (evaluate-attributes-line (buffer (current-window)))) + (evaluate-attribute-line (buffer (current-window)))) + +(define-command (com-update-attribute-list :name t :command-table buffer-table) + () + "Update the current buffers attribute list to reflect the +settings of the syntax of the buffer. + +After the attribute list has been updated, it will also be +re-evaluated. An attribute list is a line of keyword-value pairs, +each keyword separated from the corresponding value by a +colon. If another keyword-value pair follows, the value should be +terminated by a colon. The attribute list is surrounded by '-*-' +sequences, but the opening '-*-' need not be at the beginning of +the line. Climacs looks for the attribute list on the first or +second non-blank line of the file. + +An example attribute-list is: + +;; -*- Syntax: Lisp; Base: 10 -*- + +This command automatically comments the attribute line as +appropriate for the syntax of the buffer." + (update-attribute-line (buffer (current-window))) + (evaluate-attribute-line (buffer (current-window))))
(define-command (com-find-file :name t :command-table buffer-table) ((filepath 'pathname --- /project/climacs/cvsroot/climacs/core.lisp 2006/07/25 11:38:05 1.2 +++ /project/climacs/cvsroot/climacs/core.lisp 2006/08/01 16:06:37 1.3 @@ -474,7 +474,9 @@ (string-equal name "MODE"))) options :key #'first))))) - (when specified-syntax + (when (and specified-syntax + (not (eq (class-of (syntax buffer)) + specified-syntax))) (setf (syntax buffer) (make-instance specified-syntax :buffer buffer)))) @@ -503,35 +505,79 @@ (mapcar (lambda (pair) (split-attribute pair #:)) (split-attribute line #;)))
-(defun get-attribute-line (buffer) +(defun find-attribute-line-position (buffer) (let ((scan (beginning-of-buffer (clone-mark (point buffer))))) ;; skip the leading whitespace (loop until (end-of-buffer-p scan) - until (not (whitespacep (syntax buffer) (object-after scan))) - do (forward-object scan)) + until (not (whitespacep (syntax buffer) (object-after scan))) + do (forward-object scan)) ;; stop looking if we're already 1,000 objects into the buffer (unless (> (offset scan) 1000) (let ((start-found (loop with newlines = 0 - when (end-of-buffer-p scan) - do (return nil) - when (eql (object-after scan) #\Newline) - do (incf newlines) - when (> newlines 1) - do (return nil) - do (forward-object scan) - until (looking-at scan "-*-") - finally (return t)))) + when (end-of-buffer-p scan) + do (return nil) + when (eql (object-after scan) #\Newline) + do (incf newlines) + when (> newlines 1) + do (return nil) + until (looking-at scan "-*-") + do (forward-object scan) + finally (return t)))) (when start-found - (let ((line (buffer-substring buffer - (offset scan) - (offset (end-of-line (clone-mark scan)))))) - (when (>= (length line) 6) - (let ((end (search "-*-" line :from-end t :start2 3))) - (when end - (string-trim '(#\Space #\Tab) (subseq line 3 end))))))))))) + (let* ((end-scan (clone-mark scan)) + (end-found + (loop when (end-of-buffer-p end-scan) + do (return nil) + when (eql (object-after end-scan) #\Newline) + do (return nil) + do (forward-object end-scan) + until (looking-at end-scan "-*-") + finally (return t)))) + (when end-found + (values scan + (progn (forward-object end-scan 3) + end-scan))))))))) + +(defun get-attribute-line (buffer) + (multiple-value-bind (start-mark end-mark) (find-attribute-line-position buffer) + (let ((line (buffer-substring buffer + (offset start-mark) + (offset end-mark)))) + (when (>= (length line) 6) + (let ((end (search "-*-" line :from-end t :start2 3))) + (when end + (string-trim '(#\Space #\Tab) (subseq line 3 end)))))))) + +(defun replace-attribute-line (buffer new-attribute-line) + (let ((full-attribute-line (concatenate 'string + "-*- " + new-attribute-line + "-*-"))) + (multiple-value-bind (start-mark end-mark) (find-attribute-line-position buffer) + (cond ((not (null end-mark)) + ;; We have an existing attribute line. + (delete-region start-mark end-mark) + (let ((new-line-start (clone-mark start-mark :left))) + (insert-sequence start-mark full-attribute-line) + (comment-region (syntax buffer) + new-line-start + start-mark))) + (t + ;; Create a new attribute line at beginning of buffer. + (let* ((mark1 (beginning-of-buffer (clone-mark (point buffer) :left))) + (mark2 (clone-mark mark1 :right))) + (insert-sequence mark2 full-attribute-line) + (insert-object mark2 #\Newline) + (comment-region (syntax buffer) + mark1 + mark2))))))) + +(defun update-attribute-line (buffer) + (replace-attribute-line buffer + (make-attribute-line (syntax buffer))))
-(defun evaluate-attributes-line (buffer) +(defun evaluate-attribute-line (buffer) (evaluate-attributes buffer (split-attribute-line (get-attribute-line buffer)))) @@ -579,6 +625,9 @@ (setf (syntax buffer) nil) (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) @@ -586,13 +635,7 @@ (setf (file-write-time buffer) (file-write-date filepath)) ;; A file! That means we may have a local options ;; line to parse. - (evaluate-attributes-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))) + (evaluate-attribute-line buffer)) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (needs-saving buffer) nil