Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv1177
Modified Files: lisp-syntax.lisp lisp-syntax-swine.lisp lisp-syntax-commands.lisp climacs.asd Log Message: Added proof-of-concept group to the Lisp syntax, and abstracted away some of the type-checking to functions.
--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/11 20:13:32 1.114 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/12 17:24:56 1.115 @@ -1408,7 +1408,7 @@ end-offset)) (typep x 'complete-list-form)) (let ((candidate (first-form (children x)))) - (and (typep candidate 'token-mixin) + (and (form-token-p candidate) (eq (token-to-object syntax candidate :no-error t) 'cl:in-package))))))) @@ -1421,16 +1421,16 @@ (loop for (offset . nil) in (package-list syntax) unless (let ((form (form-around syntax offset))) - (and form (typep form 'complete-list-form))) + (form-list-p form)) do (return t)))))))
(defun update-package-list (buffer syntax) (declare (ignore buffer)) (setf (package-list syntax) nil) (flet ((test (x) - (when (typep x 'complete-list-form) + (when (form-list-p x) (let ((candidate (first-form (children x)))) - (and (typep candidate 'token-mixin) + (and (form-token-p candidate) (eq (token-to-object syntax candidate :no-error t) 'cl:in-package))))) @@ -1473,13 +1473,13 @@
(defun first-noncomment (list) "Returns the first non-comment in list." - (find-if-not #'(lambda (item) (typep item 'comment)) list)) + (find-if-not #'comment-p list))
(defun rest-noncomments (list) "Returns the remainder of the list after the first non-comment, stripping leading comments." (loop for rest on list - count (not (typep (car rest) 'comment)) + count (not (comment-p (car rest))) into forms until (= forms 2) finally (return rest))) @@ -1487,7 +1487,7 @@ (defun nth-noncomment (n list) "Returns the nth non-comment in list." (loop for item in list - count (not (typep item 'comment)) + count (not (comment-p item)) into forms until (> forms n) finally (return item))) @@ -1508,7 +1508,7 @@ "Returns the remainder of the list after the first form, stripping leading non-forms." (loop for rest on list - count (typep (car rest) 'form) + count (formp (car rest)) into forms until (= forms 2) finally (return rest))) @@ -1516,7 +1516,7 @@ (defun nth-form (n list) "Returns the nth form in list or `nil'." (loop for item in list - count (typep item 'form) + count (formp item) into forms until (> forms n) finally (when (> forms n) @@ -1538,26 +1538,21 @@ "Returns the third formw in list." (nth-form 2 list))
-(defgeneric form-operator (form syntax) - (:documentation "Return the operator of `form' as a Lisp -object. Returns nil if none can be found.") +(defgeneric form-operator (syntax form) + (:documentation "Return the operator of `form' as a + token. Returns nil if none can be found.") (:method (form syntax) nil))
-(defmethod form-operator ((form list-form) syntax) - (let* ((operator-token (first-form (rest (children form)))) - (operator-symbol (when operator-token - (token-to-object syntax operator-token :no-error t)))) - operator-symbol)) +(defmethod form-operator (syntax (form list-form)) + (first-form (rest (children form))))
-(defgeneric form-operands (form syntax) +(defgeneric form-operands (syntax form) (:documentation "Returns the operands of `form' as a list of - Lisp objects. Returns nil if none can be found.") + tokens. Returns nil if none can be found.") (:method (form syntax) nil))
-(defmethod form-operands ((form list-form) syntax) - (loop for operand in (rest-forms (children form)) - when (typep operand 'form) - collect (token-to-object syntax operand :no-error t))) +(defmethod form-operands (syntax (form list-form)) + (remove-if-not #'formp (rest-forms (children form))))
(defun form-toplevel (form syntax) "Return the top-level form of `form'." @@ -1565,15 +1560,15 @@ form (form-toplevel (parent form) syntax)))
-(defgeneric operator-p (token syntax) +(defgeneric form-operator-p (token syntax) (:documentation "Return true if `token' is the operator of its form. Otherwise, return nil.") (:method (token syntax) (with-accessors ((pre-token preceding-parse-tree)) token (cond ((typep pre-token 'left-parenthesis-lexeme) t) - ((typep pre-token 'comment) - (operator-p pre-token syntax)) + ((comment-p pre-token) + (form-operator-p pre-token syntax)) (t nil)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1604,9 +1599,9 @@ "unwrap" quote-forms in order to return the symbol token. If no symbol token can be found, NIL will be returned." (labels ((unwrap-form (form) - (cond ((typep form 'quote-form) + (cond ((form-quoted-p form) (unwrap-form (first-form (children form)))) - ((typep form 'complete-token-lexeme) + ((form-token-p form) form)))) (unwrap-form (expression-at-mark mark-or-offset syntax))))
@@ -1614,7 +1609,7 @@ "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) + (cond ((form-quoted-p (parent form)) (ascend (parent form))) (t form)))) (ascend token))) @@ -1623,7 +1618,7 @@ "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) + (cond ((form-quoted-p form) (descend (first-form (children form)))) (t form)))) (descend token))) @@ -1660,6 +1655,32 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Querying forms for data + +(defmacro define-form-predicate (name (&rest t-classes) &optional documentation) + "Define a generic function named `name', taking a single + argument. A default method that returns NIL will be defined, + and methods returning T will be defined for all classes in + `t-classes'." + `(progn + (defgeneric ,name (form) + (:documentation ,(or documentation "Check `form' for something.")) + (:method (form) nil)) + ,@(loop for class in t-classes collecting + `(defmethod ,name ((form ,class)) + t)))) + +(define-form-predicate formp (form)) +(define-form-predicate form-list-p (complete-list-form incomplete-list-form)) +(define-form-predicate form-incomplete-p (incomplete-form-mixin)) +(define-form-predicate form-token-p (token-mixin)) +(define-form-predicate form-string-p (string-form)) +(define-form-predicate form-quoted-p (quote-form backquote-form)) + +(define-form-predicate comment-p (comment)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Useful functions for modifying forms based on the mark.
(defun replace-symbol-at-mark (mark syntax string) @@ -1792,11 +1813,11 @@ (with-face (:lambda-list-keyword) (call-next-method))) ((and (macro-function symbol) - (operator-p parse-symbol syntax)) + (form-operator-p parse-symbol syntax)) (with-face (:macro) (call-next-method))) ((and (special-operator-p symbol) - (operator-p parse-symbol syntax)) + (form-operator-p parse-symbol syntax)) (with-face (:special-form) (call-next-method))) (t (call-next-method)))))) @@ -1910,7 +1931,7 @@ (nthcdr 2 (remove-if - #'(lambda (child) (typep child 'comment)) + #'comment-p children)))) (type-string (token-string syntax type)) (type-symbol (parse-symbol type-string :package +keyword-package+))) @@ -1971,7 +1992,7 @@
(defun form-before-in-children (children offset) (loop for (first . rest) on children - if (typep first 'form) + if (formp first) do (cond ((< (start-offset first) offset (end-offset first)) (return (if (null (children first)) @@ -1981,14 +2002,14 @@ (or (null (first-form rest)) (<= offset (start-offset (first-form rest))))) (return (let ((potential-form - (when (typep first 'list-form) + (when (form-list-p first) (form-before-in-children (children first) offset)))) (if (not (null potential-form)) (if (<= (end-offset first) (end-offset potential-form)) potential-form first) - (when (typep first 'form) + (when (formp first) first))))) (t nil)))) @@ -2001,7 +2022,7 @@
(defun form-after-in-children (children offset) (loop for child in children - if (typep child 'form) + if (formp child) do (cond ((< (start-offset child) offset (end-offset child)) (return (if (null (children child)) nil @@ -2013,7 +2034,7 @@ (start-offset potential-form)) child potential-form) - (when (typep child 'form) + (when (formp child) child))))) (t nil)))) @@ -2026,15 +2047,15 @@ (defun form-around-in-children (children offset) (loop for child in children - if (typep child 'form) + if (formp child) do (cond ((or (<= (start-offset child) offset (end-offset child)) (= offset (end-offset child)) (= offset (start-offset child))) (return (if (null (first-form (children child))) - (when (typep child 'form) + (when (formp child) child) (or (form-around-in-children (children child) offset) - (when (typep child 'form) + (when (formp child) child))))) ((< offset (start-offset child)) (return nil)) @@ -2054,7 +2075,7 @@ that returns an offset when applied to a token (eg. `start-offset' or `end-offset'). If a list parent cannot be found, return `fn' applied to `form'." - (when (not (typep form 'form*)) + (when (not (formp form)) (let ((parent (parent form))) (typecase parent (form* (funcall fn form)) @@ -2070,7 +2091,7 @@ be found, return nil." (labels ((has-list-child (form) (some #'(lambda (child) - (if (and (typep child 'list-form) + (if (and (form-list-p child) (>= (start-offset child) min-offset)) child @@ -2108,7 +2129,7 @@ (and (= start (end-offset potential-form)) (null (form-after syntax start)))) - when (typep potential-form 'list-form) + when (form-list-p potential-form) do (setf (offset mark) (end-offset potential-form)) (return t)))
@@ -2126,7 +2147,7 @@ (and (= start (start-offset potential-form)) (null (form-before syntax start)))) - when (typep potential-form 'list-form) + when (form-list-p potential-form) do (setf (offset mark) (start-offset potential-form)) (return t)))
@@ -2182,14 +2203,14 @@ (with-slots (stack-top) syntax (loop for form in (children stack-top) with last-toplevel-list = nil - when (and (typep form 'form) + when (and (formp form) (mark< mark (end-offset form))) do (if (mark< (start-offset form) mark) (setf (offset mark) (start-offset form)) (when last-toplevel-list form (setf (offset mark) (start-offset last-toplevel-list)))) (return t) - when (typep form 'form) + when (formp form) do (setf last-toplevel-list form) finally (when last-toplevel-list form (setf (offset mark) @@ -2199,7 +2220,7 @@ (defmethod forward-one-definition (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax (loop for form in (children stack-top) - when (and (typep form 'form) + when (and (formp form) (mark< mark (end-offset form))) do (setf (offset mark) (end-offset form)) (loop-finish) @@ -2441,7 +2462,7 @@ if (typep child 'comma-at-form) ;; How should we handle this? collect (apply #'token-to-object syntax child args) - else if (typep child 'form) + else if (formp child) collect (apply #'token-to-object syntax child args)))
(defmethod token-to-object (syntax (token simple-vector-form) &key) @@ -2466,7 +2487,7 @@ ;; convenience function. (defmethod token-to-object (syntax (token backquote-form) &rest args) (let ((backquoted-form (first-form (children token)))) - (if (typep backquoted-form 'list-form) + (if (form-list-p backquoted-form) `'(,@(apply #'token-to-object syntax backquoted-form args)) `',(apply #'token-to-object syntax backquoted-form args))))
@@ -2485,7 +2506,7 @@
(defmethod token-to-object (syntax (token cons-cell-form) &key) (let ((components (remove-if #'(lambda (token) - (not (typep token 'form))) + (not (formp token))) (children token)))) (if (<= (length components) 2) (cons (token-to-object syntax (first components)) @@ -2548,7 +2569,7 @@ ;; before first element (values tree 1) (let ((first-child (elt-noncomment (children tree) 1))) - (cond ((and (typep first-child 'token-mixin) + (cond ((and (form-token-p first-child) (token-to-object syntax first-child)) (compute-list-indentation syntax (token-to-object syntax first-child) tree path)) ((null (cdr path)) @@ -2730,9 +2751,8 @@
(defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'defmethod)) tree path) - (let ((lambda-list-pos (position-if (lambda (x) (typep x 'list-form)) - (remove-if - (lambda (x) (typep x 'comment)) (children tree))))) + (let ((lambda-list-pos (position-if #'form-list-p + (remove-if #'comment-p (children tree))))) (cond ((null (cdr path)) ;; top level (values tree (if (or (null lambda-list-pos) @@ -2792,7 +2812,7 @@ ;; the symbol existing in the current image. (Arguably, too, ;; this is a broken indentation form because it doesn't carry ;; over to the implicit tagbodies in macros such as DO. - (if (typep (elt-noncomment (children tree) (car path)) 'token-mixin) + (if (form-token-p (elt-noncomment (children tree) (car path))) (values tree 2) (values tree 4)) (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) @@ -2884,3 +2904,18 @@
(defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2)
[17 lines skipped] --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/11 20:13:32 1.6 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/12 17:24:56 1.7 @@ -349,7 +349,7 @@ (when (parent operand-form) (let ((form-operand-list (remove-if #'(lambda (form) - (or (not (typep form 'form)) + (or (not (formp form)) (eq form operator))) (children (parent operand-form)))))
@@ -388,8 +388,7 @@ (if (or (and candidate-before (typep candidate-before 'incomplete-list-form)) (and (null candidate-before) - (typep (or candidate-after candidate-around) - 'list-form))) + (form-list-p (or candidate-after candidate-around)))) ;; 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 @@ -689,7 +688,7 @@ ((listp argument) `(((= (first indices) ,index) ,(if (eq (first argument) 'quote) - `(cond ((typep token 'quote-form) + `(cond ((form-quoted-p token) (complete-argument-of-type ',(second argument) syntax token all-completions)) (t (call-next-method))) `(cond ((not (null (rest indices))) @@ -757,8 +756,10 @@ (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking ;; up any of this stuff. - (,operator-sym (when ,form-sym (form-operator ,form-sym ,syntax))) - (,operands-sym (when ,form-sym (form-operands ,form-sym ,syntax)))) + (,operator-sym (when ,form-sym (token-to-object ,syntax (form-operator ,syntax ,form-sym)))) + (,operands-sym (when ,form-sym (mapcar #'(lambda (operand) + (token-to-object ,syntax operand)) + (form-operands ,syntax ,form-sym))))) (declare (ignorable ,form-sym ,operator-sym ,operands-sym)) (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) (when ,form-sym (find-operand-info ,syntax ,mark-or-offset ,form-sym)) @@ -1394,7 +1395,7 @@ displayed. If no symbol can be found at `mark', return nil." (let ((token (form-around syntax (offset mark)))) (when (and (not (null token)) - (typep token 'complete-token-lexeme) + (form-token-p token) (not (= (start-offset token) (offset mark)))) (multiple-value-bind (longest completions) --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/08/20 13:10:31 1.16 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/09/12 17:24:56 1.17 @@ -69,7 +69,7 @@ (token (form-around syntax (offset (point pane)))) (fill-column (auto-fill-column pane)) (tab-width (tab-space-count (stream-default-view pane)))) - (when (typep token 'string-form) + (when (form-string-p token) (with-accessors ((offset1 start-offset) (offset2 end-offset)) token (climacs-core:fill-region (make-instance 'standard-right-sticky-mark @@ -227,7 +227,7 @@ (syntax (syntax buffer)) (mark (point pane)) (token (this-form mark syntax))) - (if (and token (typep token 'complete-token-lexeme)) + (if (and token (form-token-p token)) (com-lookup-arglist (token-to-object syntax token)) (esa:display-message "Could not find symbol at point."))))
--- /project/climacs/cvsroot/climacs/climacs.asd 2006/09/11 20:13:32 1.55 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/09/12 17:24:56 1.56 @@ -85,7 +85,7 @@ (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) (:file "lisp-syntax" :depends-on ("packages" "utils" "syntax" "buffer" "base" "pane" - "window-commands" "gui")) + "window-commands" "gui" "groups")) (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "motion-commands" "editing-commands" "misc-commands"))