/[climacs]/climacs/climacs-lisp-syntax.lisp
ViewVC logotype

Diff of /climacs/climacs-lisp-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by thenriksen, Tue Nov 20 12:59:53 2007 UTC revision 1.6 by thenriksen, Sat Dec 8 08:55:06 2007 UTC
# Line 49  Line 49 
49     (snippet :initarg :snippet :accessor snippet :initform nil))     (snippet :initarg :snippet :accessor snippet :initform nil))
50    (:documentation "The base for all non-error locations."))    (:documentation "The base for all non-error locations."))
51    
52  (defclass buffer-location (actual-location)  (defclass view-location (actual-location)
53    ((buffer-name :initarg :buffer :accessor buffer-name)))    ((view-name :initarg :view :accessor view-name)))
54    
55  (defclass file-location (actual-location)  (defclass file-location (actual-location)
56    ((file-name :initarg :file :accessor file-name)))    ((file-name :initarg :file :accessor file-name)))
# Line 121  Line 121 
121                (apply #'make-instance                (apply #'make-instance
122                       (ecase (first buf)                       (ecase (first buf)
123                         (:file 'file-location)                         (:file 'file-location)
124                         (:buffer 'buffer-location)                         (:buffer 'view-location)
125                         (:source-form 'source-location))                         (:source-form 'source-location))
126                       buf))                       buf))
127               (position               (position
# Line 204  Each newline and following whitespace is Line 204  Each newline and following whitespace is
204  (def-print-for-menu style-warning-compiler-note "Style Warning" +brown+)  (def-print-for-menu style-warning-compiler-note "Style Warning" +brown+)
205  (def-print-for-menu note-compiler-note "Note" +brown+)  (def-print-for-menu note-compiler-note "Note" +brown+)
206    
207  (defun show-notes (notes buffer-name definition)  (defun show-notes (notes view-name definition)
208    (let ((stream (climacs-gui:typeout-window    (let ((stream (climacs-gui:typeout-window
209                   (format nil "~10TCompiler Notes: ~A  ~A" buffer-name definition))))                   (format nil "~10TCompiler Notes: ~A  ~A" view-name definition))))
210      (loop for note in notes      (loop for note in notes
211         do (with-output-as-presentation (stream note 'compiler-note)         do (with-output-as-presentation (stream note 'compiler-note)
212              (print-for-menu note stream))              (print-for-menu note stream))
# Line 221  Each newline and following whitespace is Line 221  Each newline and following whitespace is
221  (defmethod goto-location ((location error-location))  (defmethod goto-location ((location error-location))
222    (esa:display-message (error-message location)))    (esa:display-message (error-message location)))
223    
224  (defmethod goto-location ((location buffer-location))  (defmethod goto-location ((location view-location))
225    (let ((buffer (find (buffer-name location)    (let ((view (find (view-name location)
226                        (buffers *application-frame*)                      (climacs-gui:views *esa-instance*)
227                        :test #'string= :key #'name)))                      :test #'string= :key #'name)))
228      (unless buffer      (unless view
229        (esa:display-message "No buffer ~A" (buffer-name location))        (esa:display-message "No view ~A" (view-name location))
230        (beep)        (beep)
231        (return-from goto-location))        (return-from goto-location))
232      (climacs-core:switch-to-buffer (current-window) buffer)      (climacs-core:switch-to-view (current-window) view)
233      (goto-position (point (current-window))      (goto-position (point)
234                     (char-position (source-position location)))))                     (char-position (source-position location)))))
235    
236  (defmethod goto-location ((location file-location))  (defmethod goto-location ((location file-location))
237    (let ((buffer (find (file-name location)    (let ((view (find (file-name location)
238                        (buffers *application-frame*)                        (views *application-frame*)
239                        :test #'string= :key #'(lambda (buffer)                        :test #'string= :key #'(lambda (view)
240                                                 (let ((path (filepath buffer)))                                                 (let ((path (filepath view)))
241                                                   (when path                                                   (when path
242                                                     (namestring path)))))))                                                     (namestring path)))))))
243      (if buffer      (if view
244          (climacs-core:switch-to-buffer (current-window) buffer)          (climacs-core:switch-to-view (current-window) view)
245          (find-file (file-name location)))          (find-file (file-name location)))
246      (goto-position (point (current-window))      (goto-position (point (current-window))
247                     (char-position (source-position location)))))                     (char-position (source-position location)))))
# Line 259  Each newline and following whitespace is Line 259  Each newline and following whitespace is
259                                                 all))                                                 all))
260             (expansion-string (with-output-to-string (s)             (expansion-string (with-output-to-string (s)
261                                 (pprint expansion s))))                                 (pprint expansion s))))
262        (let ((buffer (climacs-core:switch-to-buffer (current-window) "*Macroexpansion*")))        (let ((view (climacs-core:switch-to-view (current-window) "*Macroexpansion*")))
263          (set-syntax buffer "Lisp"))          (set-syntax view "Lisp"))
264        (let ((point (point (current-window)))        (let ((header-string (one-line-ify (subseq string 0
             (header-string (one-line-ify (subseq string 0  
265                                                   (min 40 (length string))))))                                                   (min 40 (length string))))))
266          (end-of-buffer point)          (end-of-buffer (point))
267          (unless (beginning-of-buffer-p point)          (unless (beginning-of-buffer-p (point))
268            (insert-object point #\Newline))            (insert-object (point) #\Newline))
269          (insert-sequence point          (insert-sequence (point)
270                           (format nil ";;; Macroexpand-~:[1~;all~] ~A...~%"                           (format nil ";;; Macroexpand-~:[1~;all~] ~A...~%"
271                                   all header-string))                                   all header-string))
272          (insert-sequence point expansion-string)          (insert-sequence (point) expansion-string)
273          (insert-object point #\Newline)))))          (insert-object (point) #\Newline)))))
274    
275  (defun compile-definition-interactively (mark syntax)  (defun compile-definition-interactively (view mark)
276    (let* ((token (definition-at-mark syntax mark))    (let* ((syntax (syntax view))
277             (token (definition-at-mark syntax mark))
278           (string (form-string syntax token))           (string (form-string syntax token))
279           (m (clone-mark mark))           (m (clone-mark mark))
          (buffer-name (name (buffer syntax)))  
280           (*read-base* (base syntax)))           (*read-base* (base syntax)))
281      (with-syntax-package (syntax mark)      (with-syntax-package (syntax mark)
282        (forward-definition m syntax 1 nil)        (forward-definition m syntax 1 nil)
# Line 287  Each newline and following whitespace is Line 286  Each newline and following whitespace is
286                                       (form-to-object syntax token                                       (form-to-object syntax token
287                                        :read t                                        :read t
288                                        :package (package-at-mark syntax mark))                                        :package (package-at-mark syntax mark))
289                                       (buffer syntax)                                       syntax m)
                                      m)  
290              (show-note-counts notes (second result))              (show-note-counts notes (second result))
291              (when (not (null notes))              (when (not (null notes))
292                (show-notes notes buffer-name                (show-notes notes (name view)
293                            (one-line-ify (subseq string 0 (min (length string) 20))))))                            (one-line-ify (subseq string 0 (min (length string) 20))))))
294            (display-message "No definition at point")))))            (display-message "No definition at point")))))
295    
296  (defun compile-file-interactively (buffer &optional load-p)  (defun compile-file-interactively (view &optional load-p)
297    (cond ((null (filepath buffer))    (let ((buffer (buffer view)))
298           (esa:display-message "Buffer ~A is not associated with a file" (name buffer)))      (cond ((null (filepath buffer))
299          (t             (esa:display-message "View ~A is not associated with a file" (name view)))
300           (when (and (needs-saving buffer)            (t
301                      (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer))))             (when (and (needs-saving buffer)
302             (climacs-core:save-buffer buffer))                        (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name view))))
303           (let ((*read-base* (base (syntax buffer))))               (climacs-core:save-buffer buffer))
304             (multiple-value-bind (result notes)             (let ((*read-base* (base (syntax view))))
305                 (compile-file-for-drei (get-usable-image (syntax buffer))               (multiple-value-bind (result notes)
306                                           (filepath buffer)                   (compile-file-for-drei (get-usable-image (syntax view))
307                                           (package-at-mark (syntax buffer) 0) load-p)                                          (filepath buffer)
308               (show-note-counts notes (second result))                                          (package-at-mark (syntax view) 0) load-p)
309               (when notes (show-notes notes (name buffer) "")))))))                 (show-note-counts notes (second result))
310                   (when notes (show-notes notes (name view) ""))))))))
311    
312  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
313  ;;;  ;;;
# Line 318  Each newline and following whitespace is Line 317  Each newline and following whitespace is
317    
318  (defun pop-find-definition-stack ()  (defun pop-find-definition-stack ()
319    (unless (null *find-definition-stack*)    (unless (null *find-definition-stack*)
320      (let* ((offset+buffer (pop *find-definition-stack*))      (let* ((offset+view (pop *find-definition-stack*))
321             (offset (first offset+buffer))             (offset (first offset+view))
322             (buffer (second offset+buffer)))             (view (second offset+view)))
323        (if (find buffer (buffers *application-frame*))        (if (find view (views *esa-instance*))
324            (progn (climacs-core:switch-to-buffer (current-window) buffer)            (progn (climacs-core:switch-to-view (current-window) view)
325                   (goto-position (point (current-window)) offset))                   (goto-position (point) offset))
326            (pop-find-definition-stack)))))            (pop-find-definition-stack)))))
327    
328  ;; KLUDGE: We need to put more info in the definition objects to begin  ;; KLUDGE: We need to put more info in the definition objects to begin
# Line 331  Each newline and following whitespace is Line 330  Each newline and following whitespace is
330  (defun definition-type (definition)  (defun definition-type (definition)
331    (let ((data (read-from-string (first definition))))    (let ((data (read-from-string (first definition))))
332      (case (first data)      (case (first data)
333        ((or cl:defclass)        ((cl:defclass)
334         'cl:class)         'cl:class)
335        ((or cl:defgeneric        ((cl:defgeneric
336             cl:defmethod             cl:defmethod
337             cl:defun             cl:defun
338             cl:defmacro)           cl:defmacro)
339         'cl:function)         'cl:function)
340        (t t))))        (t t))))
341    
342  (defun edit-definition (symbol &optional type)  (defun edit-definition (symbol &optional type)
343    (let ((all-definitions (find-definitions-for-drei    (let ((all-definitions (find-definitions-for-drei
344                            (get-usable-image (syntax (current-buffer)))                            (get-usable-image (current-syntax))
345                            symbol)))                            symbol)))
346      (let ((definitions (if (not type)      (let ((definitions (if (not type)
347                             all-definitions                             all-definitions
# Line 356  Each newline and following whitespace is Line 355  Each newline and following whitespace is
355               (goto-definition symbol definitions))))))               (goto-definition symbol definitions))))))
356    
357  (defun goto-definition (name definitions)  (defun goto-definition (name definitions)
358    (let* ((pane (current-window))    (push (list (offset (point)) (current-view)) *find-definition-stack*)
          (buffer (buffer pane))  
          (point (point pane))  
          (offset (offset point)))  
     (push (list offset buffer) *find-definition-stack*))  
359    (cond ((null (cdr definitions))    (cond ((null (cdr definitions))
360           (let* ((def (car definitions))           (let* ((def (car definitions))
361                  (xref (make-xref def)))                  (xref (make-xref def)))
# Line 413  Each newline and following whitespace is Line 408  Each newline and following whitespace is
408    
409  ;; WARNING, using this group can be dangerous, as Climacs is not  ;; WARNING, using this group can be dangerous, as Climacs is not
410  ;; really suited to opening up a large amount of buffers that each  ;; really suited to opening up a large amount of buffers that each
 ;; require a full syntax reparse.  FIXME: Groups are currently  
 ;; disabled.  
 #+nil (climacs-core:define-group "ASDF System Files" (group (system (asdf:find-system (accept 'symbol :prompt "System"))))  
         (declare (ignore group))  
         (when system  
           (mapcar #'asdf:component-pathname  
                   (remove-if-not (lambda (c)  
                                    (typep c 'asdf:cl-source-file))  
                                  (asdf:module-components system)))))  
411    ;; require a full syntax reparse.
412    (climacs-core:define-group "ASDF System Files" (group (system (asdf:find-system (accept 'symbol :prompt "System"))))
413      (declare (ignore group))
414      (when system
415        (mapcar #'asdf:component-pathname
416                (remove-if-not (lambda (c)
417                                 (typep c 'asdf:cl-source-file))
418                               (asdf:module-components system)))))

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

  ViewVC Help
Powered by ViewVC 1.1.5