[climacs-cvs] CVS climacs

[dmurray]

Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv11198

Modified Files:
	file-commands.lisp 
Log Message:
Made local-options parsing a bit more robust, removed dependence
on split-sequence, and added command Reparse Attribute List
(a la Zmacs). Changed terminology from 'local options' to
'attribute line/list'.


--- /project/climacs/cvsroot/climacs/file-commands.lisp	2006/05/06 06:27:14	1.11
+++ /project/climacs/cvsroot/climacs/file-commands.lisp	2006/05/06 11:41:57	1.12
@@ -129,20 +129,8 @@
 	     :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
+(defun evaluate-attributes (buffer options)
+  "Evaluate the attributes `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
@@ -152,8 +140,8 @@
   (let ((specified-syntax
          (syntax-from-name
           (second (find-if #'(lambda (name)
-                               (or (string= name "SYNTAX")
-                                   (string= name "MODE")))
+                               (or (string-equal name "SYNTAX")
+                                   (string-equal name "MODE")))
                            options
                            :key #'first)))))
     (when specified-syntax
@@ -163,32 +151,74 @@
   ;; 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"))
+     unless (or (string-equal name "SYNTAX")
+                (string-equal 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))))))
+(defun split-attribute (string char)
+  (let (pairs)
+    (loop with start = 0
+	  for ch across string
+	  for i from 0
+	  when (eql ch char)
+	    do (push (string-trim '(#\Space #\Tab) (subseq string start i))
+		     pairs)
+	       (setf start (1+ i))
+	  finally (unless (>= start i)
+		    (push (string-trim '(#\Space #\Tab) (subseq string start))
+			  pairs)))
+    (nreverse pairs)))
+
+(defun split-attribute-line (line)
+  (mapcar (lambda (pair) (split-attribute pair #\:))
+	  (split-attribute line #\;)))
+
+(defun get-attribute-line (buffer)
+  (let ((scan (beginning-of-buffer (clone-mark (point buffer)))))
+    ;; skip the leading whitespace
+    (loop until (end-of-buffer-p scan)
+	  until (not (whitespacep (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 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)))))))))))
+
+(defun evaluate-attributes-line (buffer)
+  (evaluate-attributes
+   buffer
+   (split-attribute-line (get-attribute-line buffer))))
+
+(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
+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 -*- "
+  (evaluate-attributes-line (buffer (current-window))))
 
 ;; Adapted from cl-fad/PCL
 (defun directory-pathname-p (pathspec)