[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Sun Aug 20 13:10:31 UTC 2006
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)))
, at 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 at labri.fr)
;;; (c) copyright 2006 by
;;; Troels Henriksen (athas at 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]
More information about the Climacs-cvs
mailing list