Changeset 6790 for branches

Timestamp:

Jul 6, 2007, 12:03:02 PM (17 years ago)

Author:

Gary Byers

Message:

Random typeout to named windows. (It's a start.)

Location:

branches/ide-1.0/ccl/hemlock/src

Files:

• doccoms.lisp (modified) (10 diffs)
• echo.lisp (modified) (1 diff)
• echocoms.lisp (modified) (2 diffs)
• filecoms.lisp (modified) (1 diff)
• lispmode.lisp (modified) (3 diffs)
• listener.lisp (modified) (5 diffs)
• macros.lisp (modified) (2 diffs)
• modeline.lisp (modified) (1 diff)
• morecoms.lisp (modified) (2 diffs)
• rompsite.lisp (modified) (1 diff)
• searchcoms.lisp (modified) (1 diff)

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

@@ -63 +63 @@
                                            :help "Name of command to look for.")
     (let ((bindings (command-bindings cmd)))
-      (with-pop-up-display (s)
+      (with-pop-up-display (s :title (format nil "Bindings of ~s" nam))
         (cond
          ((null bindings)
@@ -91 +91 @@
          (attr (find-containing str *character-attribute-names*)))
     (if (or coms vars attr)
-        (apropos-command-output str coms vars attr)
-        (with-pop-up-display (s :height 1)
-          (format s "No command, attribute or variable name contains ~S."
-                  str)))))
+      (apropos-command-output str coms vars attr)
+      (message "No command, attribute or variable name contains ~S." str))))
 
 (defun apropos-command-output (str coms vars attr)
   (declare (list coms vars attr))
-  (with-pop-up-display (s)
+  (with-pop-up-display (s :title "Apropos Output")
     (when coms
       (format s "Commands with ~S in their names:~%" str)
@@ -156 +154 @@
                         :help "Name of a command to document.")
     (let ((bindings (command-bindings com)))
-      (with-pop-up-display (s)
+      (with-pop-up-display (s :title (format nil "~s command documentation" nam))
         (format s "Documentation for ~S:~%   ~A~%"
                 nam (command-documentation com))
@@ -191 +189 @@
                 (write-char #\space *echo-area-stream*)
                 (cond ((commandp res)
-                       (with-pop-up-display (s)
+                       (with-pop-up-display (s :title "Key documentation")
                          (hemlock-ext:print-pretty-key (copy-seq hi::*prompt-key*) s)
                          (format s " is bound to ~S.~%" (command-name res))
@@ -203 +201 @@
                        (return)))))))
       (setf (current-window) old-window))))
-
-(defcommand "Describe Pointer" (p)
-  "Describe commands with any key binding that contains a \"mouse\" character
-   (modified or not).  Does not describe the command \"Illegal\"."
-  "Describe commands with any key binding that contains a \"mouse\" character
-   (modified or not).  Does not describe the command \"Illegal\"."
-  (declare (ignore p))
-  (let ((illegal-command (getstring "Illegal" *command-names*)))
-    (with-pop-up-display (s)
-      (dolist (cmd (get-mouse-commands))
-        (unless (eq cmd illegal-command)
-          (format s "Documentation for ~S:~%   ~A~%"
-                  (command-name cmd)
-                  (command-documentation cmd))
-          (write-line
-           "This can be invoked in the following ways:" s)
-          (write-string "   " s)
-          (print-command-bindings (command-bindings cmd) s)
-          (terpri s) (terpri s))))))
-
-(defun get-mouse-commands ()
-  (let ((result nil))
-    (do-strings (name cmd *command-names* result)
-      (declare (ignore name))
-      (dolist (b (command-bindings cmd))
-        (let ((key (car b)))
-          (declare (simple-vector key))
-          (when (dotimes (i (length key) nil)
-                  (when (member (hemlock-ext:make-key-event (svref key i))
-                                (list #k"Leftdown" #k"Leftup" #k"Middledown"
-                                      #k"Middleup" #k"Rightdown" #k"Rightup"))
-                    (push cmd result)
-                    (return t)))
-            (return)))))))
 
 
@@ -283 +247 @@
     (function (funcall doc :full))
     (simple-string
-     (with-pop-up-display (s)
+     (with-pop-up-display (s :title (format nil "~s documentation" nam))
        (format s "Documentation for ~S:~%  ~A" nam doc)))
     (t (error "Bad documentation: ~S" doc))))
@@ -300 +264 @@
                         :help "Name of variable to describe."
                         :prompt "Variable: ")
-    (with-pop-up-display (s)
+    (with-pop-up-display (s :title (format nil "~S Variable documentation"))
       (show-variable s name var))))
 
@@ -312 +276 @@
                         :help "Name of variable to describe."
                         :prompt "Variable: ")
-    (with-pop-up-display (s)
+    (with-pop-up-display (s :title (format nil "~s" name))
       (format s "Documentation for ~S:~%  ~A~&~%"
               name (variable-documentation var))
@@ -350 +314 @@
                                       :default
                                       (car (buffer-modes (current-buffer)))))))
-    (with-pop-up-display (s)
+    (with-pop-up-display (s :title (format nil "~A mode" name))
       (format s "~A mode description:~%" name)
       (let ((doc (mode-documentation name)))
@@ -383 +347 @@
   "Display the last 60 characters typed."
   (declare (ignore p))
-  (with-pop-up-display (s :height 7)
+  (with-pop-up-display (s :title (format nil "The last ~d characters typed") :height 7)
     (let ((num (ring-length *key-event-history*)))
       (format s "The last ~D characters typed:~%" num)

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

@@ -754 +754 @@
   (let ((help (if (listp help)
                   (apply #'format nil help) help)))
-    (with-pop-up-display (s)
+    (with-pop-up-display (s :title "Help")
       (write-string help s)
       (fresh-line s)

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

@@ -71 +71 @@
      ((eq *parse-type* :keyword)
       (let ((strings (find-all-completions input *parse-string-tables*)))
-        (with-pop-up-display (s :height (+ (length strings) 2))
+        (with-pop-up-display (s :title "input help" :height (+ (length strings) 2))
           (write-line help s)
           (cond (strings
@@ -84 +84 @@
                                   *parse-default*)))
         (declare (list pns))
-        (with-pop-up-display(s :height (+ (length pns) 2))
+        (with-pop-up-display(s :title "Completion help" :height (+ (length pns) 2))
           (write-line help s)
           (cond (pns

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

@@ -46 +46 @@
    \"Mode\" mode option is specified, then this tries to invoke the appropriate
    file type hook."
-  (#_NSLog #@"processing file options")
   (let* ((string
           (line-string (mark-line (buffer-start-mark buffer))))

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

@@ -1754 +1754 @@
                       (values (ignore-errors (string pkgname))))))))))))))
 
+(defparameter *previous-in-package-search-pattern*
+    (new-search-pattern :string-insensitive :backward "in-package" nil))
+
+(defun package-at-mark (start-mark)
+  (let* ((pattern *previous-in-package-search-pattern*)
+         (mark (copy-mark start-mark :temporary)))
+    (with-mark ((start mark)
+                (end mark)
+                (list-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)
+              (move-mark list-end start)
+              (unless (and (list-offset list-end 1)
+                           (mark<= list-end start-mark))
+                (return))
+              (when (scan-char start :lisp-syntax :constituent)
+                (unless (or (mark= mark start)
+                            (let* ((s (nstring-upcase (region-to-string (region start end))))
+                                   (*package* (find-package "CL-USER")))
+                              (eq (ignore-errors (values (read-from-string s)))
+                                  'in-package)))
+                  (return))
+                (unless (form-offset end 1) (format t "~& worse") (return 4))
+                (move-mark start end)
+                (form-offset start -1)
+                (return
+                  (if (eql (next-character start) #\")
+                    (progn
+                      (character-offset start 1)
+                      (character-offset end -1)
+                      (region-to-string (region start end)))
+                    (let* ((pkgname (ignore-errors (values (read-from-string (region-to-string (region start end)))))))
+                      (if pkgname
+                        (values (ignore-errors (string pkgname)))))))))))))))
+
 (defun ensure-buffer-package (buffer)
   (or (variable-value 'current-package :buffer buffer)
@@ -1767 +1809 @@
       "The package used for evaluation of Lisp in this buffer."
       :buffer buffer
-      :value nil
+      :value "CL-USER"
       :hooks (list 'package-name-change-hook))))
 
@@ -1847 +1889 @@
                 (return nil)))))))))
 
+#||
 (defcommand "Set Package Name" (p)
   (variable-value 'current-package :buffer buffer)
-                
+||#                

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

@@ -659 +659 @@
   `(cond ((not (symbolp ,var))
           (,error-name "~S is not a symbol." ,var))
+         ((special-operator-p ,var) ,var)
          ((macro-function ,var))
-         ((fboundp ,var)
-          (if (listp (symbol-function ,var))
-              ,var
-              (symbol-function ,var)))
+         ((fboundp ,var))
          (t
           (,error-name "~S is not a function." ,var))))
@@ -680 +678 @@
        (let* ((sym (read s))
               (fun (function-to-describe sym editor-error)))
-         (with-pop-up-display (*standard-output*)
+         (with-pop-up-display (*standard-output* :title (format nil "~s" sym))
            (editor-describe-function fun sym)))))))
 
@@ -694 +692 @@
       (let ((thing (read s)))
         (if (symbolp thing)
-          (with-pop-up-display (*standard-output*)
+          (with-pop-up-display (*standard-output* :title (format nil "~s" thing))
             (describe thing))
           (if (and (consp thing)
@@ -700 +698 @@
                        (eq (car thing) 'function))
                    (symbolp (cadr thing)))
-            (with-pop-up-display (*standard-output*)
+            (with-pop-up-display (*standard-output* :title (format nil "~s" (cadr thing)))
               (describe (cadr thing)))
             (editor-error "~S is not a symbol, or 'symbol, or #'symbol."
@@ -740 +738 @@
                 :help "Expression to evaluate to get object to describe."))
           (obj (eval exp)))
-     (with-pop-up-display (*standard-output*)
+     (with-pop-up-display (*standard-output* :title (format nil "~s" exp))
        (describe obj)))))
 

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

@@ -549 +549 @@
 
 
-(defmacro with-pop-up-display ((var &key height (buffer-name "Random Typeout"))
+(defmacro with-pop-up-display ((var &key height title)
                                &body body)
-  (declare (ignore buffer-name))
-
 
   "Execute body in a context with var bound to a stream.  Output to the stream
@@ -562 +560 @@
   (let ((stream (gensym)))
     `(let ()
-       (let ((,stream (ccl::typeout-stream)))
+       (let ((,stream (ccl::typeout-stream ,title)))
          (clear-output ,stream)
        (unwind-protect

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

@@ -129 +129 @@
                                               :buffer buffer)))
                      (if val
+                       (if (find-package val)
                          (format nil "~A:  " val)
-                         " "))
+                         (format nil "?~A?:  " val))
+                       " "))
                    " ")))
 

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

@@ -255 +255 @@
 
 
-(defcommand "List Buffers" (p)
-  "Show a list of all buffers.
-   If the buffer is modified then a * is displayed before the name.  If there
-   is an associated file then it's name is displayed last.  With prefix
-   argument, only list modified buffers."
-  "Display the names of all buffers in a with-random-typeout window."
-  (with-pop-up-display (s)
-    (do-strings (n b *buffer-names*)
-      (declare (simple-string n))
-      (unless (or (eq b *echo-area-buffer*)
-                  (assoc b *random-typeout-buffers* :test #'eq))
-        (let ((modified (buffer-modified b))
-              (buffer-pathname (buffer-pathname b)))
-          (when (or (not p) modified)
-            (write-char (if modified #\* #\space) s)
-            (if buffer-pathname
-                (format s "~A  ~25T~A~:[~68T~A~;~]~%"
-                        (file-namestring buffer-pathname)
-                        (directory-namestring buffer-pathname)
-                        (string= (pathname-to-buffer-name buffer-pathname) n)
-                        n)
-                (format s "~A~68T~D Line~:P~%"
-                        n (count-lines (buffer-region b))))))))))
-
-(defcommand "Select Random Typeout Buffer" (p)
-  "Select last random typeout buffer."
-  "Select last random typeout buffer."
-  (declare (ignore p))
-  (if *random-typeout-buffers*
-      (change-to-buffer (caar *random-typeout-buffers*))
-      (editor-error "There are no random typeout buffers.")))
-
-
-(defcommand "Room" (p)
-  "Display stats on allocated storage."
-  "Run Room into a With-Random-Typeout window."
-  (declare (ignore p))
-  (with-pop-up-display (*standard-output*)
-    (room)))
+
 
 
@@ -662 +624 @@
 
                            
-(defcommand "View Page Directory" (p)
-  "Print a listing of the first non-blank line after each page mark
-   in a pop-up window."
-  "Print a listing of the first non-blank line after each page mark
-   in a pop-up window."
-  (declare (ignore p))
-  (let ((dir (page-directory (current-buffer))))
-    (declare (list dir))
-    (with-pop-up-display (s :height (1+ (the fixnum (length dir))))
-      (display-page-directory s dir))))
-
-(defcommand "Insert Page Directory" (p)
-  "Insert a listing of the first non-blank line after each page mark at
-   the beginning of the buffer.  A mark is dropped before going to the
-   beginning of the buffer.  If an argument is supplied, insert the page
-   directory at point."
-  "Insert a listing of the first non-blank line after each page mark at
-   the beginning of the buffer."
-  (let ((point (current-point)))
-    (unless p
-      (push-buffer-mark (copy-mark point))
-      (buffer-start point))
-    (push-buffer-mark (copy-mark point))
-    (display-page-directory (make-hemlock-output-stream point :full)
-                            (page-directory (current-buffer))))
-  (setf (last-command-type) :ephemerally-active))
-
-(defun display-page-directory (stream directory)
-  "This writes the list of strings, directory, to stream, enumerating them
-   in a field of three characters.  The number and string are separated by
-   two spaces, and the first line contains headings for the numbers and
-   strings columns."
-  (write-line "Page    First Non-blank Line" stream)
-  (do ((dir directory (cdr dir))
-       (count 1 (1+ count)))
-      ((null dir))
-    (declare (fixnum count))
-    (format stream "~3D  " count)
-    (write-line (car dir) stream)))
-
-(defun page-directory (buffer)
-  "Return a list of strings where each is the first non-blank line
-   following a :page-delimiter in buffer."
-  (with-mark ((m (buffer-point buffer)))
-    (buffer-start m)
-    (let ((end-of-buffer (buffer-end-mark buffer)) result)
-      (loop ;over pages.
-        (loop ;for first non-blank line.
-          (cond ((not (blank-after-p m))
-                 (let* ((str (line-string (mark-line m)))
-                        (len (length str)))
-                   (declare (simple-string str))
-                   (push (if (and (> len 1)
-                                  (= (character-attribute :page-delimiter
-                                                          (schar str 0))
-                                     1))
-                             (subseq str 1)
-                             str)
-                         result))
-                 (unless (page-offset m 1)
-                   (return-from page-directory (nreverse result)))
-                 (when (mark= m end-of-buffer)
-                   (return-from page-directory (nreverse result)))
-                 (return))
-                ((not (line-offset m 1 0))
-                 (return-from page-directory (nreverse result)))
-                ((= (character-attribute :page-delimiter (next-character m))
-                    1)
-                 (push "" result)
-                 (mark-after m)
-                 (return))))))))
-
-
-(defcommand "Previous Page" (p)
-  "Move to the beginning of the current page.
-  With prefix argument move that many pages."
-  "Move backward P pages."
-  (let ((point (current-point)))
-    (unless (page-offset point (- (or p 1)))
-      (editor-error "No such page."))
-    (line-start (move-mark (window-display-start (current-window)) point))))
-
-(defcommand "Next Page" (p)
-  "Move to the beginning of the next page.
-  With prefix argument move that many pages."
-  "Move forward P pages."
-  (let ((point (current-point)))
-    (unless (page-offset point (or p 1))
-      (editor-error "No such page."))
-    (line-start (move-mark (window-display-start (current-window)) point))))
-
-(defcommand "Mark Page" (p)
-  "Put point at beginning, mark at end of current page.
-   With prefix argument, mark the page that many pages after the current one."
-  "Mark the P'th page after the current one."
-  (let ((point (current-point)))
-    (if p
-        (unless (page-offset point (1+ p)) (editor-error "No such page."))
-        (page-offset point 1)) ;If this loses, we're at buffer-end.
-    (with-mark ((m point))
-      (unless (page-offset point -1)
-        (editor-error "No such page."))
-      (push-buffer-mark (copy-mark m) t)
-      (line-start (move-mark (window-display-start (current-window)) point)))))
-
-(defun page-offset (mark n)
-  "Move mark past n :page-delimiters that are in the zero'th line position.
-   If a :page-delimiter is the immediately next character after mark in the
-   appropriate direction, then skip it before starting."
-  (cond ((plusp n)
-         (find-attribute mark :page-delimiter #'zerop)
-         (dotimes (i n mark)
-           (unless (next-character mark) (return nil))
-           (loop
-             (unless (find-attribute mark :page-delimiter)
-               (return-from page-offset nil))
-             (unless (mark-after mark)
-               (return (if (= i (1- n)) mark)))
-             (when (= (mark-charpos mark) 1) (return)))))
-        (t
-         (reverse-find-attribute mark :page-delimiter #'zerop)
-         (prog1
-          (dotimes (i (- n) mark)
-            (unless (previous-character mark) (return nil))
-            (loop
-              (unless (reverse-find-attribute mark :page-delimiter)
-                (return-from page-offset nil))
-              (mark-before mark)
-              (when (= (mark-charpos mark) 0) (return))))
-          (let ((buffer (line-buffer (mark-line mark))))
-            (unless (or (not buffer) (mark= mark (buffer-start-mark buffer)))
-              (mark-after mark)))))))
-
-
-
-
-;;;; Counting some stuff
-
-(defcommand "Count Lines Page" (p)
-  "Display number of lines in current page and position within page.
-   With prefix argument do on entire buffer."
-  "Count some lines, Man."
-  (let ((point (current-point)))
-    (if p
-        (let ((r (buffer-region (current-buffer))))
-          (count-lines-function "Buffer" (region-start r) point (region-end r)))
-        (with-mark ((m1 point)
-                    (m2 point))
-          (unless (and (= (character-attribute :page-delimiter
-                                               (previous-character m1))
-                          1)
-                       (= (mark-charpos m1) 1))
-            (page-offset m1 -1))
-          (unless (and (= (character-attribute :page-delimiter
-                                               (next-character m2))
-                          1)
-                       (= (mark-charpos m2) 0))
-            (page-offset m2 1))
-          (count-lines-function "Page" m1 point m2)))))
-
-(defun count-lines-function (msg start mark end)
-  (let ((before (1- (count-lines (region start mark))))
-        (after (count-lines (region mark end))))
-    (message "~A: ~D lines, ~D/~D" msg (+ before after) before after)))
+
 
 (defcommand "Count Lines" (p)

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

@@ -753 +753 @@
   (declare (ignorable sym))
   (describe fun)
-  #+GBNIL
-  (when (and (compiled-function-p fun)
-             (not (eq (kernel:%function-name (kernel:%closure-function fun))
-                      sym)))
-    (let ((doc (documentation sym 'function)))
-      (when doc
-        (format t "~&Function documentation for ~S:" sym)
-        (setf (lisp::indenting-stream-stream *editor-describe-stream*)
-              *standard-output*)
-        (ext:indenting-further *editor-describe-stream* 2
-          (fresh-line *editor-describe-stream*)
-          (write-string doc *editor-describe-stream*))))))
+  (let ((doc (documentation sym 'function)))
+    (when doc
+      (format *standard-output* "~%Function documentation for ~S:~&~%" sym)
+          (write-string doc *standard-output*))))
+
 
 

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

@@ -543 +543 @@
         (unless (line-offset mark 1 0)
           (return))))
-    (with-pop-up-display (s :height (length matching-lines))
+    (with-pop-up-display (s :height (length matching-lines) :title (format nil "Lines matching ~s" string))
       (dolist (line matching-lines)
         (write-line line s)))))