Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv22315

Modified Files: swine.lisp swine-cmds.lisp Log Message: De-Swankified Swine. Moved all direct calls to Swank functions to a small Swank-interface-layer and changed names of functions to downplay Swank (this also involved removing the name Swine from various commands). The purpose of this is to make the use of Swank more transparent and manageable, and to make Swine seem more integrated with the Lisp syntax and not appear like a separate library. The ultimate goal is, of course, to get Swine into Climacs itself.

--- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/05/30 23:22:39 1.16 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/05/31 18:01:04 1.17 @@ -25,7 +25,80 @@

(in-package :climacs-lisp-syntax)

-;; Convenience functions: +;;; Swank interface functions: + +(defun compile-string-for-climacs (string package buffer buffer-mark) + "Compile and evaluate `string' in `package'. Two values are +returned: The result of evaluating `string' and a list of +compiler notes. `Buffer' and `buffer-mark' will be used for +hyperlinking the compiler notes to the source code." + (let* ((buffer-name (name buffer)) + (buffer-file-name (filepath buffer)) + ;; swank::compile-string-for-emacs binds *compile-verbose* to t + ;; so we need to do this to avoid scribbles on the pane + (*standard-output* *debug-io*) + (swank::*buffer-package* package) + (swank::*buffer-readtable* *readtable*)) + (let ((result (swank::compile-string-for-emacs + string buffer-name (offset buffer-mark) buffer-file-name)) + (notes (loop for note in (swank::compiler-notes-for-emacs) + collect (make-compiler-note note)))) + (values result notes)))) + +(defun compile-form-for-climacs (form buffer buffer-mark) + "Compile and evaluate `form', which must be a valid Lisp +form. Two values are returned: The result of evaluating `string' +and a list of compiler notes. `Buffer' and `buffer-mark' will be +used for hyperlinking the compiler notes to the source code." + (compile-string-for-climacs (write-to-string form) *package* buffer buffer-mark)) + +(defun compile-file-for-climacs (filepath package &optional load-p) + "Compile the file at `filepath' in `package'. If `load-p' is +non-NIL, also load the file at `filepath'. Two values will be +returned: the result of compiling the file and a list of compiler +notes." + (let* ((swank::*buffer-package* package) + (swank::*buffer-readtable* *readtable*) + (*compile-verbose* nil) + (result (swank::compile-file-for-emacs filepath load-p)) + (notes (loop for note in (swank::compiler-notes-for-emacs) + collect (make-compiler-note note)))) + (values result notes))) + +(defun find-definitions-for-climacs (symbol) + "Return list of definitions for `symbol'." + (flet ((fully-qualified-symbol-name (symbol) + (let ((*package* (find-package :keyword))) + (format nil "~S" symbol)))) + (let* ((name (fully-qualified-symbol-name symbol)) + (swank::*buffer-package* *package*) + (swank::*buffer-readtable* *readtable*)) + (swank::find-definitions-for-emacs name)))) + +(defun get-class-keyword-parameters (class) + "Get a list of keyword parameters (possibly along with any +default values) that can be used in a `make-instance' form for +`class'." + (loop for arg in (swank::extra-keywords/make-instance 'make-instance class) + if (swank::keyword-arg.default-arg arg) + collect (list (swank::keyword-arg.arg-name arg) + (swank::keyword-arg.default-arg arg)) + else collect (swank::keyword-arg.arg-name arg))) + +(defun arglist (symbol) + "Get plain arglist for symbol." + (swank::arglist symbol)) + +(defun simple-completions (string default-package) + "Return a list of simple symbol-completions for `string' in +`default-package'." + (swank::completions string (package-name default-package))) + +(defun fuzzy-completions (symbol-name default-package &optional limit) + "Return a list of fuzzy completions for `symbol-name'." + (swank::fuzzy-completions symbol-name (package-name default-package) limit)) + +;;; Convenience functions:

(defun unlisted (obj) (if (listp obj) @@ -51,9 +124,8 @@

(defun symbol-name-at-mark (mark syntax) "Return the text of the symbol at mark." - (symbol-name (token-to-symbol syntax - (expression-at-mark mark syntax) - :preserve))) + (token-string syntax + (symbol-at-mark mark syntax)))

(defun this-form (mark syntax) "Return a form at mark. This function defines which @@ -66,6 +138,15 @@ (or (find-package package-designator) *package*))

+(defmacro with-syntax-package (syntax (package-sym) + &body body) + "Evaluate `body' with `package-sym' bound to a valid package, + preferably taken from `syntax'." + `(let ((,package-sym (usable-package (slot-value ,syntax 'package)))) + ,@body)) + +;;; Real code: + (defun macroexpand-token (syntax token &optional (all nil)) (let* ((string (token-string syntax token)) (expression (read-from-string string)) @@ -114,29 +195,26 @@ values))) (esa:display-message result))))

-(defun compile-defun-with-swank (mark pane syntax) - (with-slots (package) syntax - (let* ((string (text-of-definition-at-mark mark syntax)) - (buffer-name (name (buffer pane))) - (buffer-file-name (filepath (buffer pane))) - (m (clone-mark mark)) - ;; swank::compile-string-for-emacs binds *compile-verbose* to t - ;; so we need to do this to avoid scribbles on the pane - (*standard-output* *debug-io*) - (swank::*buffer-package* (or package *package*)) - (swank::*buffer-readtable* *readtable*)) - (end-of-definition m syntax) - (beginning-of-definition m syntax) - (let ((result (swank::compile-string-for-emacs - string buffer-name (offset m) buffer-file-name)) - (notes (loop for note in (swank::compiler-notes-for-emacs) - collect (make-swine-compiler-note note)))) - (show-swine-note-counts notes (second result)) - (when notes - (show-swine-notes notes buffer-name - (one-line-ify (subseq string 0 (max (length string) 20))))))))) +(defun compile-definition-interactively (mark pane syntax) + (with-syntax-package syntax (package) + (let* ((token (definition-at-mark mark syntax)) + (string (token-string syntax token)) + (m (clone-mark mark)) + (buffer-name (name (buffer pane)))) + (end-of-definition m syntax) + (beginning-of-definition m syntax) + (multiple-value-bind (result notes) + (compile-form-for-climacs (token-to-object syntax token + :read t + :package package) + (buffer pane) + m) + (show-note-counts notes (second result)) + (when notes + (show-notes notes buffer-name + (one-line-ify (subseq string 0 (min (length string) 20)))))))))

-(defun make-swine-compiler-note (note-list) +(defun make-compiler-note (note-list) (let ((severity (getf note-list :severity)) (message (getf note-list :message)) (location (getf note-list :location)) @@ -144,148 +222,148 @@ (short-message (getf note-list :short-message))) (make-instance (ecase severity - (:error 'swine-error-compiler-note) - (:read-error 'swine-read-error-compiler-note) - (:warning 'swine-warning-compiler-note) - (:style-warning 'swine-style-warning-compiler-note) - (:note 'swine-note-compiler-note)) + (:error 'error-compiler-note) + (:read-error 'read-error-compiler-note) + (:warning 'warning-compiler-note) + (:style-warning 'style-warning-compiler-note) + (:note 'note-compiler-note)) :message message :location location :references references :short-message short-message)))

-(defclass swine-compiler-note () +(defclass compiler-note () ((message :initarg :message :initform nil :accessor message) (location :initarg :location :initform nil :accessor location) (references :initarg :references :initform nil :accessor references) (short-message :initarg :short-message :initform nil :accessor short-message)) - (:documentation "The base for all swine-compiler-notes.")) + (:documentation "The base for all compiler-notes."))

-(defclass swine-error-compiler-note (swine-compiler-note) ()) +(defclass error-compiler-note (compiler-note) ())

-(defclass swine-read-error-compiler-note (swine-compiler-note) ()) +(defclass read-error-compiler-note (compiler-note) ())

-(defclass swine-warning-compiler-note (swine-compiler-note) ()) +(defclass warning-compiler-note (compiler-note) ())

-(defclass swine-style-warning-compiler-note (swine-compiler-note) ()) +(defclass style-warning-compiler-note (compiler-note) ())

-(defclass swine-note-compiler-note (swine-compiler-note) ()) +(defclass note-compiler-note (compiler-note) ())

-(defclass swine-location ()() - (:documentation "The base for all swine-locations.")) +(defclass location ()() + (:documentation "The base for all locations."))

-(defclass swine-error-location (swine-location) +(defclass error-location (location) ((error-message :initarg :error-message :accessor error-message)))

-(defclass swine-actual-location (swine-location) +(defclass actual-location (location) ((source-position :initarg :position :accessor source-position) (snippet :initarg :snippet :accessor snippet :initform nil)) - (:documentation "The base for all non-error swine-locations.")) + (:documentation "The base for all non-error locations."))

-(defclass swine-buffer-location (swine-actual-location) +(defclass buffer-location (actual-location) ((buffer-name :initarg :buffer :accessor buffer-name)))

-(defclass swine-file-location (swine-actual-location) +(defclass file-location (actual-location) ((file-name :initarg :file :accessor file-name)))

-(defclass swine-source-location (swine-actual-location) +(defclass source-location (actual-location) ((source-form :initarg :source-form :accessor source-form)))

-(defclass swine-position () () - (:documentation "The base for all swine-positions.")) +(defclass basic-position () () + (:documentation "The base for all positions."))

-(defclass swine-char-position (swine-position) +(defclass char-position (basic-position) ((char-position :initarg :position :accessor char-position) (align-p :initarg :align-p :initform nil :accessor align-p)))

-(defun make-swine-char-position (position-list) - (make-instance 'swine-char-position :position (second position-list) +(defun make-char-position (position-list) + (make-instance 'char-position :position (second position-list) :align-p (third position-list)))

-(defclass swine-line-position (swine-position) +(defclass line-position (basic-position) ((start-line :initarg :line :accessor start-line) (end-line :initarg :end-line :initform nil :accessor end-line)))

-(defun make-swine-line-position (position-list) - (make-instance 'swine-line-position :line (second position-list) +(defun make-line-position (position-list) + (make-instance 'line-position :line (second position-list) :end-line (third position-list)))

-(defclass swine-function-name-position (swine-position) +(defclass function-name-position (basic-position) ((function-name :initarg :function-name)))

-(defun make-swine-function-name-position (position-list) - (make-instance 'swine-function-name-position :function-name (second position-list))) +(defun make-function-name-position (position-list) + (make-instance 'function-name-position :function-name (second position-list)))

-(defclass swine-source-path-position (swine-position) +(defclass source-path-position (basic-position) ((path :initarg :source-path :accessor path) (start-position :initarg :start-position :accessor start-position)))

-(defun make-swine-source-path-position (position-list) - (make-instance 'swine-source-path-position :source-path (second position-list) +(defun make-source-path-position (position-list) + (make-instance 'source-path-position :source-path (second position-list) :start-position (third position-list)))

-(defclass swine-text-anchored-position (swine-position) +(defclass text-anchored-position (basic-position) ((start :initarg :text-anchored :accessor start) (text :initarg :text :accessor text) (delta :initarg :delta :accessor delta)))

-(defun make-swine-text-anchored-position (position-list) - (make-instance 'swine-text-anchored-position :text-anchored (second position-list) +(defun make-text-anchored-position (position-list) + (make-instance 'text-anchored-position :text-anchored (second position-list) :text (third position-list) :delta (fourth position-list)))

-(defclass swine-method-position (swine-position) +(defclass method-position (basic-position) ((name :initarg :method :accessor name) (specializers :initarg :specializers :accessor specializers) (qualifiers :initarg :qualifiers :accessor qualifiers)))

-(defun make-swine-method-position (position-list) - (make-instance 'swine-method-position :method (second position-list) +(defun make-method-position (position-list) + (make-instance 'method-position :method (second position-list) :specializers (third position-list) :qualifiers (last position-list)))

-(defun make-swine-location (location-list) +(defun make-location (location-list) (ecase (first location-list) - (:error (make-instance 'swine-error-location :error-message (second location-list))) + (:error (make-instance 'error-location :error-message (second location-list))) (:location (destructuring-bind (l buf pos hints) location-list (declare (ignore l)) (let ((location (apply #'make-instance (ecase (first buf) - (:file 'swine-file-location) - (:buffer 'swine-buffer-location) - (:source-form 'swine-source-location)) + (:file 'file-location) + (:buffer 'buffer-location) + (:source-form 'source-location)) buf)) (position (funcall (ecase (first pos) - (:position #'make-swine-char-position) - (:line #'make-swine-line-position) - (:function-name #'make-swine-function-name-position) - (:source-path #'make-swine-source-path-position) - (:text-anchored #'make-swine-text-anchored-position) - (:method #'make-swine-method-position)) + (:position #'make-char-position) + (:line #'make-line-position) + (:function-name #'make-function-name-position) + (:source-path #'make-source-path-position) + (:text-anchored #'make-text-anchored-position) + (:method #'make-method-position)) pos))) (setf (source-position location) position) (when hints (setf (snippet location) (rest hints))) location)))))

-(defmethod initialize-instance :after ((note swine-compiler-note) &rest args) +(defmethod initialize-instance :after ((note compiler-note) &rest args) (declare (ignore args)) - (setf (location note) (make-swine-location (location note)))) + (setf (location note) (make-location (location note))))

-(defun show-swine-note-counts (notes &optional seconds) +(defun show-note-counts (notes &optional seconds) (loop with nerrors = 0 with nwarnings = 0 with nstyle-warnings = 0 with nnotes = 0 for note in notes do (etypecase note - (swine-error-compiler-note (incf nerrors)) - (swine-read-error-compiler-note (incf nerrors)) - (swine-warning-compiler-note (incf nwarnings)) - (swine-style-warning-compiler-note (incf nstyle-warnings)) - (swine-note-compiler-note (incf nnotes))) + (error-compiler-note (incf nerrors)) + (read-error-compiler-note (incf nerrors)) + (warning-compiler-note (incf nwarnings)) + (style-warning-compiler-note (incf nstyle-warnings)) + (note-compiler-note (incf nnotes))) finally (climacs-gui::display-message "Compilation finished: ~D error~:P ~ ~D warning~:P ~D style-warning~:P ~D note~:P ~ @@ -325,17 +403,17 @@ `(defmethod print-for-menu ((object ,class) stream) (print-note-for-menu object stream ,name ,colour)))

-(def-print-for-menu swine-error-compiler-note "Error" +red+) -(def-print-for-menu swine-read-error-compiler-note "Read Error" +red+) -(def-print-for-menu swine-warning-compiler-note "Warning" +dark-red+) -(def-print-for-menu swine-style-warning-compiler-note "Style Warning" +brown+) -(def-print-for-menu swine-note-compiler-note "Note" +brown+) +(def-print-for-menu error-compiler-note "Error" +red+) +(def-print-for-menu read-error-compiler-note "Read Error" +red+) +(def-print-for-menu warning-compiler-note "Warning" +dark-red+) +(def-print-for-menu style-warning-compiler-note "Style Warning" +brown+) +(def-print-for-menu note-compiler-note "Note" +brown+)

-(defun show-swine-notes (notes buffer-name definition) +(defun show-notes (notes buffer-name definition) (let ((stream (climacs-gui::typeout-window (format nil "~10TCompiler Notes: ~A ~A" buffer-name definition)))) (loop for note in notes - do (with-output-as-presentation (stream note 'swine-compiler-note) + do (with-output-as-presentation (stream note 'compiler-note) (print-for-menu note stream)) (terpri stream) count note into length @@ -343,23 +421,23 @@ :height (* length (stream-line-height stream))) (scroll-extent stream 0 0))))

-(defgeneric goto-swine-location (swine-location)) +(defgeneric goto-location (location))

[284 lines skipped] --- /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/05/30 20:38:58 1.18 +++ /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/05/31 18:01:04 1.19 @@ -32,10 +32,11 @@ (mark (point (current-window))) (token (form-before syntax (offset mark)))) (if token - (let ((*package* (slot-value syntax 'package))) - (climacs-gui::com-eval-expression - (read-from-string (token-string syntax token)) - insertp)) + (with-syntax-package syntax (package) + (let ((*package* package)) + (climacs-gui::com-eval-expression + (read-from-string (token-string syntax token)) + insertp))) (esa:display-message "Nothing to evaluate."))))

(esa:set-key `(com-eval-last-expression ,esa:*numeric-argument-p*) @@ -91,9 +92,9 @@ (define-command (com-compile-definition :name t :command-table lisp-table) () "Compile and load definition at point." - (compile-defun-with-swank (point (current-window)) - (current-window) - (syntax (buffer (current-window))))) + (compile-definition-interactively (point (current-window)) + (current-window) + (syntax (buffer (current-window)))))

(esa:set-key 'com-compile-definition 'lisp-table @@ -104,7 +105,7 @@ "Compile and load the current file.

Compiler notes will be displayed in a seperate buffer." - (compile-file-with-swank (buffer (current-window)) t)) + (compile-file-interactively (buffer (current-window)) t))

(esa:set-key 'com-compile-and-load-file 'lisp-table @@ -115,33 +116,33 @@ "Compile the file open in the current buffer.

This command does not load the file after it has been compiled." - (compile-file-with-swank (buffer (current-window)) nil)) + (compile-file-interactively (buffer (current-window)) nil))

(esa:set-key 'com-compile-file 'lisp-table '((#\c :control) (#\k :meta)))

(define-command (com-goto-location :name t :command-table lisp-table) - ((note 'swine-compiler-note)) + ((note 'compiler-note)) "Move point to the part of a given file that caused the compiler note.

If the file is not already open, a new buffer will be opened with that file." - (goto-swine-location (location note))) + (goto-location (location note)))

-(define-presentation-to-command-translator swine-compiler-note-to-goto-location-translator - (swine-compiler-note com-goto-location lisp-table) - (presentation) - (list (presentation-object presentation))) +(define-presentation-to-command-translator compiler-note-to-goto-location-translator + (compiler-note com-goto-location lisp-table) + (presentation) + (list (presentation-object presentation)))

(define-command (com-goto-xref :name t :command-table lisp-table) - ((xref 'swine-xref)) + ((xref 'xref)) "Go to the referenced location of a code cross-reference." - (goto-swine-location xref)) + (goto-location xref))

-(define-presentation-to-command-translator swine-xref-to-goto-location-translator - (swine-xref com-goto-xref lisp-table) +(define-presentation-to-command-translator xref-to-goto-location-translator + (xref com-goto-xref lisp-table) (presentation) (list (presentation-object presentation)))

@@ -207,7 +208,7 @@ 'lisp-table '((#\c :control) (#\d :control) (#\a)))

-(define-command (com-swine-space :command-table lisp-table) +(define-command (com-space :command-table lisp-table) () "Insert a space and display argument hints in the minibuffer." (let* ((window (current-window)) @@ -228,28 +229,11 @@ (forward-object mark) (clear-completions)))

-(esa:set-key 'com-swine-space +(esa:set-key 'com-space 'lisp-table '((#\Space)))

-(define-command (com-swine-simple-completion :name t :command-table lisp-table) - () - "Attempt a simple symbol-completion for the symbol at mark. - -If more than one completion is available, a list of possible -completions will be displayed." - (let* ((point-current-window (point (current-window))) - (name (symbol-name-at-mark point-current-window - (syntax (buffer (current-window)))))) - (when name - (let* ((completion (show-simple-completions name)) - (difference (let ((mismatch (mismatch name completion))) - (if mismatch - (subseq completion mismatch) - "")))) - (insert-sequence point-current-window difference))))) - -(define-command (com-swine-completion :name t :command-table lisp-table) () +(define-command (com-complete-symbol :name t :command-table lisp-table) () "Attempt to complete the symbol at mark.

If more than one completion is available, a list of possible @@ -260,12 +244,12 @@ (when name (let ((completion (show-completions name)) (mark (clone-mark point-current-window))) - (unless (= (length completion) 0) + (unless (= (length completion) 0) (backward-object mark (length name)) (delete-region mark point-current-window) (insert-sequence point-current-window completion))))))

-(define-command (com-swine-fuzzy-completion :name t :command-table lisp-table) () +(define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) () "Attempt to fuzzily complete the abbreviation at mark.

Fuzzy completion tries to guess which symbol is abbreviated. If @@ -282,12 +266,11 @@ (delete-region mark point-current-window) (insert-sequence point-current-window completion))))))

-(esa:set-key 'com-swine-completion +(esa:set-key 'com-complete-symbol 'lisp-table '((#\Tab :meta)))

- -(esa:set-key 'com-swine-fuzzy-completion +(esa:set-key 'com-fuzzily-complete-symbol 'lisp-table '((#\c :control) (#\i :meta)))