Changeset 6772

Timestamp:

Jun 20, 2007, 11:32:47 AM (17 years ago)

Author:

Gary Byers

Message:

strip package when indenting; defindent for cond (wrong!), find first
IN-PACKAGE.

File:

• branches/ide-1.0/ccl/hemlock/src/lispmode.lisp (modified) (7 diffs)

branches/ide-1.0/ccl/hemlock/src/lispmode.lisp

@@ -858 +858 @@
 (defindent "ccase" 1)                      
 (defindent "compiler-let" 1)
+(defindent "cond" 0)
 (defindent "ctypecase" 1)
 (defindent "defconstant" 1)
@@ -965 +966 @@
 ;;; 
 (defindent "with-slots" 1)
-(defindent "with-slots*" 2) ; obsolete
 (defindent "with-accessors" 2)
-(defindent "with-accessors*" 2) ; obsolete
 (defindent "defclass" 2)
 (defindent "print-unreadable-object" 1)
+(defindent "defmethod" 2)
 
 ;;; System forms.
@@ -984 +984 @@
 
 ;;; LISP-INDENTATION -- Internal Interface.
+
+(defun strip-package-prefix (string)
+  (let* ((p (position #\: string :from-end t)))
+    (if p
+      (subseq string (1+ p))
+      string)))
 ;;;
 (defun lisp-indentation (mark)
@@ -1006 +1012 @@
       (with-mark ((fstart m))
         (scan-char m :lisp-syntax (not :constituent))
-        (let* ((fname (nstring-upcase (region-to-string (region fstart m))))
+        (let* ((fname (nstring-upcase
+                       (strip-package-prefix (region-to-string (region fstart m)))))
                (special-args (or (gethash fname *special-forms*)
                                  (and (> (length fname) 2)
@@ -1716 +1723 @@
 (defmode "Lisp" :major-p t :setup-function 'setup-lisp-mode)
 
+
+(defun buffer-first-in-package-form (buffer)
+  "Returns the package name referenced in the first apparent IN-PACKAGE
+   form in buffer, or NIL if it can't find an IN-PACKAGE."
+  (let* ((pattern (new-search-pattern :string-insensitive :forward "in-package" nil))
+         (mark (copy-mark (buffer-start-mark buffer))))
+    (with-mark ((start mark)
+                (end mark))
+      (loop
+        (unless (find-pattern mark pattern)
+          (return))
+        (pre-command-parse-check mark)
+        (when (valid-spot mark t)
+          (move-mark end mark)
+          (when (form-offset end 1)
+            (move-mark start end)
+            (when (backward-up-list start)
+              (when (scan-char start :lisp-syntax :constituent)
+                (let* ((s (nstring-upcase (region-to-string (region start end))))
+                       (*package* (find-package "CL-USER")))
+                  (unless (eq (ignore-errors (values (read-from-string s)))
+                              'in-package)
+                    (return)))
+                (unless (form-offset end 1) (return))
+                (move-mark start end)
+                (form-offset start -1)
+                (let* ((pkgname (ignore-errors (values (read-from-string (region-to-string (region start end)))))))
+                  (return
+                    (if pkgname
+                      (values (ignore-errors (string pkgname))))))))))))))
+
+(defun ensure-buffer-package (buffer)
+  (or (variable-value 'current-package :buffer buffer)
+      (setf (variable-value 'current-package :buffer buffer)
+            (buffer-first-in-package-form buffer))))
+
+
+
+    
 (defun setup-lisp-mode (buffer)
   (unless (hemlock-bound-p 'current-package :buffer buffer)
@@ -1721 +1767 @@
       "The package used for evaluation of Lisp in this buffer."
       :buffer buffer
-      :value "CL-USER"
+      :value nil
       :hooks (list 'package-name-change-hook))))
 
@@ -1801 +1847 @@
                 (return nil)))))))))
 
+(defcommand "Set Package Name" (p)
+  (variable-value 'current-package :buffer buffer)