Commit 6ff394dc authored by Troels Henriksen's avatar Troels Henriksen
Browse files

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.
parent ed18b495
......@@ -88,13 +88,13 @@ string at point."
(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)
......
......@@ -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)
......
;;; -*- 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
;; the list form itself, so we create a new parser
;; symbol, attach the list form as a parent and try to
;; find the new symbol. That way we can get a list of
;; argument-indices to the first element of the list
;; form, even if it is empty or incomplete.
(let ((obj (make-instance 'parser-symbol)))
(setf (parent obj) candidate)
obj)
candidate)))
(argument-indices (find-argument-indices-for-operand
syntax
indexing-start-arg
operator-form))
(preceding-arg-obj (when preceding-arg-token
(token-to-object syntax preceding-arg-token
:no-error t))))
(values preceding-arg-obj argument-indices))))
(defun valid-operator-p (operator)
"Check whether or not `operator' is a valid
operator. `Operator' is considered a valid operator if it is a
symbol bound to a function, or if it is a lambda expression."
(cond ((symbolp operator)
(or (fboundp operator)
(macro-function operator)
(special-operator-p operator)))
((listp operator)
(eq (first operator) 'cl:lambda))))
(defun indices-match-arglist (arglist arg-indices)
"Check whether the argument indices `arg-indices' could refer
to a direct argument for the operator with the argument list
`arglist'. Returns T if they could, NIL otherwise. This
functions does not care about the argument quantity, only their
structure."
(let* ((index (first arg-indices))
(pure-arglist (remove-if #'arglist-keyword-p arglist))
(arg (when (< index (length pure-arglist))
(elt pure-arglist index))))
(cond ((or (and (>= index (or (position-if #'arglist-keyword-p arglist)
(1+ index)))
(not (null (rest arg-indices))))
(and (not (null (rest arg-indices)))
(> (length pure-arglist)
index)
(not (listp (elt pure-arglist index)))))
nil)
((and (not (null arg))
(listp arg)
(rest arg-indices))
(indices-match-arglist arg (rest arg-indices)))
(t t))))
(defun direct-arg-p (form syntax)
"Check whether `form' is a direct argument to one of its
parents."
(labels ((recurse (parent)
(let ((operator (form-operator
parent
syntax)))
(or (and
;; An operator is not an argument to itself...
(not (= (start-offset form)
(start-offset (first-form (children parent)))))
(valid-operator-p operator)
(indices-match-arglist
(arglist (image syntax)
operator)
(second
(multiple-value-list
(find-operand-info
(start-offset form)
syntax
parent)))))
(when (parent parent)
(recurse (parent parent)))))))
(when (parent form)
(recurse (parent form)))))
(defun relevant-keywords (arglist arg-indices)
"Return a list of the keyword arguments that it would make
sense to use at the position `arg-indices' relative to the
operator that has the argument list `arglist'."
(let* ((key-position (position '&key arglist))
(rest-position (position '&rest arglist))
(cleaned-arglist (remove-if #'arglist-keyword-p
arglist))
(index (first arg-indices))
(difference (+ (- (length arglist)
(length cleaned-arglist))
(if rest-position 1 0))))
(cond ((and (null key-position)
(rest arg-indices)
(> (length cleaned-arglist)
index)
(listp (elt cleaned-arglist index)))
;; Look in a nested argument list.
(relevant-keywords (elt cleaned-arglist index)
(rest arg-indices)))
((and (not (null key-position))
(>= (+ index
difference)
key-position)
(evenp (- index (- key-position
(1- difference)))))
(mapcar #'unlisted (subseq cleaned-arglist
(+ (- key-position
difference)
(if rest-position 2 1))))))))
(defgeneric possible-completions (syntax operator token operands indices)
(:documentation "Get the applicable completions for completing
`token' (which should be a token-lexeme), which is part of a
form with the operator `operator' (which should be a valid
operator object), and which has the operands
`operands'. `Indices' should be the argument indices from the
operator to `token' (see
`find-argument-indices-for-operands').")
(:method :around (syntax operator token operands indices)
(declare (ignore syntax operator token operands indices))
(with-syntax-package (syntax (start-offset token))
(call-next-method)))
(:method (syntax operator token operands indices)
(let ((completions (first (simple-completions (get-usable-image syntax)
(token-string syntax (fully-unquoted-form token))
(package-at-mark syntax (start-offset token))))))
(or (when (valid-operator-p operator)
(let* ((relevant-keywords
(relevant-keywords (arglist-for-form syntax operator operands) indices))
(relevant-completions
(remove-if-not #'(lambda (compl)
(member compl relevant-keywords
:test #'(lambda (a b)
(string-equal a b
:start1 1))
:key #'symbol-name))
(mapcar #'string-downcase completions))))
relevant-completions))
completions))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defgeneric code-for-argument-type-completion (argument-type syntax-symbol token-symbol all-completions-symbol)
(:documentation "Generate completion code for an argument of
type `argument-type'.")
(:method (argument-type syntax-symbol token-symbol all-completions-symbol)
'(call-next-method)))
(defgeneric code-for-argument-list-modification (argument-type syntax-symbol arglist-symbol arguments-symbol)
(:documentation "Generate argument list modification code for
a form having an argument of type `argument-type'.")
(:method (argument-type syntax-symbol arglist-symbol arguments-symbol)))
(defmacro define-argument-type (name (&optional inherit-from)
&rest options)
(let ((completion-code (rest (assoc :completion options)))
(modification-code (rest (assoc :arglist-modification options))))
`(progn
,(if (or completion-code inherit-from)
`(defmethod code-for-argument-type-completion ((argument-type (eql ',name))
,@(if completion-code
(first completion-code)
'(syntax token)))
,(if completion-code
`'(let ((,(third (first completion-code))
(call-next-method)))
,@(rest completion-code))
(code-for-argument-type-completion inherit-from 'syntax 'token 'all-completions)))
(let ((method (find-method #'code-for-argument-type-completion nil `((eql ,name) t t t) nil)))
(when method
(remove-method #'code-for-argument-type-completion method))))
,(if (or modification-code inherit-from)
`(defmethod code-for-argument-list-modification ((argument-type (eql ',name))
,@(if modification-code
(first modification-code)
'(syntax arglist arguments)))
,(if modification-code
`'(progn ,@(rest modification-code))
`',(code-for-argument-list-modification inherit-from 'syntax 'arglist 'arguments)))
(let ((method (find-method #'code-for-argument-list-modification nil `((eql ,name) t t t) nil)))
(when method
(remove-method #'code-for-argument-list-modification method)))))))
(define-argument-type class-name ()
(:completion (syntax token all-completions)
(loop for completion in all-completions
when (find-class (ignore-errors (read-from-string (string-upcase completion)))
nil)
collect completion))
(:arglist-modification (syntax arglist arguments)
(if (and (plusp (length arguments))
(listp (first arguments))
(> (length (first arguments)) 1)
(eq (caar arguments) 'cl:quote))
(nconc arglist
(cons '&key (get-class-keyword-parameters
(get-usable-image syntax)
(first arguments)))))))
(define-argument-type package-designator ()