September 2006 - climacs-cvs@common-lisp.net

[climacs-cvs] CVS climacs
by thenriksen 16 Sep '06

16 Sep '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv881 Modified Files: lisp-syntax.lisp lisp-syntax-swine.lisp Log Message: Even more fixes regarding handling of quoted forms (now works I think). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/16 10:30:37 1.117 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/16 12:11:11 1.118 @@ -2025,8 +2025,7 @@ (loop for (first . rest) on children if (formp first) do - (cond ((and (< (start-offset first) offset) - (<= offset (end-offset first))) + (cond ((< (start-offset first) offset (end-offset first)) (return (if (null (children first)) nil (form-before-in-children (children first) offset)))) @@ -2034,8 +2033,12 @@ (or (null (first-form rest)) (<= offset (start-offset (first-form rest))))) (return (let ((potential-form - (when (form-list-p first) - (form-before-in-children (children first) offset)))) + (cond ((form-list-p first) + (form-before-in-children (children first) offset)) + ((and (form-quoted-p first) + (not (form-incomplete-p first)) + (form-list-p (second (children first)))) + (form-before-in-children (children (second (children first))) offset))))) (if (not (null potential-form)) (if (<= (end-offset first) (end-offset potential-form)) --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/16 10:30:37 1.10 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/16 12:11:12 1.11 @@ -493,13 +493,14 @@ ;; nested/destructuring argument lists such as those found in ;; macros. (labels ((recurse (candidate-form) - (when (parent candidate-form) - (if (and (direct-arg-p syntax (first-form (children candidate-form)) - arg-form) - (not (find-applicable-form syntax (first-form (children candidate-form))))) - candidate-form + (if (and (direct-arg-p syntax (first-form (children candidate-form)) + arg-form) + (not (find-applicable-form syntax (first-form (children candidate-form))))) + candidate-form + (unless (form-at-top-level-p candidate-form) (recurse (parent candidate-form)))))) - (recurse (parent arg-form)))) + (unless (form-at-top-level-p arg-form) + (recurse (parent arg-form))))) (defun relevant-keywords (arglist arg-indices) "Return a list of the keyword arguments that it would make @@ -770,7 +771,8 @@ ;; If nothing else can be found, and `arg-form' ;; is the operator of its enclosing form, we use ;; the enclosing form. - (when (eq (first-form (children (parent immediate-form))) immediate-form) + (when (and (not (form-at-top-level-p immediate-form)) + (eq (first-form (children (parent immediate-form))) immediate-form)) (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking ;; up any of this stuff.

1 0

[climacs-cvs] CVS climacs
by thenriksen 16 Sep '06

16 Sep '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv11885 Modified Files: lisp-syntax.lisp lisp-syntax-swine.lisp Log Message: More fixes regarding handling of quoted forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/15 22:34:24 1.116 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/16 10:30:37 1.117 @@ -1565,6 +1565,12 @@ (defmethod form-operator (syntax (form list-form)) (first-form (rest (children form)))) +(defmethod form-operator (syntax (form complete-quote-form)) + (first-form (rest (children (second (children form)))))) + +(defmethod form-operator (syntax (form complete-backquote-form)) + (first-form (rest (children (second (children form)))))) + (defgeneric form-operands (syntax form) (:documentation "Returns the operands of `form' as a list of tokens. Returns nil if none can be found.") @@ -1698,6 +1704,12 @@ (define-form-predicate comment-p (comment)) +(defgeneric form-at-top-level-p (form) + (:documentation "Return NIL if `form' is not a top-level-form, + T otherwise.") + (:method ((form t)) + (typep (parent form) 'form*))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Useful functions for modifying forms based on the mark. @@ -2013,7 +2025,8 @@ (loop for (first . rest) on children if (formp first) do - (cond ((< (start-offset first) offset (end-offset first)) + (cond ((and (< (start-offset first) offset) + (<= offset (end-offset first))) (return (if (null (children first)) nil (form-before-in-children (children first) offset)))) --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/15 22:34:24 1.9 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/16 10:30:37 1.10 @@ -1424,7 +1424,8 @@ (funcall fn syntax (if useful-token (start-offset (fully-quoted-form token)) - (if (form-quoted-p token) + (if (and (form-quoted-p token) + (form-incomplete-p token)) (start-offset token) (offset mark))) (if useful-token

1 0

[climacs-cvs] CVS climacs
by thenriksen 15 Sep '06

15 Sep '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7529 Modified Files: utils.lisp packages.lisp lisp-syntax.lisp lisp-syntax-swine.lisp Log Message: Added new utility function (`list-aref'), added Lisp parser recognition of incomplete quote forms, added support for "blank" completion in Lisp syntax, so you no longer need to complete from a symbol, but can get a list of all (applicable) completions. Is very, very slow when listing all possible symbols due to the "slow" McCLIM menu implementation. --- /project/climacs/cvsroot/climacs/utils.lisp 2006/09/11 20:13:32 1.1 +++ /project/climacs/cvsroot/climacs/utils.lisp 2006/09/15 22:34:24 1.2 @@ -48,4 +48,10 @@ (defun listed (obj) (if (listp obj) obj - (list obj))) \ No newline at end of file + (list obj))) + +(defun list-aref (list &rest subscripts) + (if subscripts + (apply #'list-aref (nth (first subscripts) list) + (rest subscripts)) + list)) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/12 19:49:18 1.119 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/15 22:34:24 1.120 @@ -32,7 +32,8 @@ #:once-only #:unlisted #:fully-unlisted - #:listed)) + #:listed + #:list-aref)) (defpackage :climacs-buffer (:use :clim-lisp :flexichain :binseq) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/12 17:24:56 1.115 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/15 22:34:24 1.116 @@ -981,7 +981,7 @@ ;;; parse trees (defclass token-form (form token-mixin) ()) (defclass complete-token-form (token-form) ()) -(defclass incomplete-token-form (token-form) ()) +(defclass incomplete-token-form (token-form incomplete-form-mixin) ()) (define-parser-state | m-e-start text* | (lexer-escaped-token-state parser-state) ()) (define-parser-state | m-e-start text* m-e-end | (lexer-toplevel-state parser-state) ()) @@ -1002,6 +1002,8 @@ ;;; parse trees (defclass quote-form (form) ()) +(defclass complete-quote-form (quote-form) ()) +(defclass incomplete-quote-form (quote-form incomplete-form-mixin) ()) (define-parser-state |' | (form-may-follow) ()) (define-parser-state |' form | (lexer-toplevel-state parser-state) ()) @@ -1009,16 +1011,25 @@ (define-new-lisp-state (form-may-follow quote-lexeme) |' |) (define-new-lisp-state (|' | form) |' form |) (define-new-lisp-state (|' | comment) |' |) - +(define-new-lisp-state (|' | unmatched-right-parenthesis-lexeme) |( form* ) |) ;;; reduce according to the rule form -> ' form (define-lisp-action (|' form | t) - (reduce-until-type quote-form quote-lexeme)) + (reduce-until-type complete-quote-form quote-lexeme)) + +(define-lisp-action (|' | right-parenthesis-lexeme) + (reduce-until-type incomplete-quote-form quote-lexeme)) +(define-lisp-action (|' | unmatched-right-parenthesis-lexeme) + (reduce-until-type incomplete-quote-form quote-lexeme)) +(define-lisp-action (|' | (eql nil)) + (reduce-until-type incomplete-quote-form quote-lexeme)) ;;;;;;;;;;;;;;;; Backquote ;;; parse trees (defclass backquote-form (form) ()) +(defclass complete-backquote-form (backquote-form) ()) +(defclass incomplete-backquote-form (backquote-form incomplete-form-mixin) ()) (define-parser-state |` | (form-may-follow) ()) (define-parser-state |` form | (lexer-toplevel-state parser-state) ()) @@ -1026,10 +1037,18 @@ (define-new-lisp-state (form-may-follow backquote-lexeme) |` |) (define-new-lisp-state (|` | form) |` form |) (define-new-lisp-state (|` | comment) |` |) +(define-new-lisp-state (|` | unmatched-right-parenthesis-lexeme) |( form* ) |) ;;; reduce according to the rule form -> ` form (define-lisp-action (|` form | t) - (reduce-until-type backquote-form backquote-lexeme)) + (reduce-until-type complete-backquote-form backquote-lexeme)) + +(define-lisp-action (|` | right-parenthesis-lexeme) + (reduce-until-type incomplete-backquote-form backquote-lexeme)) +(define-lisp-action (|` | unmatched-right-parenthesis-lexeme) + (reduce-until-type incomplete-backquote-form backquote-lexeme)) +(define-lisp-action (|` | (eql nil)) + (reduce-until-type incomplete-backquote-form backquote-lexeme)) ;;;;;;;;;;;;;;;; Comma @@ -2412,7 +2431,7 @@ incomplete tokens. This function may signal an error if `no-error' is nil and `token' cannot be converted to a Lisp object. Otherwise, nil will be returned.") - (:method :around (syntax token &rest args &key no-error package quote read) + (:method :around (syntax (token t) &rest args &key no-error package quote read) ;; Ensure that every symbol that is READ will be looked up ;; in the correct package. Also handle quoting. (flet ((act () @@ -2479,9 +2498,14 @@ (declare (ignore no-error)) (read-from-string (token-string syntax token))) -(defmethod token-to-object (syntax (token quote-form) &rest args) +(defmethod token-to-object (syntax (token complete-quote-form) &rest args) (apply #'token-to-object syntax (second (children token)) :quote t args)) +(defmethod token-to-object (syntax (token incomplete-quote-form) &rest args) + (declare (ignore args)) + ;; Utterly arbitrary, but reasonable in my opinion. + '(quote)) + ;; I'm not sure backquotes are handled correctly, but then again, ;; `token-to-object' is not meant to be a perfect Lisp reader, only a ;; convenience function. --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/12 19:49:18 1.8 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/15 22:34:24 1.9 @@ -339,9 +339,9 @@ (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). " + means (list-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) @@ -482,15 +482,16 @@ argument. Return NIL if none can be found." ;; The algorithm for finding the applicable form: ;; - ;; From `arg-form', we wander up the tree looking enclosing forms, - ;; until we find a a form with an operator, the form-operator, that - ;; has `arg-form' as a direct argument (this is checked by comparing - ;; argument indices for `arg-form', relative to form-operator, with - ;; the arglist ofform-operator). However, if form-operator itself is - ;; a direct argument to one of its parents, we ignore it (unless - ;; form-operators form-operator is itself a direct argument, - ;; etc). This is so we can properly handle nested/destructuring - ;; argument lists such as those found in macros. + ;; From `arg-form', we wander up the tree looking at enclosing + ;; forms, until we find a a form with an operator, the + ;; form-operator, that has `arg-form' as a direct argument (this is + ;; checked by comparing argument indices for `arg-form', relative to + ;; form-operator, with the arglist ofform-operator). However, if + ;; form-operator itself is a direct argument to one of its parents, + ;; we ignore it (unless form-operators form-operator is itself a + ;; direct argument, etc). This is so we can properly handle + ;; nested/destructuring argument lists such as those found in + ;; macros. (labels ((recurse (candidate-form) (when (parent candidate-form) (if (and (direct-arg-p syntax (first-form (children candidate-form)) @@ -531,40 +532,48 @@ difference) (if rest-position 2 1)))))))) -(defgeneric possible-completions (syntax operator token operands indices) +(defgeneric possible-completions (syntax operator string package 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) +`string' (which should a string of the, possibly partial, symbol +name to be completed) in `package', 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 (syntax operator string package 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)))))) + string package)))) + ;; Welcome to the ugly mess! Part of the uglyness is that we + ;; depend on Swank do to our nonobvious completion (m-v-b -> + ;; multiple-value-bind). (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 #'(lambda (s) - (symbol-name (fully-unlisted s))))) - (mapcar #'string-downcase completions)))) - relevant-completions)) + (keyword-completions (mapcar #'(lambda (a) + (string-downcase (format nil ":~A" a))) + relevant-keywords))) + (when relevant-keywords + ;; We need Swank to get the concrete list of + ;; possibilities, but after that, we need to filter + ;; out anything that is not a relevant keyword + ;; argument. ALSO, if `string' is blank, Swank will + ;; "helpfully" not put any keyword symbols in + ;; `completions', thus ruining this entire scheme. SO, + ;; we have to force Swank to give us a list of keyword + ;; symbols and use that instead of `completions'. Joy! + (intersection (mapcar #'string-downcase + (if (string= string "") + (first (simple-completions (get-usable-image syntax) + ":" package)) + completions)) + keyword-completions + :key #'string-downcase + :test #'string=)))) completions)))) -(defgeneric complete-argument-of-type (argument-type syntax token all-completions) +(defgeneric complete-argument-of-type (argument-type syntax string all-completions) (:documentation "") - (:method (argument-type syntax token all-completions) + (:method (argument-type syntax string all-completions) all-completions)) (defgeneric modify-argument-list (argument-type syntax arglist arguments arg-position) @@ -612,11 +621,14 @@ (remove-method #'modify-argument-list 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 completion)) - nil) - collect completion)) + (:completion (syntax string all-completions) + (let ((all-lower (every #'lower-case-p string))) + (loop for completion in all-completions + when (find-class (ignore-errors (read-from-string completion)) + nil) + collect (if all-lower + (string-downcase completion) + completion)))) (:arglist-modification (syntax arglist arguments arg-position) (if (and (> (length arguments) arg-position) (listp (elt arguments arg-position)) @@ -630,10 +642,11 @@ arglist))) (define-argument-type package-designator () - (:completion (syntax token all-completions) + (:completion (syntax string all-completions) (declare (ignore all-completions)) - (let* ((string (token-string syntax token)) - (keyworded (char= (aref string 0) #\:))) + (let ((keyworded (and (plusp (length string)) + (char= (aref string 0) #\:))) + (all-upper (every #'upper-case-p string))) (loop for package in (list-all-packages) for package-name = (if keyworded (concatenate 'string ":" (package-name package)) @@ -642,7 +655,7 @@ :test #'char-equal :end2 (min (length string) (length package-name))) - collect (if (every #'upper-case-p string) + collect (if all-upper package-name (string-downcase package-name)))))) @@ -666,48 +679,53 @@ ;; FIXME: This macro should also define indentation rules. (labels ((process-keyword-arg-descs (arguments) ;; We expect `arguments' to be a plist mapping keyword - ;; symbols to type/class designators/names. We use a - ;; `case' form to map from the keyword preceding the - ;; symbol to be completed, to the code that generates the - ;; possible completions. + ;; symbols to type/class designators/names. `((t - (let* ((keyword (token-to-object syntax (form-before syntax (1- (start-offset token))))) + (let* ((keyword-indices (loop + for (car . cdr) on indices + if (null cdr) + collect (1+ car) + else collect car)) + (keyword (apply #'list-aref operands keyword-indices)) (type (getf ',arguments keyword))) (if (null type) (call-next-method) - (complete-argument-of-type type syntax token all-completions)))))) + (complete-argument-of-type type syntax string all-completions)))))) (process-arg-descs (arguments index) (let ((argument (first arguments))) - (cond ((null arguments) + (cond ((null argument) nil) ((eq argument '&rest) `(((>= (first indices) ,index) - (complete-argument-of-type ',(second arguments) syntax token all-completions)))) + (complete-argument-of-type ',(second arguments) syntax string all-completions)))) ((eq argument '&key) (process-keyword-arg-descs (rest arguments))) ((listp argument) - `(((= (first indices) ,index) - ,(if (eq (first argument) 'quote) - `(cond ((form-quoted-p token) - (complete-argument-of-type ',(second argument) syntax token all-completions)) - (t (call-next-method))) - `(cond ((not (null (rest indices))) - (pop indices) - (cond ,@(build-completions-cond-body argument))) - (t (call-next-method))))))) + (cons `((= (first indices) ,index) + ,(if (eq (first argument) 'quote) + `(cond ((eq (first (apply #'list-aref operands indices)) 'quote) + (complete-argument-of-type ',(second argument) syntax string all-completions)) + (t (call-next-method))) + `(cond ((not (null (rest indices))) + (pop indices) + (cond ,@(build-completions-cond-body argument))) + (t (call-next-method))))) + (process-arg-descs (rest arguments) + (1+ index)))) (t (cons `((= (first indices) ,index) - (complete-argument-of-type ',argument syntax token all-completions)) + (complete-argument-of-type ',argument syntax string all-completions)) (process-arg-descs (rest arguments) (1+ index))))))) (build-completions-cond-body (arguments) (append (process-arg-descs arguments 0) '((t (call-next-method)))))) `(progn - (defmethod possible-completions (syntax (operator (eql ',operator)) token operands indices) + (defmethod possible-completions (syntax (operator (eql ',operator)) string package operands indices) ,(if no-typed-completion '(call-next-method) - `(let ((all-completions (call-next-method))) + `(let* ((*package* package) + (all-completions (call-next-method))) (cond ,@(build-completions-cond-body arguments))))) ,(unless no-smart-arglist `(defmethod arglist-for-form (syntax (operator (eql ',operator)) &optional arguments) @@ -758,7 +776,8 @@ ;; up any of this stuff. (,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)) + (when 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) @@ -1361,65 +1380,77 @@ (delete-window completions-pane) (setf completions-pane nil)))) -(defun find-completion-by-fn (fn symbol package) - (esa:display-message (format nil "~a completions" symbol)) - (let* ((result (funcall fn symbol (package-name package))) - (set (first result)) - (longest (second result))) - (values longest set))) - -(defun find-completion (syntax token) - (let* ((symbol-name (token-string syntax token)) - (result (with-code-insight (start-offset token) syntax +(defun find-completions (syntax mark-or-offset string) + "Find completions for the symbol denoted by the string `string' +at `mark-or-offset'. Two values will be returned: the common +leading string of the completions and a list of the possible +completions as strings." + (let* ((result (with-code-insight mark-or-offset syntax (:operator operator :operands operands :preceding-operand-indices indices) - (let ((completions (possible-completions syntax operator token operands indices))) + (let ((completions (possible-completions + syntax operator string + (package-at-mark syntax mark-or-offset) + operands indices))) (list completions (longest-completion completions))))) (set (first result)) (longest (second result))) - (esa:display-message (format nil "~a completions" symbol-name)) (values longest set))) -(defun find-fuzzy-completion (syntax token package) - (let ((symbol-name (token-string syntax token))) - (esa:display-message (format nil "~a completions" symbol-name)) - (let* ((set (fuzzy-completions (get-usable-image syntax) symbol-name package 10)) - (best (caar set))) - (values best set)))) +(defun find-fuzzy-completions (syntax mark-or-offset string) + "Find completions for the symbol denoted by the string +`string' at `mark-or-offset'. Two values will be returned: the +common leading string of the completions and a list of the +possible completions as strings. This function uses fuzzy logic +to find completions based on `string'." + (let* ((set (fuzzy-completions (get-usable-image syntax) string + (package-at-mark syntax mark-or-offset) + 10)) + (best (caar set))) + (values best set))) -(defun complete-symbol-at-mark-with-fn (syntax mark &optional (fn #'find-completion)) +(defun complete-symbol-at-mark-with-fn (syntax mark &optional (fn #'find-completions)) "Attempt to find and complete the symbol at `mark' using the function `fn' to get the list of completions. If the completion is ambiguous, a list of possible completions will be displayed. If no symbol can be found at `mark', return nil." - (let ((token (form-around syntax (offset mark)))) - (when (and (not (null token)) - (form-token-p token) - (not (= (start-offset token) - (offset mark)))) - (multiple-value-bind (longest completions) - (funcall fn syntax (fully-quoted-form token)) - (if (> (length longest) 0) - (if (= (length completions) 1) - (replace-symbol-at-mark mark syntax longest) - (progn - (esa:display-message (format nil "Longest is ~a|" longest)) - (let ((selection (menu-choose (mapcar - ;; FIXME: this can - ;; get ugly. - #'(lambda (completion) - (if (listp completion) - (cons completion - (first completion)) - completion)) - completions) - :label "Possible completions" - :scroll-bars :vertical))) - (replace-symbol-at-mark mark syntax (or selection - longest))))) - (esa:display-message "No completions found"))) - t))) + (let* ((token (form-around syntax (offset mark))) + (useful-token (and (not (null token)) + (form-token-p token) + (not (= (start-offset token) + (offset mark)))))) + (multiple-value-bind (longest completions) + (funcall fn syntax + (if useful-token + (start-offset (fully-quoted-form token)) + (if (form-quoted-p token) + (start-offset token) + (offset mark))) + (if useful-token + (token-string syntax token) + "")) + (if completions + (if (= (length completions) 1) + (replace-symbol-at-mark mark syntax longest) + (progn + (esa:display-message (format nil "Longest is ~a|" longest)) + (let ((selection (menu-choose (mapcar + ;; FIXME: this can + ;; get ugly. + #'(lambda (completion) + (if (listp completion) + (cons completion + (first completion)) + completion)) + completions) + :label "Possible completions" + :scroll-bars :vertical))) + (if useful-token + (replace-symbol-at-mark mark syntax (or selection longest)) + (insert-sequence mark (or selection longest)))))) + (esa:display-message "No completions found"))) + t)) (defun complete-symbol-at-mark (syntax mark) "Attempt to find and complete the symbol at `mark'. If the @@ -1432,4 +1463,4 @@ completion. If the completion is ambiguous, a list of possible completions will be displayed. If no symbol can be found at `mark', return nil." - (complete-symbol-at-mark-with-fn syntax mark #'find-fuzzy-completion)) + (complete-symbol-at-mark-with-fn syntax mark #'find-fuzzy-completions))

1 0

[climacs-cvs] CVS climacs/Doc
by thenriksen 14 Sep '06

14 Sep '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv30619/Doc Modified Files: climacs-internals.texi Log Message: Fixed markup errors (thanks to Daniel Katz). --- /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2006/09/06 20:07:21 1.23 +++ /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2006/09/14 14:24:01 1.24 @@ -2235,14 +2235,14 @@ containing the files designated by @var{group} while @var{body} is run. @end deffn -@deffn {Macro} {define-group} (name (group-arg &rest args) &body body) +@deffn {Macro} {define-group} name (group-arg &rest args) &body body Define a persistent group named @var{name}. @var{Body} should return a list of pathnames and will be used to calculate which files are designated by the group. @var{Args} should be two-element lists, with the first element bound to the result of evaluating the second element. The second element will be evaluated when the group is selected to be the active group by the user. -@node Index +@end deffn @deftp {Error Condition} group-not-found This condition is signaled whenever a synonym group is unable to find

1 0

[climacs-cvs] CVS climacs
by thenriksen 12 Sep '06

12 Sep '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv17172 Modified Files: core.lisp file-commands.lisp fundamental-syntax.lisp gui.lisp lisp-syntax-swine.lisp packages.lisp search-commands.lisp Log Message: Try to naively unbreak typeout panes a little more. Also some fixes related to accepting buffers. --- /project/climacs/cvsroot/climacs/core.lisp 2006/09/08 18:12:03 1.9 +++ /project/climacs/cvsroot/climacs/core.lisp 2006/09/12 19:49:18 1.10 @@ -373,38 +373,43 @@ :value-key #'identity)) :partial-completers '(#\Space) :allow-any-input t) - (cond (success - (values object type)) + (cond ((and success (plusp (length string))) + (if object + (values object type) + (values string 'string))) ((and (zerop (length string)) defaultp) - (values default default-type)) - (t (values string 'string))))) + (values default default-type)) + (t + (values string 'string))))) + +(defgeneric switch-to-buffer (pane buffer)) + +(defmethod switch-to-buffer ((pane extended-pane) (buffer climacs-buffer)) + (with-accessors ((buffers buffers)) *application-frame* + (let* ((position (position buffer buffers)) + (pane (current-window))) + (when position + (setf buffers (delete buffer buffers))) + (push buffer buffers) + (setf (offset (point (buffer pane))) (offset (point pane))) + (setf (buffer pane) buffer) + (full-redisplay pane) + buffer))) + +(defmethod switch-to-buffer ((pane typeout-pane) (buffer climacs-buffer)) + (let ((usable-pane (or (find-if #'(lambda (pane) + (typep pane 'extended-pane)) + (windows *application-frame*)) + (split-window t)))) + (switch-to-buffer usable-pane buffer))) -(defgeneric switch-to-buffer (buffer)) - -(defmethod switch-to-buffer ((buffer climacs-buffer)) - (let* ((buffers (buffers *application-frame*)) - (position (position buffer buffers)) - (pane (current-window))) - (when position - (setf buffers (delete buffer buffers))) - (push buffer (buffers *application-frame*)) - (setf (offset (point (buffer pane))) (offset (point pane))) - (setf (buffer pane) buffer) - (full-redisplay pane) - buffer)) - -(defmethod switch-to-buffer ((name string)) +(defmethod switch-to-buffer (pane (name string)) (let ((buffer (find name (buffers *application-frame*) :key #'name :test #'string=))) - (switch-to-buffer (or buffer + (switch-to-buffer pane + (or buffer (make-new-buffer :name name))))) -;;placeholder -(defmethod switch-to-buffer ((symbol (eql 'nil))) - (let ((default (second (buffers *application-frame*)))) - (when default - (switch-to-buffer default)))) - ;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR, ;; ;;; 2005-10-31. ;; (defmethod (setf buffer) :around (buffer (pane extended-pane)) --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/08/20 13:06:39 1.24 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/09/12 19:49:18 1.25 @@ -224,27 +224,22 @@ ;;; ;;; Buffer commands -(define-command (com-switch-to-buffer :name t :command-table pane-table) () +(define-command (com-switch-to-buffer :name t :command-table pane-table) + ((buffer 'buffer :default (or (second (buffers *application-frame*)) + (any-buffer)))) "Prompt for a buffer name and switch to that buffer. -If the a buffer with that name does not exist, create it. Uses the name of the next buffer (if any) as a default." - (let* ((default (second (buffers *application-frame*))) - (buffer (if default - (accept 'buffer - :prompt "Switch to buffer" - :default default) - (accept 'buffer - :prompt "Switch to buffer")))) - (switch-to-buffer buffer))) +If the a buffer with that name does not exist, create it. Uses +the name of the next buffer (if any) as a default." + (switch-to-buffer (current-window) buffer)) -(set-key 'com-switch-to-buffer +(set-key `(com-switch-to-buffer ,*unsupplied-argument-marker*) 'pane-table '((#\x :control) (#\b))) (define-command (com-kill-buffer :name t :command-table pane-table) ((buffer 'buffer :prompt "Kill buffer" - :default (buffer (current-window)) - :default-type 'buffer)) + :default (buffer (current-window)))) "Prompt for a buffer name and kill that buffer. If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default." (kill-buffer buffer)) @@ -253,22 +248,22 @@ 'pane-table '((#\x :control) (#\k))) -(define-command (com-toggle-read-only :name t :command-table base-table) +(define-command (com-toggle-read-only :name t :command-table buffer-table) ((buffer 'buffer :default (current-buffer *application-frame*))) (setf (read-only-p buffer) (not (read-only-p buffer)))) (define-presentation-to-command-translator toggle-read-only - (read-only com-toggle-read-only base-table + (read-only com-toggle-read-only buffer-table :gesture :menu) (object) (list object)) -(define-command (com-toggle-modified :name t :command-table base-table) +(define-command (com-toggle-modified :name t :command-table buffer-table) ((buffer 'buffer :default (current-buffer *application-frame*))) (setf (needs-saving buffer) (not (needs-saving buffer)))) (define-presentation-to-command-translator toggle-modified - (modified com-toggle-modified base-table + (modified com-toggle-modified buffer-table :gesture :menu) (object) (list object)) \ No newline at end of file --- /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/11 20:13:32 1.6 +++ /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/12 19:49:18 1.7 @@ -194,7 +194,7 @@ (let ((point (point pane))) (multiple-value-bind (cursor-x cursor-y line-height) (offset-to-screen-position (offset point) pane) - (updating-output (pane :unique-id -1 :cache-value (offset point)) + (updating-output (pane :unique-id -1 :cache-value (cons (offset point) current-p)) (draw-rectangle* pane (1- cursor-x) cursor-y (+ cursor-x 2) (+ cursor-y line-height) --- /project/climacs/cvsroot/climacs/gui.lisp 2006/09/06 20:07:21 1.230 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/09/12 19:49:18 1.231 @@ -40,6 +40,8 @@ (defclass typeout-pane (application-pane esa-pane-mixin) ()) +(defmethod full-redisplay ((pane typeout-pane))) + (defgeneric buffer-pane-p (pane) (:documentation "Returns T when a pane contains a buffer.")) @@ -119,6 +121,17 @@ (make-command-table 'climacs-help-table :inherit-from '(help-table) :errorp nil) +;; We have a special command table for typeout panes because we want +;; to keep being able to do window, buffer, etc, management, but we do +;; not want any actual editing commands. +(make-command-table 'typeout-pane-table + :errorp nil + :inherit-from '(global-esa-table + base-table + pane-table + window-table + development-table + climacs-help-table)) (defvar *bg-color* +white+) (defvar *fg-color* +black+) @@ -212,6 +225,10 @@ "Return the current buffer." (buffer (car (windows application-frame)))) +(defun any-buffer () + "Return some buffer, any buffer, as long as it is a buffer!" + (first (buffers *application-frame*))) + (define-presentation-type read-only ()) (define-presentation-method highlight-presentation ((type read-only) record stream state) @@ -322,15 +339,16 @@ (setf (needs-saving buffer) t))))) (defmethod find-applicable-command-table ((frame climacs)) - (or - (let ((syntax (and (buffer-pane-p (current-window)) - (syntax (buffer (current-window)))))) - (and syntax - (slot-exists-p syntax 'command-table) - (slot-boundp syntax 'command-table) - (slot-value syntax 'command-table) - (find-command-table (slot-value syntax 'command-table)))) - (find-command-table 'global-climacs-table))) + (cond ((typep (current-window) 'typeout-pane) + (find-command-table 'typeout-pane-table)) + ((buffer-pane-p (current-window)) + (or (let ((syntax (syntax (buffer (current-window))))) + ;; Why all this absurd checking? Smells fishy. + (and (slot-exists-p syntax 'command-table) + (slot-boundp syntax 'command-table) + (slot-value syntax 'command-table) + (find-command-table (slot-value syntax 'command-table)))) + (find-command-table 'global-climacs-table))))) (define-command (com-full-redisplay :name t :command-table base-table) () "Redisplay the contents of the current window. @@ -431,16 +449,27 @@ :width 900)))) (values vbox extended-pane))) +(defgeneric setup-split-pane (orig-pane new-pane) + (:documentation "Perform split-setup operations `new-pane', + which is supposed to be a pane that has been freshly split from + `orig-pane'.")) + +(defmethod setup-split-pane ((orig-pane extended-pane) (new-pane extended-pane)) + (setf (offset (point (buffer orig-pane))) (offset (point orig-pane)) + (buffer new-pane) (buffer orig-pane) + (auto-fill-mode new-pane) (auto-fill-mode orig-pane) + (auto-fill-column new-pane) (auto-fill-column orig-pane))) + +(defmethod setup-split-pane ((orig-pane typeout-pane) (new-pane extended-pane)) + (setf (buffer new-pane) (any-buffer))) + (defun split-window (&optional (vertically-p nil) (pane (current-window))) (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) (multiple-value-bind (vbox new-pane) (make-pane-constellation) (let* ((current-window pane) (constellation-root (find-parent current-window))) - (setf (offset (point (buffer current-window))) (offset (point current-window)) - (buffer new-pane) (buffer current-window) - (auto-fill-mode new-pane) (auto-fill-mode current-window) - (auto-fill-column new-pane) (auto-fill-column current-window)) + (setup-split-pane current-window new-pane) (push new-pane (windows *application-frame*)) (setf *standard-output* new-pane) (replace-constellation constellation-root vbox vertically-p) @@ -510,11 +539,7 @@ (setf (windows *application-frame*) (append (cdr (windows *application-frame*)) (list (car (windows *application-frame*)))))) - ;; Try to avoid setting the point in a typeout pane. FIXME: This is a kludge. - (if (and (subtypep 'typeout-pane (type-of (car (windows *application-frame*)))) - (> (length (windows *application-frame*)) 1)) - (other-window) - (setf *standard-output* (car (windows *application-frame*))))) + (setf *standard-output* (car (windows *application-frame*)))) ;;; For the ESA help functions. --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/12 17:24:56 1.7 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/12 19:49:18 1.8 @@ -1013,7 +1013,7 @@ (esa:display-message "No buffer ~A" (buffer-name location)) (beep) (return-from goto-location)) - (switch-to-buffer buffer) + (switch-to-buffer (current-window) buffer) (goto-position (point (current-window)) (char-position (source-position location))))) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/11 20:13:32 1.118 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/12 19:49:18 1.119 @@ -344,6 +344,7 @@ #:current-buffer #:current-point #:current-mark + #:any-buffer #:point #:syntax #:mark --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/09/06 20:07:21 1.14 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/09/12 19:49:18 1.15 @@ -318,7 +318,7 @@ (buffers buffers) (mark mark)) state (flet ((head-to-buffer (buffer) - (switch-to-buffer buffer) + (switch-to-buffer (current-window) buffer) (setf mark (point (current-window))) (beginning-of-buffer mark))) (unless (eq (current-buffer) (first buffers))

1 0

[climacs-cvs] CVS climacs
by thenriksen 12 Sep '06

12 Sep '06

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"))

1 0

[climacs-cvs] CVS climacs/Doc
by thenriksen 12 Sep '06

12 Sep '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv31323/Doc Modified Files: climacs-user.texi Log Message: Changed terminology from "order" to "gesture". --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/09/06 17:42:08 1.14 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/09/12 17:03:51 1.15 @@ -179,8 +179,8 @@ @cindex command Such a key sequence is called a @emph{complete key sequence} @cindex complete key sequence -or an @emph{order}. -@cindex order +or a @emph{gesture}. +@cindex gesture @node Basic editing commands @chapter Basic editing commands @@ -239,7 +239,7 @@ Typically, a numeric argument prefix makes the command repeat its action a number of times indicated by the numeric argument prefix. For instance, the command @command{Delete Object}, usually associated -with the order @kbd{C-d}, normally deletes a single object from the +with the gesture @kbd{C-d}, normally deletes a single object from the buffer. However, if given a numeric argument, it deletes that many objects. @@ -262,7 +262,7 @@ command. One way is to first type @kbd{C-u}, @kindex C-u then a sequence of -decimal digits, and finally the order that invokes the command. For +decimal digits, and finally the gesture that invokes the command. For instance, to delete the next 15 objects after point, you could type @kbd{C-u 1 5 C-d}. The other way is to hold down the @key{Meta} key (usually the one marked @key{Alt}) while typing the decimal digits, as @@ -300,19 +300,19 @@ To delete an object @emph{to the right} of the point, use the @kbd{C-d} @kindex C-d -(@command{Delete Object}) order. When used with a numeric +(@command{Delete Object}) gesture. When used with a numeric argument, these commands delete that many objects. @node Deleting by words @subsection Deleting by words It is also possible to delete larger chunks of buffer contents. The -order @kbd{M-d} +gesture @kbd{M-d} @kindex M-d (@command{Kill Word}) is used to delete the @emph{word} @cindex word @emph{following} point. If point is not at the beginning of a word, -then the part of the word that follows point is deleted. The order +then the part of the word that follows point is deleted. the gesture @kbd{M-@key{Backspace}} @kindex M-@key{Backspace} (@command{Backward Kill Word}) is used to @@ -326,7 +326,7 @@ @subsection Deleting by lines @climacs{} allows you to delete buffer objects one or more lines at a -time. The order @kbd{C-k} +time. The gesture @kbd{C-k} @kindex C-k (@command{Kill Line}) lets you do this. When point is @emph{not} at the end of a line, then this command kills the buffer contents from @@ -357,14 +357,14 @@ The most frequent way of moving around is by one buffer position at a time. -The order @kbd{C-f} +The gesture @kbd{C-f} @kindex C-f (@command{Forward Object}) allows you to advance the position of point by one position. If given a numeric argument, it advances by that many positions. The @command{Forward Object} command is also associated with the @emph{right-arrow key}. -The order @kbd{C-b} +The gesture @kbd{C-b} @kindex C-b (@command{Backward Object}) allows you to move the position of point backward by one position. If given a numeric @@ -377,14 +377,14 @@ @climacs{} will allow you to move around by larger units than objects. -The order @kbd{M-f} +The gesture @kbd{M-f} @kindex M-f (@command{Forward Word}) lets you move forward over the @emph{word} @cindex word following point. With a numeric argument, this command moves point forward that many words. -The order @kbd{M-b} +The gesture @kbd{M-b} @kindex M-b (@command{Backward Word}) lets you move backward over the @emph{word} @cindex word @@ -401,7 +401,7 @@ @climacs{} has commands to move by one or several @emph{lines} at a time. -The order @kbd{C-p} +The gesture @kbd{C-p} @kindex C-p (@command{Previous Line}) allows you to move point @emph{up} to the previous line. If given a numeric @@ -409,7 +409,7 @@ @command{Previous Line} is also associated with the @emph{up-arrow key}. -The order @kbd{C-n} +The gesture @kbd{C-n} @kindex C-n (@command{Next Line}) allows you to move point @emph{down} to the next line. If given a numeric @@ -431,7 +431,7 @@ In order to make editing as efficient as possible, many @climacs{} commands can be invoked by key sequences. It is, however, possible to -invoke most @climacs{} commands by using the order @kbd{M-x} which +invoke most @climacs{} commands by using the gesture @kbd{M-x} which invokes the command @command{Extended Command} which lets you type the @emph{name} of the command in the minibuffer at the prompt. In general, you do not have to type the full name of the command, @@ -467,7 +467,7 @@ @node Finding a file @subsection Finding a file -To find a file, use the order @kbd{C-x C-f} +To find a file, use the gesture @kbd{C-x C-f} @kindex C-x C-f (@command{Find File}). @@ -483,7 +483,7 @@ @node Saving a buffer @subsection Saving a buffer -To save a buffer, use the order @kbd{C-x C-s} +To save a buffer, use the gesture @kbd{C-x C-s} @kindex C-x C-s (@command{Save Buffer}). The contents of the buffer will be transfered to the file associated @@ -495,7 +495,7 @@ @subsection Writing a buffer @anchor{write-buffer} -To write a buffer to a file, use the order @kbd{C-x C-w} +To write a buffer to a file, use the gesture @kbd{C-x C-w} @kindex C-x C-w (@command{Write Buffer}). @climacs{} will prompt for the name of a file to save the buffer contents in. Completion (by using the @@ -602,22 +602,22 @@ @node Group commands @section Group commands -Specific groups can be defined by using the order @kbd{C-x g d} +Specific groups can be defined by using the gesture @kbd{C-x g d} @kindex C-x g d (@command{Define Group}). You will be queried for a name for the group and a list of buffers, and a group with the specified name and buffers will be created and selected as the active group. Alternatively, you can -use the order @kbd{C-x g f} +use the gesture @kbd{C-x g f} @kindex C-x g f (@command{Define File Group}, which will query for files instead of buffers. If you wish to select an already existing group (persistent or -specific) as the active group, you can use the order @kbd{C-x g s}. +specific) as the active group, you can use the gesture @kbd{C-x g s}. @kindex C-x g s -You can deselect the active group with the order @kbd{C-x g u} +You can deselect the active group with the gesture @kbd{C-x g u} @kindex C-x g u (@command{Deselect Group}) - this will usually make all group-aware commands operate on just the current buffer. To see which group is the -active group, use the order @kbd{C-x g c} +active group, use the gesture @kbd{C-x g c} @kindex C-x g c (@command{Current Group}), and to see the buffers and files designated by the active group, use @kbd{C-x g l} (@command{List Group Contents}). @@ -641,20 +641,20 @@ the keyboard, and then making it possibly to @emph{replay} the recorded sequence. -To start recording a sequence of keystrokes, use the order @kbd{C-x (} +To start recording a sequence of keystrokes, use the gesture @kbd{C-x (} @kindex C-x ( (@command{Start Kbd Macro}). You will see the word @samp{Def} appearing on the mode line, indicating that a keyboard macro is being defined. As long as recording is in effect, every keystroke will be saved for later use. -To stop recording a sequence of keystrokes, use the order @kbd{C-x )} +To stop recording a sequence of keystrokes, use the gesture @kbd{C-x )} @kindex C-x ) (@command{End Kbd Macro}). The word @samp{Def} will disappear from the mode line, indicating that keystrokes are no longer being recorded. -To replay a previously recorded sequence of keystrokes, use the order +To replay a previously recorded sequence of keystrokes, use the gesture @kbd{C-x e} @kindex C-x e (@command{Call Last Kbd Macro}). When used with a numeric argument, @@ -713,7 +713,7 @@ immediate feedback while entering the search string. Incremental search is controlled through a command loop. @xref{The isearch command loop}. -Incremental search can be entered via two orders, @kbd{C-s} +Incremental search can be entered via two gestures, @kbd{C-s} @kindex C-s (@command{Isearch Forward}) and @kbd{C-r} @kindex C-r @@ -729,7 +729,7 @@ the search string, and @climacs{} moving point ahead to the most immediate instance of the provided string, while the user is typing. Apart from simply entering text, the user can manipulate the command loop by -entering the following orders: +entering the following gestures: @table @kbd @item C-s @@ -749,7 +749,7 @@ @item @key{Backspace} Delete the last element of the search string. This is not the same as deleting the last character - for example, if the word at point has been -appended to the search string via @kbd{C-w}, this order will delete the +appended to the search string via @kbd{C-w}, this gesture will delete the entire word, not just the last character of the word. @item @key{Newline} Exit the isearch command loop. @@ -758,14 +758,14 @@ @node Replacing single strings @subsection Replacing single strings -The basic string-replacement command can be accessed through the order +The basic string-replacement command can be accessed through the gesture @kbd{C-x e} @kindex C-x e (@command{Replace String}). This command will prompt for two strings, and replace all instances of the first string following point in the current buffer, with the second string. This command is not querying, and will thus not prompt before each replacement, so if you desire this -behavior, use the order @kbd{M-%} +behavior, use the gesture @kbd{M-%} @kindex M-% (@command{Query Replace}) instead. @xref{The query-replace command loop}. @@ -795,7 +795,7 @@ process. The command loop will loop across the buffer, and for each match, the -command loop will read an order from the user. The following orders and +command loop will read a gesture from the user. The following gestures and their corresponding commands are available: @table @kbd @@ -818,7 +818,7 @@ In addition to this manual, @climacs{} contains an online help facility. There are several different topics that you can get help -with. Most of these topics are obtained by some order using the +with. Most of these topics are obtained by some gesture using the @kbd{C-h} @kindex C-h prefix key. The key following @kbd{C-h} determines what kind of help @@ -829,13 +829,13 @@ * Help with a key binding:: * Help with a particular key sequence:: * Help finding a command:: -* Help finding an order for a command:: +* Help finding a gesture for a command:: @end menu @node Help with a command @section Help with a command -To get documentation about a particular command, use the order @kbd{C-h +To get documentation about a particular command, use the gesture @kbd{C-h f} @kindex C-h f (@command{Describe Command}). You will be prompted for the name of a @@ -847,24 +847,24 @@ @node Help with a key binding @section Help with a key binding -To obtain a list of all orders and the associated commands that are -valid in a particular context, use the order @kbd{C-h b} +To obtain a list of all gestures and the associated commands that are +valid in a particular context, use the gesture @kbd{C-h b} @kindex C-h b (@command{Describe Bindings}). A table with each command name and -associated order (if any) is displayed in a new window. +associated gesture (if any) is displayed in a new window. @node Help with a particular key sequence @section Help with a particular key sequence -To obtain a description of what some putative order will do, use the -order @kbd{C-h c}p +To obtain a description of what some putative gesture will do, use the +gesture @kbd{C-h c}p @kindex C-h c (@command{Describe Key Briefly}). You will be prompted for a key sequence. If the key sequence you type is bound to a command, the command name will be displayed in the minibuffer. Otherwise, a message indicating that the key is not bound to a command will be displayed. -For more detailed information, use the order @kbd{C-h c} +For more detailed information, use the gesture @kbd{C-h c} @kindex C-h k (@command{Describe Key}). You will be prompted for a key sequence, and if the key sequence you provide is bound to a command, documentation for @@ -875,7 +875,7 @@ @section Help finding a command If you do not know which commands are applicable to a given situation, -you can use the order @kbd{C-h a} +you can use the gesture @kbd{C-h a} @kindex C-h a (@command{Apropos Command}) to perform a keyword-based search for commands. You will be prompted for a keyword, after which @climacs{} @@ -885,18 +885,18 @@ them. You can also click on the names of the commands to get more thorough documentation. -@node Help finding an order for a command -@section Help finding an order for a command +@node Help finding a gesture for a command +@section Help finding a gesture for a command Sometimes, you know the name of a command, and would like to find out -whether it is bound to any order, and if so, which one(s). For that, -you can use the order @kbd{C-h w} +whether it is bound to any gesture, and if so, which one(s). For that, +you can use the gesture @kbd{C-h w} @kindex C-h w (@command{Where Is}). You will be prompted for a command name (completion can be used as usual), and if the command name given is -bound to an order, that order will displayed in the minibuffer. +bound to a a gesture, that gesture will displayed in the minibuffer. Otherwise, a message indicating that the command is not bound to any -order will be displayed. +gesture will be displayed. @node Proposal for new buffer/pane relations @chapter Proposal for new buffer/pane relations

1 0

[climacs-cvs] CVS climacs
by thenriksen 11 Sep '06

11 Sep '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12218 Modified Files: syntax.lisp rectangle.lisp pane.lisp packages.lisp lisp-syntax.lisp lisp-syntax-swine.lisp groups.lisp fundamental-syntax.lisp climacs.asd base.lisp Added Files: utils.lisp Log Message: Added utils.lisp file and CLIMACS-UTILS package so it's no longer necessary to hand-roll `with-gensyms', `once-only' and other helpful macros. --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/09/02 21:43:56 1.71 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/09/11 20:13:32 1.72 @@ -207,13 +207,13 @@ of the option." ;; The name is converted to a keyword symbol which is used for all ;; further identification. - (let ((name-symbol (gensym)) - (symbol (intern (string-upcase option-name) - (find-package :keyword)))) - `(defmethod eval-option ((,syntax-symbol ,syntax) - (,name-symbol (eql ,symbol)) - ,value-symbol) - ,@body))) + (with-gensyms (name) + (let ((symbol (intern (string-upcase option-name) + (find-package :keyword)))) + `(defmethod eval-option ((,syntax-symbol ,syntax) + (,name (eql ,symbol)) + ,value-symbol) + ,@body)))) (defgeneric current-attributes-for-syntax (syntax) (:method-combination append) --- /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/09 18:21:40 1.2 +++ /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/11 20:13:32 1.3 @@ -54,18 +54,16 @@ columns `startcol' and `endcol'. If `force-start' or `force-end' is non-NIL, the line will be padded with space characters in order to put `start-mark' or `end-mark' at their specified columns respectively." - (let ((mark-val-sym (gensym)) - (startcol-val-sym (gensym)) - (endcol-val-sym (gensym))) + (once-only (mark startcol endcol) `(progn - (let ((,mark-val-sym ,mark) - (,startcol-val-sym ,startcol) - (,endcol-val-sym ,endcol)) - (move-to-column ,mark-val-sym ,startcol-val-sym ,force-start) - (let ((,start-mark (clone-mark ,mark-val-sym))) - (let ((,end-mark (clone-mark ,mark-val-sym))) - (move-to-column ,end-mark ,endcol-val-sym ,force-end) - ,@body)))))) + (let ((,mark ,mark) + (,startcol ,startcol) + (,endcol ,endcol)) + (move-to-column ,mark ,startcol ,force-start) + (let ((,start-mark (clone-mark ,mark))) + (let ((,end-mark (clone-mark ,mark))) + (move-to-column ,end-mark ,endcol ,force-end) + ,@body)))))) (defun extract-and-delete-rectangle-line (mark startcol endcol) "For the line that `mark' is in, delete and return the string --- /project/climacs/cvsroot/climacs/pane.lisp 2006/09/02 21:43:56 1.52 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/09/11 20:13:32 1.53 @@ -110,21 +110,21 @@ will be evaluated whenever a complete list of buffers is needed (to set up all buffers to prepare for undo, and to check them all for changes after `body' has run)." - (let ((buffer-sym (gensym))) - `(progn - (dolist (,buffer-sym ,get-buffers-exp) - (setf (undo-accumulate ,buffer-sym) '())) - (unwind-protect (progn ,@body) - (dolist (,buffer-sym ,get-buffers-exp) - (cond ((null (undo-accumulate ,buffer-sym)) nil) - ((null (cdr (undo-accumulate ,buffer-sym))) - (add-undo (car (undo-accumulate ,buffer-sym)) - (undo-tree ,buffer-sym))) - (t - (add-undo (make-instance 'compound-record - :buffer ,buffer-sym - :records (undo-accumulate ,buffer-sym)) - (undo-tree ,buffer-sym))))))))) + (with-gensyms (buffer) + `(progn + (dolist (,buffer ,get-buffers-exp) + (setf (undo-accumulate ,buffer) '())) + (unwind-protect (progn ,@body) + (dolist (,buffer ,get-buffers-exp) + (cond ((null (undo-accumulate ,buffer)) nil) + ((null (cdr (undo-accumulate ,buffer))) + (add-undo (car (undo-accumulate ,buffer)) + (undo-tree ,buffer))) + (t + (add-undo (make-instance 'compound-record + :buffer ,buffer + :records (undo-accumulate ,buffer)) + (undo-tree ,buffer))))))))) (defmethod flip-undo-record :around ((record climacs-undo-record)) (with-slots (buffer) record --- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/06 20:07:21 1.117 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/11 20:13:32 1.118 @@ -26,6 +26,14 @@ (in-package :cl-user) +(defpackage :climacs-utils + (:use :clim-lisp) + (:export #:with-gensyms + #:once-only + #:unlisted + #:fully-unlisted + #:listed)) + (defpackage :climacs-buffer (:use :clim-lisp :flexichain :binseq) (:export #:buffer #:standard-buffer @@ -76,7 +84,7 @@ (:documentation "An implementation of a kill ring.")) (defpackage :climacs-base - (:use :clim-lisp :climacs-buffer :climacs-kill-ring :esa-buffer) + (:use :clim-lisp :climacs-buffer :climacs-kill-ring :esa-buffer :climacs-utils) (:export #:as-offsets #:do-buffer-region #:do-buffer-region-lines @@ -118,7 +126,7 @@ #:add-abbrev)) (defpackage :climacs-syntax - (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) + (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain :climacs-utils) (:export #:syntax #:define-syntax #:*default-syntax* #:eval-option #:define-option-for-syntax @@ -170,7 +178,7 @@ (defpackage :climacs-pane (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev - :climacs-syntax :flexichain :undo :esa-buffer :esa-io) + :climacs-syntax :flexichain :undo :esa-buffer :esa-io :climacs-utils) (:export #:climacs-buffer #:needs-saving #:filepath #:file-saved-p #:file-write-time #:read-only-p #:buffer-read-only @@ -378,7 +386,8 @@ (defpackage :climacs-core (:use :clim-lisp :climacs-base :climacs-buffer :climacs-fundamental-syntax :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring - :climacs-editing :climacs-gui :clim :climacs-abbrev :esa :esa-buffer :esa-io) + :climacs-editing :climacs-gui :clim :climacs-abbrev :esa :esa-buffer :esa-io + :climacs-utils) (:export #:display-string #:object-equal #:object= @@ -484,7 +493,7 @@ (defpackage :climacs-lisp-syntax (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base :climacs-syntax :climacs-fundamental-syntax :flexichain :climacs-pane :climacs-gui - :climacs-motion :climacs-editing :climacs-core) + :climacs-motion :climacs-editing :climacs-core :climacs-utils) (:export #:lisp-string #:edit-definition)) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/11 08:55:21 1.113 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/11 20:13:32 1.114 @@ -28,21 +28,6 @@ ;;; ;;; Convenience functions and macros: -(defun unlisted (obj &optional (fn #'first)) - (if (listp obj) - (funcall fn obj) - obj)) - -(defun fully-unlisted (obj &optional (fn #'first)) - (if (listp obj) - (fully-unlisted (funcall fn obj)) - obj)) - -(defun listed (obj) - (if (listp obj) - obj - (list obj))) - (defun usable-package (package-designator) "Return a usable package based on `package-designator'." (or (find-package package-designator) --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/11 08:55:21 1.5 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/11 20:13:32 1.6 @@ -741,33 +741,29 @@ (preceding-operand-sym (or preceding-operand (gensym))) (operands-sym (or operands (gensym))) (form-sym (or form (gensym))) - (operand-indices-sym (or preceding-operand-indices (gensym))) - ;; My kingdom for with-gensyms (or once-only)! - (mark-value-sym (gensym)) - (syntax-value-sym (gensym))) - `(let* ((,mark-value-sym ,mark-or-offset) - (,syntax-value-sym ,syntax) - (,form-sym - ;; Find a form with a valid (fboundp) operator. - (let ((immediate-form - (preceding-form ,mark-value-sym ,syntax-value-sym))) - (unless (null immediate-form) - (or (find-applicable-form ,syntax-value-sym immediate-form) - ;; If nothing else can be found, and `arg-form' - ;; is the operator of its enclosing form, we use - ;; the enclosing form. - (when (eq (first-form (children (parent immediate-form))) immediate-form) - (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-value-sym))) - (,operands-sym (when ,form-sym (form-operands ,form-sym ,syntax-value-sym)))) - (declare (ignorable ,mark-value-sym ,syntax-value-sym ,form-sym - ,operator-sym ,operands-sym)) - (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) - (when ,form-sym (find-operand-info ,syntax-value-sym ,mark-value-sym ,form-sym)) - (declare (ignorable ,preceding-operand-sym ,operand-indices-sym)) - ,@body)))) + (operand-indices-sym (or preceding-operand-indices (gensym)))) + (once-only (mark-or-offset syntax) + `(declare (ignorable ,mark-or-offset ,syntax)) + `(let* ((,form-sym + ;; Find a form with a valid (fboundp) operator. + (let ((immediate-form + (preceding-form ,mark-or-offset ,syntax))) + (unless (null immediate-form) + (or (find-applicable-form ,syntax immediate-form) + ;; If nothing else can be found, and `arg-form' + ;; is the operator of its enclosing form, we use + ;; the enclosing form. + (when (eq (first-form (children (parent immediate-form))) immediate-form) + (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)))) + (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)) + (declare (ignorable ,preceding-operand-sym ,operand-indices-sym)) + ,@body))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/climacs/cvsroot/climacs/groups.lisp 2006/09/08 18:12:03 1.2 +++ /project/climacs/cvsroot/climacs/groups.lisp 2006/09/11 20:13:32 1.3 @@ -273,22 +273,20 @@ `body' has run. Also, `buffers' will be bound to a list of the buffers containing the files designated by `group' while `body' is run." - (let ((buffers-before-sym (gensym)) - (buffers-after-sym (gensym)) - (buffer-diff-sym (gensym)) - (group-val-sym (gensym))) - `(let ((,buffers-before-sym (buffers *application-frame*)) - (,group-val-sym ,group)) - (ensure-group-buffers ,group-val-sym) - (let* ((,buffers-after-sym (buffers *application-frame*)) - (,buffer-diff-sym (set-difference ,buffers-after-sym - ,buffers-before-sym)) - (,buffers (group-buffers ,group-val-sym))) - (unwind-protect (progn ,@body) - (unless ,keep - (loop for buffer in ,buffer-diff-sym + (with-gensyms (buffers-before buffers-after buffer-diff) + (once-only (group keep) + `(let ((,buffers-before (buffers *application-frame*)) + (,group ,group)) + (ensure-group-buffers ,group) + (let* ((,buffers-after (buffers *application-frame*)) + (,buffer-diff (set-difference ,buffers-after + ,buffers-before)) + (,buffers (group-buffers ,group))) + (unwind-protect (progn ,@body) + (unless ,keep + (loop for buffer in ,buffer-diff do (save-buffer buffer) - do (kill-buffer buffer)))))))) + do (kill-buffer buffer))))))))) (defmacro define-group (name (group-arg &rest args) &body body) "Define a persistent group named `name'. `Body' should return a @@ -297,25 +295,25 @@ the first element bound to the result of evaluating the second element. The second element will be evaluated when the group is selected to be the active group by the user." - (let ((name-val-sym (gensym)) - (group-val-sym (gensym))) - `(let ((,name-val-sym ,name)) - (assert (stringp ,name-val-sym)) - (setf (gethash ,name-val-sym *persistent-groups*) - (make-instance 'custom-group - :name ,name-val-sym - :pathname-lister #'(lambda (,group-val-sym) - (destructuring-bind - (&key ,@(mapcar #'(lambda (arg) - `((,arg ,arg))) - (mapcar #'first args))) - (value-plist ,group-val-sym) - (let ((,group-arg ,group-val-sym)) - ,@body))) - :select-response #'(lambda (group) - (declare (ignorable group)) - ,@(loop for (name form) in args - collect `(setf (getf (value-plist group) ',name) ,form)))))))) + (with-gensyms (group) + (once-only (name) + `(let ((,name ,name)) + (assert (stringp ,name)) + (setf (gethash ,name *persistent-groups*) + (make-instance 'custom-group + :name ,name + :pathname-lister #'(lambda (,group) + (destructuring-bind + (&key ,@(mapcar #'(lambda (arg) + `((,arg ,arg))) + (mapcar #'first args))) + (value-plist ,group) + (let ((,group-arg ,group)) + ,@body))) + :select-response #'(lambda (group) + (declare (ignorable group)) + ,@(loop for (name form) in args + collect `(setf (getf (value-plist group) ',name) ,form))))))))) (define-group "Current Directory Files" (group) (declare (ignore group)) --- /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/02 21:43:56 1.5 +++ /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/11 20:13:32 1.6 @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Package: CLIMACS-FUNDAMENTAL-SYNTAX -*- +;; -*- Mode: Lisp; Package: CLIMACS-FUNDAMENTAL-SYNTAX -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh(a)labri.fr) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/09/06 20:07:21 1.54 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/09/11 20:13:32 1.55 @@ -55,6 +55,7 @@ (:file "binseq2" :depends-on ("binseq-package" "obinseq" "binseq")))) (:file "packages" :depends-on ("cl-automaton" "Persistent")) + (:file "utils" :depends-on ("packages")) (:file "buffer" :depends-on ("packages")) (:file "motion" :depends-on ("packages" "buffer" "syntax")) (:file "editing" :depends-on ("packages" "buffer" "syntax" "motion" "kill-ring")) @@ -62,9 +63,9 @@ :pathname #p"Persistent/persistent-buffer.lisp" :depends-on ("packages" "buffer" "Persistent")) - (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring")) + (:file "base" :depends-on ("packages" "utils" "buffer" "persistent-buffer" "kill-ring")) (:file "abbrev" :depends-on ("packages" "buffer" "base")) - (:file "syntax" :depends-on ("packages" "buffer" "base")) + (:file "syntax" :depends-on ("packages" "utils" "buffer" "base")) (:file "text-syntax" :depends-on ("packages" "base" "buffer" "syntax" "motion")) (:file "delegating-buffer" :depends-on ("packages" "buffer")) (:file "kill-ring" :depends-on ("packages")) @@ -72,7 +73,7 @@ (:file "persistent-undo" :pathname #p"Persistent/persistent-undo.lisp" :depends-on ("packages" "buffer" "persistent-buffer" "undo")) - (:file "pane" :depends-on ("packages" "syntax" "buffer" "base" + (:file "pane" :depends-on ("packages" "utils" "syntax" "buffer" "base" "persistent-undo" "persistent-buffer" "abbrev" "delegating-buffer" "undo")) (:file "fundamental-syntax" :depends-on ("packages" "syntax" "buffer" "pane" @@ -83,7 +84,7 @@ (:file "prolog2paiprolog" :depends-on ("prolog-syntax")) (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) - (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane" + (:file "lisp-syntax" :depends-on ("packages" "utils" "syntax" "buffer" "base" "pane" "window-commands" "gui")) (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "motion-commands" @@ -91,7 +92,7 @@ #.(if (find-swank) '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) (values)) - (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" + (:file "gui" :depends-on ("packages" "utils" "syntax" "base" "buffer" "undo" "pane" "kill-ring" "text-syntax" "abbrev" "editing" "motion")) (:file "io" :depends-on ("packages" "gui")) --- /project/climacs/cvsroot/climacs/base.lisp 2006/09/04 07:05:21 1.60 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/09/11 20:13:32 1.61 @@ -71,8 +71,7 @@ at the beginning of the line and `body' will be executed. Note that the iteration will always start from the mark specifying the earliest position in the buffer." - (let ((mark-sym (gensym)) - (mark2-sym (gensym))) + (with-gensyms (mark-sym mark2-sym) `(progn (let* ((,mark-sym (clone-mark ,mark1)) (,mark2-sym (clone-mark ,mark2))) --- /project/climacs/cvsroot/climacs/utils.lisp 2006/09/11 20:13:33 NONE +++ /project/climacs/cvsroot/climacs/utils.lisp 2006/09/11 20:13:33 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-UTILS -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)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. ;;; Miscellaneous utilities used in Climacs. (in-package :climacs-utils) ; Cribbed from Paul Graham (defmacro with-gensyms (syms &body body) `(let ,(mapcar #'(lambda (s) `(,s (gensym))) syms) ,@body)) ; Cribbed from PCL by Seibel (defmacro once-only ((&rest names) &body body) (let ((gensyms (loop for n in names collect (gensym)))) `(let (,@(loop for g in gensyms collect `(,g (gensym)))) `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) ,@body))))) (defun unlisted (obj &optional (fn #'first)) (if (listp obj) (funcall fn obj) obj)) (defun fully-unlisted (obj &optional (fn #'first)) (if (listp obj) (fully-unlisted (funcall fn obj)) obj)) (defun listed (obj) (if (listp obj) obj (list obj)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 11 Sep '06

11 Sep '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv11152 Modified Files: lisp-syntax.lisp lisp-syntax-swine.lisp Log Message: Fixed some bugs related to evil argument lists (SBCL `make-string') and made applicable-form-finding even more intelligent (again). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/02 21:43:56 1.112 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/11 08:55:21 1.113 @@ -33,6 +33,11 @@ (funcall fn obj) obj)) +(defun fully-unlisted (obj &optional (fn #'first)) + (if (listp obj) + (fully-unlisted (funcall fn obj)) + obj)) + (defun listed (obj) (if (listp obj) obj --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/08 18:12:03 1.4 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/11 08:55:21 1.5 @@ -118,7 +118,7 @@ (unlisted (find (symbol-name keyword) (get-args '&key) :key #'(lambda (arg) - (symbol-name (unlisted arg))) + (symbol-name (fully-unlisted arg))) :test #'string=)))) ;; We have to find the associated ;; symbol in the argument list... ugly. @@ -166,7 +166,7 @@ (get-args '&key) :test #'string= :key #'(lambda (arg) - (symbol-name (unlisted arg)))))) + (symbol-name (fully-unlisted arg)))))) ;; We are in the &body, &rest or &key arguments. (values ;; Only emphasize the &key @@ -369,7 +369,7 @@ (worker (parent operand-form))))))))) (nreverse (worker operand-form t))))) -(defun find-operand-info (mark-or-offset syntax operator-form) +(defun find-operand-info (syntax mark-or-offset operator-form) "Returns two values: The operand preceding `mark-or-offset' and the path from `operator-form' to the operand." (as-offsets ((offset mark-or-offset)) @@ -444,31 +444,62 @@ (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 direct-arg-p (syntax operator-form arg-form) + "Is `arg-form' a direct argument to `operator-form'? A \"direct +argument\" is defined as an argument that would be directly bound +to a symbol when evaluating the operators body, or as an argument +that would be a direct component of a &body or &rest argument." + (let ((operator (token-to-object syntax operator-form))) + (and + ;; An operator is not an argument to itself. + (not (eq arg-form + (first-form (children (parent operator-form))))) + ;; An operator must be valid. + (valid-operator-p operator) + ;; The argument must match the operators argument list. + (indices-match-arglist + (arglist (image syntax) + operator) + (nth-value 1 (find-operand-info + syntax + (start-offset arg-form) + (parent operator-form))))))) + +(defun find-direct-operator (syntax arg-form) + "Check whether `arg-form' is a direct argument to one of its +parents. If it is, return the form with the operator that +`arg-form' is a direct argument to. If not, return NIL." + (labels ((recurse (form) + ;; Check whether `arg-form' is a direct argument to + ;; the operator of `form'. + (when (parent form) + (if (direct-arg-p syntax (first-form (children form)) arg-form) + form + (recurse (parent form)))))) + (recurse (parent arg-form)))) + +(defun find-applicable-form (syntax arg-form) + "Find the enclosing form that has `arg-form' as a valid +argument. Return NIL if none can be found." + ;; The algorithm for finding the applicable form: + ;; + ;; From `arg-form', we wander up the tree looking enclosing forms, + ;; until we find a a form with an operator, the form-operator, that + ;; has `arg-form' as a direct argument (this is checked by comparing + ;; argument indices for `arg-form', relative to form-operator, with + ;; the arglist ofform-operator). However, if form-operator itself is + ;; a direct argument to one of its parents, we ignore it (unless + ;; form-operators form-operator is itself a direct argument, + ;; etc). This is so we can properly handle nested/destructuring + ;; argument lists such as those found in macros. + (labels ((recurse (candidate-form) + (when (parent candidate-form) + (if (and (direct-arg-p syntax (first-form (children candidate-form)) + arg-form) + (not (find-applicable-form syntax (first-form (children candidate-form))))) + candidate-form + (recurse (parent candidate-form)))))) + (recurse (parent arg-form)))) (defun relevant-keywords (arglist arg-indices) "Return a list of the keyword arguments that it would make @@ -526,7 +557,8 @@ :test #'(lambda (a b) (string-equal a b :start1 1)) - :key #'symbol-name)) + :key #'(lambda (s) + (symbol-name (fully-unlisted s))))) (mapcar #'string-downcase completions)))) relevant-completions)) completions)))) @@ -719,31 +751,12 @@ ;; Find a form with a valid (fboundp) operator. (let ((immediate-form (preceding-form ,mark-value-sym ,syntax-value-sym))) - ;; Recurse upwards until we find a form with a valid - ;; operator. This could be improved a lot, as we could - ;; inspect the lambda list of the found operator and - ;; check if the position of mark makes sense with - ;; regard to the structure of the lambda list. If we - ;; cannot find a form with a valid operator, just - ;; return the form `mark' is in. (unless (null immediate-form) - (labels ((recurse (form) - (unless (null (parent form)) - (or (unless (eq (first-form (children (parent form))) - form) - (recurse (parent form))) - (and (valid-operator-p (form-operator - form - ,syntax-value-sym)) - (indices-match-arglist - (arglist-for-form - ,syntax-value-sym - (form-operator form ,syntax-value-sym) - (form-operands form ,syntax-value-sym)) - (nth-value 1 (find-operand-info ,mark-value-sym ,syntax-value-sym form))) - (not (direct-arg-p form ,syntax-value-sym)) - form))))) - (or (recurse (parent immediate-form)) + (or (find-applicable-form ,syntax-value-sym immediate-form) + ;; If nothing else can be found, and `arg-form' + ;; is the operator of its enclosing form, we use + ;; the enclosing form. + (when (eq (first-form (children (parent immediate-form))) immediate-form) (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking ;; up any of this stuff. @@ -752,7 +765,7 @@ (declare (ignorable ,mark-value-sym ,syntax-value-sym ,form-sym ,operator-sym ,operands-sym)) (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) - (when ,form-sym (find-operand-info ,mark-value-sym ,syntax-value-sym ,form-sym)) + (when ,form-sym (find-operand-info ,syntax-value-sym ,mark-value-sym ,form-sym)) (declare (ignorable ,preceding-operand-sym ,operand-indices-sym)) ,@body))))

1 0

[climacs-cvs] CVS climacs
by thenriksen 09 Sep '06

09 Sep '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29556 Modified Files: rectangle.lisp Log Message: Fix regarding killing of rectangles across lines that are shorter than the width of the rectangle. --- /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/04 09:00:30 1.1 +++ /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/09 18:21:40 1.2 @@ -76,7 +76,9 @@ (let ((str (concatenate 'string (buffer-substring (buffer mark) (offset start-mark) (offset end-mark)) - (make-string (- endcol (column-number end-mark)) :initial-element #\Space)))) + (make-string (- (- endcol startcol) + (- (column-number end-mark) (column-number start-mark))) + :initial-element #\Space)))) (delete-range start-mark (- (offset end-mark) (offset start-mark))) str)))

1 0