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
