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

Modified Files: swine.lisp Log Message: Added code to handle the case where `current-arg-indices' is NIL.

--- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/05/28 13:37:46 1.11 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/05/28 16:28:42 1.12 @@ -479,54 +479,56 @@ &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. `Preceding-arg-key' 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." - (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)))))))) + 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'." @@ -537,7 +539,9 @@ split-arglist)) (mandatory-argument-count (length (rest (assoc '&mandatory split-arglist)))) - (current-arg-index (or (first current-arg-indices) 0)) + + (current-arg-index (or (first current-arg-indices) + 0)) ret-arglist emphasized-symbols highlighted-symbols) @@ -546,18 +550,23 @@ ;; arguments will be handled specially. (multiple-value-bind (es hs) (find-affected-simple-arguments arglist - current-arg-index + ;; 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 calls `analyze-arglist' on it - ;; to find the arglist and emphasized and highlighted symbols for - ;; it. + ;; 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 calls `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 @@ -589,10 +598,16 @@ 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. - (if (= index current-arg-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, that + ;; means that 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