Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv924
Modified Files: lisp-syntax.lisp lisp-syntax-swank.lisp lisp-syntax-commands.lisp Added Files: lisp-syntax-swine.lisp Log Message: Big refactoring and enhancement patch for Lisp syntax.
* New file added, lisp-syntax-swine.lisp, in order to keep the size of lisp-syntax.lisp down.
* `define-form-traits' macro that can be used to teach Climacs how to intelligently handle certain forms (for example, only symbols naming classes will be completed from when using `make-instance' or `make-pane').
* Taught Climacs how to handle certain forms.
--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/11 21:59:05 1.108 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/20 13:10:31 1.109 @@ -28,9 +28,9 @@ ;;; ;;; Convenience functions and macros:
-(defun unlisted (obj) +(defun unlisted (obj &optional (fn #'first)) (if (listp obj) - (first obj) + (funcall fn obj) obj))
(defun listed (obj) @@ -614,57 +614,66 @@ (t (fo) (make-instance 'delimiter-lexeme)))))
(defun lex-token (syntax scan) - ;; May need more work. Can recognize symbols and numbers. - (flet ((fo () (forward-object scan))) - (let ((could-be-number t) - sign-seen dot-seen slash-seen nondot-seen) - (flet ((return-token-or-number-lexeme () - (return-from lex-token - (if could-be-number - (if nondot-seen - (make-instance 'number-lexeme) - (make-instance 'dot-lexeme)) - (make-instance 'complete-token-lexeme)))) - (this-object () - (object-after scan))) - (tagbody - START + ;; May need more work. Can recognize symbols and numbers. This can + ;; get very ugly and complicated (out of necessity I believe). + (let ((could-be-number t) + sign-seen dot-seen slash-seen nondot-seen number-seen exponent-seen) + (flet ((fo () (forward-object scan)) + (return-token-or-number-lexeme () + (return-from lex-token + (if (and could-be-number + (if exponent-seen + nondot-seen t)) + (if nondot-seen + (make-instance 'number-lexeme) + (make-instance 'dot-lexeme)) + (make-instance 'complete-token-lexeme)))) + (this-object () + (object-after scan))) + (tagbody + START + (when (end-of-buffer-p scan) + (return-token-or-number-lexeme)) + (when (constituentp (object-after scan)) + (when (not (eql (this-object) #.)) + (setf nondot-seen t)) + (cond ((or (eql (this-object) #+) + (eql (this-object) #-)) + (when (or sign-seen number-seen slash-seen) + (setf could-be-number nil)) + (setf sign-seen t)) + ((eql (this-object) #.) + (when (or dot-seen exponent-seen) + (setf could-be-number nil)) + (setf dot-seen t)) + ((member (this-object) + '(#\e #\f #\l #\s #\d) + :test #'equalp) + (when exponent-seen + (setf could-be-number nil)) + (setf exponent-seen t) + (setf number-seen nil) + (setf sign-seen nil)) + ((eql (this-object) #/) + (when (or slash-seen dot-seen exponent-seen) + (setf could-be-number nil)) + (setf slash-seen t)) + ((not (digit-char-p (this-object) + (base syntax))) + (setf could-be-number nil)) + (t (setf number-seen t))) + (fo) + (go START)) + (when (eql (object-after scan) #\) + (fo) (when (end-of-buffer-p scan) - (return-token-or-number-lexeme)) - (when (constituentp (object-after scan)) - (when (not (eql (this-object) #.)) - (setf nondot-seen t)) - (cond ((or (eql (this-object) #+) - (eql (this-object) #-)) - (when sign-seen - (setf could-be-number nil)) - (setf sign-seen t)) - ((eql (this-object) #.) - (when dot-seen - (setf could-be-number nil)) - (setf dot-seen t)) - ((eql (this-object) #/) - (when slash-seen - (setf could-be-number nil)) - (setf slash-seen t)) - ;; We obey the base specified in the file when - ;; determining whether or not this character is an - ;; integer. - ((not (digit-char-p (this-object) - (base syntax))) - (setf could-be-number nil))) - (fo) - (go START)) - (when (eql (object-after scan) #\) - (fo) - (when (end-of-buffer-p scan) - (return-from lex-token (make-instance 'incomplete-lexeme))) - (fo) - (go START)) - (when (eql (object-after scan) #|) - (fo) - (return-from lex-token (make-instance 'multiple-escape-start-lexeme))) - (return-token-or-number-lexeme)))))) + (return-from lex-token (make-instance 'incomplete-lexeme))) + (fo) + (go START)) + (when (eql (object-after scan) #|) + (fo) + (return-from lex-token (make-instance 'multiple-escape-start-lexeme))) + (return-token-or-number-lexeme)))))
(defmethod lex ((syntax lisp-syntax) (state lexer-escaped-token-state) scan) (let ((bars-seen 0)) @@ -1380,7 +1389,7 @@ (defmacro with-syntax-package ((syntax offset) &body body) "Evaluate `body' with `*package*' bound to a valid package, - preferably taken from `syntax' based on `offset'.." + preferably taken from `syntax' based on `offset'." `(let ((*package* (package-at-mark ,syntax ,offset))) ,@body))
@@ -1555,10 +1564,9 @@ (:method (form syntax) nil))
(defmethod form-operands ((form list-form) syntax) - (mapcar #'(lambda (operand) - (if (typep operand 'form) - (token-to-object syntax operand :no-error t))) - (rest-forms (children form)))) + (loop for operand in (rest-forms (children form)) + when (typep operand 'form) + collect (token-to-object syntax operand :no-error t)))
(defun form-toplevel (form syntax) "Return the top-level form of `form'." @@ -1588,9 +1596,9 @@ returned. Otherwise, the form following `mark-or-offset' is returned." (as-offsets ((mark-or-offset offset)) - (or (form-around syntax offset) - (form-after syntax offset) - (form-before syntax offset)))) + (or (form-around syntax offset) + (form-after syntax offset) + (form-before syntax offset))))
(defun definition-at-mark (mark-or-offset syntax) "Return the top-level form at `mark-or-offset'. If `mark-or-offset' is just after, @@ -1611,6 +1619,24 @@ form)))) (unwrap-form (expression-at-mark mark-or-offset syntax))))
+(defun fully-quoted-form (token) + "Return the top token object for `token', return `token' or the +top quote-form that `token' is buried in. " + (labels ((ascend (form) + (cond ((typep (parent form) 'quote-form) + (ascend (parent form))) + (t form)))) + (ascend token))) + +(defun fully-unquoted-form (token) + "Return the bottom token object for `token', return `token' or +the form that `token' quotes, peeling away all quote forms." + (labels ((descend (form) + (cond ((typep form 'quote-form) + (descend (first-form (children form)))) + (t form)))) + (descend token))) + (defun this-form (mark-or-offset syntax) "Return a form at `mark-or-offset'. This function defines which forms the COM-FOO-this commands affect." @@ -2597,7 +2623,7 @@ (if (null (cdr path)) ;; top level (let* ((arglist (when (fboundp symbol) - (arglist-for-form symbol))) + (arglist-for-form syntax symbol))) (body-or-rest-pos (or (position '&body arglist) (position '&rest arglist)))) (if (and (or (macro-function symbol) @@ -2609,7 +2635,7 @@ ;; &body arg. (values (elt-noncomment (children tree) 1) 1) ;; non-&body-arg. - (values (elt-noncomment (children tree) 1) 3)) + (values (elt-noncomment (children tree) 1) 1)) ;; normal form. (if (= (car path) 2) ;; indent like first child @@ -2867,1222 +2893,3 @@
(defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2) (line-uncomment-region syntax mark1 mark2)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Swine - -;;; Compiler note hyperlinking code - -(defun make-compiler-note (note-list) - (let ((severity (getf note-list :severity)) - (message (getf note-list :message)) - (location (getf note-list :location)) - (references (getf note-list :references)) - (short-message (getf note-list :short-message))) - (make-instance - (ecase severity - (: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 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 compiler-notes.")) - -(defclass error-compiler-note (compiler-note) ()) - -(defclass read-error-compiler-note (compiler-note) ()) - -(defclass warning-compiler-note (compiler-note) ()) - -(defclass style-warning-compiler-note (compiler-note) ()) - -(defclass note-compiler-note (compiler-note) ()) - -(defclass location ()() - (:documentation "The base for all locations.")) - -(defclass error-location (location) - ((error-message :initarg :error-message :accessor error-message))) - -(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 locations.")) - -(defclass buffer-location (actual-location) - ((buffer-name :initarg :buffer :accessor buffer-name))) - -(defclass file-location (actual-location) - ((file-name :initarg :file :accessor file-name))) - -(defclass source-location (actual-location) - ((source-form :initarg :source-form :accessor source-form))) - -(defclass basic-position () () - (:documentation "The base for all positions.")) - -(defclass char-position (basic-position) - ((char-position :initarg :position :accessor char-position) - (align-p :initarg :align-p :initform nil :accessor align-p))) - -(defun make-char-position (position-list) - (make-instance 'char-position :position (second position-list) - :align-p (third position-list))) - -(defclass line-position (basic-position) - ((start-line :initarg :line :accessor start-line) - (end-line :initarg :end-line :initform nil :accessor end-line))) - -(defun make-line-position (position-list) - (make-instance 'line-position :line (second position-list) - :end-line (third position-list))) - -(defclass function-name-position (basic-position) - ((function-name :initarg :function-name))) - -(defun make-function-name-position (position-list) - (make-instance 'function-name-position :function-name (second position-list))) - -(defclass source-path-position (basic-position) - ((path :initarg :source-path :accessor path) - (start-position :initarg :start-position :accessor start-position))) - -(defun make-source-path-position (position-list) - (make-instance 'source-path-position :source-path (second position-list) - :start-position (third position-list))) - -(defclass text-anchored-position (basic-position) - ((start :initarg :text-anchored :accessor start) - (text :initarg :text :accessor text) - (delta :initarg :delta :accessor delta))) - -(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 method-position (basic-position) - ((name :initarg :method :accessor name) - (specializers :initarg :specializers :accessor specializers) - (qualifiers :initarg :qualifiers :accessor qualifiers))) - -(defun make-method-position (position-list) - (make-instance 'method-position :method (second position-list) - :specializers (third position-list) - :qualifiers (last position-list))) - -(defun make-location (location-list) - (ecase (first 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 'file-location) - (:buffer 'buffer-location) - (:source-form 'source-location)) - buf)) - (position - (funcall - (ecase (first pos) - (: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 compiler-note) &rest args) - (declare (ignore args)) - (setf (location note) (make-location (location note)))) - -(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 - (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 - (esa:display-message "Compilation finished: ~D error~:P ~ - ~D warning~:P ~D style-warning~:P ~D note~:P ~ - ~@[[~D secs]~]" - nerrors nwarnings nstyle-warnings nnotes seconds))) - -(defun one-line-ify (string) - "Return a single-line version of STRING. -Each newline and following whitespace is replaced by a single space." - (loop with count = 0 - while (< count (length string)) - with new-string = (make-array 0 :element-type 'character :adjustable t - :fill-pointer 0) - when (char= (char string count) #\Newline) - do (loop while (and (< count (length string)) - (whitespacep nil (char string count))) - do (incf count) - ;; Just ignore whitespace if it is last in the - ;; string. - finally (when (< count (length string)) - (vector-push-extend #\Space new-string))) - else - do (vector-push-extend (char string count) new-string) - (incf count) - finally (return new-string))) - -(defgeneric print-for-menu (object stream)) - -(defun print-note-for-menu (note stream severity ink)
[1033 lines skipped] --- /project/climacs/cvsroot/climacs/lisp-syntax-swank.lisp 2006/07/05 13:52:17 1.1 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swank.lisp 2006/08/20 13:10:31 1.2 @@ -47,7 +47,7 @@ (handler-case (asdf:oos 'asdf:load-op :swank) (asdf:missing-component () (esa:display-message "Swank not available."))))) - (setf (image (syntax (current-buffer))) + (setf (image (syntax (current-buffer *application-frame*))) (make-instance 'swank-local-image)))
(defmethod compile-string-for-climacs ((image swank-local-image) string package buffer buffer-mark) --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/08/11 21:59:05 1.15 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/08/20 13:10:31 1.16 @@ -88,13 +88,13 @@ (define-command (com-set-base :name t :command-table lisp-table) ((base '(integer 2 36))) "Set the base for the current buffer." - (setf (base (syntax (current-buffer))) + (setf (base (syntax (current-buffer *application-frame*))) base))
(define-command (com-set-package :name t :command-table lisp-table) ((package 'package)) "Set the package for the current buffer." - (setf (option-specified-package (syntax (current-buffer))) + (setf (option-specified-package (syntax (current-buffer *application-frame*))) package))
(define-command (com-indent-expression :name t :command-table lisp-table)
--- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/20 13:10:31 NONE +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/20 13:10:31 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-LISP-SYNTAX -*-
;;; (c) copyright 2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.
;;; Functionality designed to aid development of Common Lisp code.
(in-package :climacs-lisp-syntax)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Code interrogation/form analysis
(defparameter +cl-arglist-keywords+ lambda-list-keywords)
(defparameter +cl-garbage-keywords+ '(&whole &environment))
(defun arglist-keyword-p (arg) "Return T if `arg' is an arglist keyword. NIL otherwise." (when (member arg +cl-arglist-keywords+) t))
(defun split-arglist-on-keywords (arglist) "Return an alist keying lambda list keywords of `arglist' to the symbols affected by the keywords." (let ((sing-result '()) (env (position '&environment arglist))) (when env (push (list '&environment (elt arglist (1+ env))) sing-result) (setf arglist (remove-if (constantly t) arglist :start env :end (+ env 2)))) (when (eq '&whole (first arglist)) (push (subseq arglist 0 2) sing-result) (setf arglist (cddr arglist))) (do ((llk '(&mandatory &optional &key &allow-other-keys &aux &rest &body)) (args (if (arglist-keyword-p (first arglist)) arglist (cons '&mandatory arglist)) (cdr args)) (chunk '()) (result '())) ((null args) (when chunk (push (nreverse chunk) result)) (nreverse (nconc sing-result result))) (if (member (car args) llk) (progn (when chunk (push (nreverse chunk) result)) (setf chunk (list (car args)))) (push (car args) chunk)))))
(defun find-optional-argument-values (arglist provided-args &optional (split-arglist (split-arglist-on-keywords arglist))) "Return an association list mapping symbols of optional or keyword arguments from `arglist' to the specified values in `provided-args'. `Split-arglist' should be either a split arglist or nil, in which case it will be calculated from `arglist'." (flet ((get-args (keyword) (rest (assoc keyword split-arglist)))) (let* ((mandatory-args-count (length (get-args '&mandatory))) (optional-args-count (length (get-args '&optional))) (keyword-args-count (length (get-args '&key))) (provided-args-count (length provided-args)) (nonmandatory-args-count (+ keyword-args-count optional-args-count))) ;; First we check whether any optional arguments have even been ;; provided. (when (> provided-args-count mandatory-args-count) ;; We have optional arguments. (let ( ;; Find the part of the provided arguments that concern ;; optional arguments. (opt-args-values (subseq provided-args mandatory-args-count (min provided-args-count nonmandatory-args-count))) ;; Find the part of the provided arguments that concern ;; keyword arguments. (keyword-args-values (subseq provided-args (min (+ mandatory-args-count optional-args-count) provided-args-count)))) (append (mapcar #'cons (mapcar #'unlisted (get-args '&optional)) opt-args-values)
(loop ;; Loop over the provided keyword symbols and ;; values in the argument list. Note that ;; little checking is done to ensure that the ;; given symbols are valid - this is not a ;; compiler, so extra mappings do not ;; matter. for (keyword value) on keyword-args-values by #'cddr if (keywordp keyword) collect (let ((argument-symbol (unlisted (find (symbol-name keyword) (get-args '&key) :key #'(lambda (arg) (symbol-name (unlisted arg))) :test #'string=)))) ;; We have to find the associated ;; symbol in the argument list... ugly. (cons argument-symbol value)))))))))
(defun find-affected-simple-arguments (arglist current-arg-index preceding-arg &optional (split-arglist (split-arglist-on-keywords arglist))) "Find the simple arguments of `arglist' that would be affected if an argument was intered at index `current-arg-index' in the arglist. If `current-arg-index' is nil, no calculation will be done (this function will just return nil). `Preceding-arg' should either be nil or the argument directly preceding point. `Split-arglist' should either be a split arglist or nil, in which case `split-arglist' will be computed from `arglist'. This function returns two values: The primary value is a list of symbols that should be emphasized, the secondary value is a list of symbols that should be highlighted." (when current-arg-index (flet ((get-args (keyword) (rest (assoc keyword split-arglist)))) (let ((mandatory-argument-count (length (get-args '&mandatory)))) (cond ((> mandatory-argument-count current-arg-index) ;; We are in the main, mandatory, positional arguments. (let ((relevant-arg (elt (get-args '&mandatory) current-arg-index))) ;; We do not handle complex argument lists here, only ;; pure standard arguments. (unless (and (listp relevant-arg) (< current-arg-index mandatory-argument-count)) (values nil (list (unlisted relevant-arg)))))) ((> (+ (length (get-args '&optional)) (length (get-args '&mandatory))) current-arg-index) ;; We are in the &optional arguments. (values nil (list (unlisted (elt (get-args '&optional) (- current-arg-index (length (get-args '&mandatory)))))))) (t (let ((body-or-rest-args (or (get-args '&rest) (get-args '&body))) (key-arg (find (format nil "~A" preceding-arg) (get-args '&key) :test #'string= :key #'(lambda (arg) (symbol-name (unlisted arg)))))) ;; We are in the &body, &rest or &key arguments. (values ;; Only emphasize the &key ;; symbol if we are in a position to add a new ;; keyword-value pair, and not just in a position to ;; specify a value for a keyword. (when (and (null key-arg) (get-args '&key)) '(&key)) (append (when key-arg (list (unlisted key-arg))) body-or-rest-args)))))))))
(defun analyze-arglist-impl (arglist current-arg-indices preceding-arg provided-args) "The implementation for `analyze-arglist'." (let* ((split-arglist (split-arglist-on-keywords arglist)) (user-supplied-arg-values (find-optional-argument-values arglist provided-args split-arglist)) (mandatory-argument-count (length (rest (assoc '&mandatory split-arglist))))
(current-arg-index (or (first current-arg-indices) 0)) ret-arglist emphasized-symbols highlighted-symbols) ;; First, we find any standard arguments that should be ;; highlighted or emphasized, more complex, destructuring ;; arguments will be handled specially. (multiple-value-bind (es hs) (find-affected-simple-arguments arglist ;; If `current-arg-indices' is ;; nil, that means that we do ;; not have enough information ;; to properly highlight ;; symbols in the arglist. (and current-arg-indices current-arg-index) preceding-arg split-arglist) (setf emphasized-symbols es) (setf highlighted-symbols hs)) ;; We loop over the arglist and build a new list, and if we have a ;; default value for a given argument, we insert it into the ;; list. Also, whenever we encounter a list in a mandatory ;; argument position, we assume that it is a destructuring arglist ;; and recursively call `analyze-arglist' on it to find the ;; arglist and emphasized and highlighted symbols for it. (labels ((generate-arglist (arglist) (loop for arg-element in arglist for arg-name = (unlisted arg-element) for index from 0
if (and (listp arg-element) (> mandatory-argument-count index)) collect (multiple-value-bind (arglist sublist-emphasized-symbols sublist-highlighted-symbols) (analyze-arglist arg-element (rest current-arg-indices) preceding-arg (when (< index (length provided-args)) (listed (elt provided-args index)))) ;; Unless our `current-arg-index' ;; actually refers to this sublist, its ;; highlighted and emphasized symbols ;; are ignored. Also, if ;; `current-arg-indices' is nil, we do ;; not have enough information to ;; properly highlight symbols in the ;; arglist. (when (and current-arg-indices (= index current-arg-index)) (if (and (rest current-arg-indices)) (setf emphasized-symbols (union (mapcar #'unlisted sublist-emphasized-symbols) emphasized-symbols) highlighted-symbols (union sublist-highlighted-symbols highlighted-symbols)) (setf emphasized-symbols (union (mapcar #'unlisted arg-element) emphasized-symbols)))) arglist) else if (assoc arg-name user-supplied-arg-values) collect (list arg-name (rest (assoc arg-name user-supplied-arg-values))) else collect arg-element))) (setf ret-arglist (generate-arglist arglist))) (list ret-arglist emphasized-symbols highlighted-symbols)))
(defun analyze-arglist (arglist current-arg-indices preceding-arg provided-args) "Analyze argument list and provide information for highlighting it. `Arglist' is the argument list that is to be analyzed, `current-arg-index' is the index where the next argument would be written (0 is just after the operator), `preceding-arg' is the written argument preceding point and `provided-args' is a list of the args already written.
Three values are returned:
* An argument list with values for &optional and &key arguments inserted from `provided-args'.
* A list of symbols that should be emphasized.
* A list of symbols that should be highlighted." (apply #'values (analyze-arglist-impl arglist current-arg-indices preceding-arg provided-args)))
(defun cleanup-arglist (arglist) "Remove elements of `arglist' that we are not interested in." (loop for arg in arglist with in-&aux ; If non-NIL, we are in the ; &aux parameters that should ; not be displayed.
with in-garbage ; If non-NIL, the next ; argument is a garbage ; parameter that should not be ; displayed. if in-garbage do (setf in-garbage nil) else if (not in-&aux) if (eq arg '&aux) do (setf in-&aux t) else if (member arg +cl-garbage-keywords+ :test #'eq) do (setf in-garbage t) else collect arg))
(defgeneric arglist-for-form (syntax operator &optional arguments) (:documentation "Return an arglist for `operator'") (:method (syntax operator &optional arguments) (declare (ignore arguments)) (cleanup-arglist (arglist (get-usable-image syntax) operator))))
(defmethod arglist-for-form (syntax (operator list) &optional arguments) (declare (ignore arguments)) (case (first operator) ('cl:lambda (cleanup-arglist (second operator)))))
(defun find-argument-indices-for-operand (syntax operand-form operator-form) "Return a list of argument indices for `argument-form' relative to `operator-form'. These lists take the form of (n m p), which means (aref form-operand-list n m p). A list of argument indices can have arbitrary length (but they are practically always at most 2 elements long). " (declare (ignore syntax)) (let ((operator (first-form (children operator-form)))) (labels ((worker (operand-form &optional the-first) ;; Cannot find index for top-level-form. (when (parent operand-form) (let ((form-operand-list (remove-if #'(lambda (form) (or (not (typep form 'form)) (eq form operator))) (children (parent operand-form)))))
(let ((operand-position (position operand-form form-operand-list)) (go-on (not (eq operator-form (parent operand-form))))) ;; If we find anything, we have to increment the ;; position by 1, since we consider the existance ;; of a first operand to mean point is at operand ;; 2. Likewise, a position of nil is interpreted ;; as 0. (cons (if operand-position (if (or the-first) (1+ operand-position) operand-position) 0) (when go-on (worker (parent operand-form))))))))) (nreverse (worker operand-form t)))))
(defun find-operand-info (mark-or-offset syntax operator-form) "Returns two values: The operand preceding `mark-or-offset' and the path from `operator-form' to the operand." (as-offsets ((mark-or-offset offset)) (let* ((preceding-arg-token (form-before syntax offset)) (indexing-start-arg (let* ((candidate-before preceding-arg-token) (candidate-after (when (null candidate-before) (let ((after (form-after syntax offset))) (when after (parent after))))) (candidate-around (when (null candidate-after) (form-around syntax offset))) (candidate (or candidate-before candidate-after candidate-around))) (if (or (and candidate-before (typep candidate-before 'incomplete-list-form)) (and (null candidate-before) (typep (or candidate-after candidate-around) 'list-form))) ;; HACK: We should not attempt to find the location of
[971 lines skipped]