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

[climacs-cvs] CVS climacs
by thenriksen 31 Aug '06

31 Aug '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv13041 Modified Files: pane.lisp Log Message: Fixed updating-output bug and added simplistic handling of long lines (a band-aid, really). --- /project/climacs/cvsroot/climacs/pane.lisp 2006/08/20 13:06:38 1.49 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/08/31 18:40:48 1.50 @@ -368,7 +368,7 @@ (updating-output (pane :unique-id (incf id) :id-test #'= :cache-value contents - :cache-test #'string=) + :cache-test #'equal) (present-contents contents pane))) (setf saved-index nil)))) (with-slots (bot scan cursor-x cursor-y) pane @@ -561,11 +561,8 @@ (defgeneric fix-pane-viewport (pane)) (defmethod fix-pane-viewport ((pane climacs-pane)) - (let* ((v (window-viewport pane)) - (x (rectangle-width v)) - (y (rectangle-height v))) - (resize-sheet pane x y) - (setf (window-viewport-position pane) (values 0 0)))) + (setf (window-viewport-position pane) (values 0 0)) + (change-space-requirements pane :min-width (bounding-rectangle-width (stream-current-output-record pane)))) (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax basic-syntax) current-p) @@ -582,9 +579,9 @@ (setf (full-redisplay-p pane) nil)) (adjust-cache pane)) (fill-cache pane) - (fix-pane-viewport pane) (update-syntax-for-display (buffer pane) (syntax (buffer pane)) (top pane) (bot pane)) - (redisplay-pane-with-syntax pane (syntax (buffer pane)) current-p)) + (redisplay-pane-with-syntax pane (syntax (buffer pane)) current-p) + (fix-pane-viewport pane)) (defgeneric full-redisplay (pane))

1 0

[climacs-cvs] CVS climacs
by thenriksen 30 Aug '06

30 Aug '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29488 Modified Files: lisp-syntax-swine.lisp Log Message: Improved the capabilities of `define-form-traits' and added more form trait definitions. --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/28 17:22:58 1.2 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/30 19:32:23 1.3 @@ -325,6 +325,17 @@ (case (first operator) ('cl:lambda (cleanup-arglist (second operator))))) +;; HACK ALERT: SBCL, and some implementations I guess, provides us +;; with an arglist that is too simple, confusing the code +;; analysers. We fix that here. +(defmethod arglist-for-form (syntax (operator (eql 'clim-lisp:defclass)) &optional arguments) + (declare (ignore arguments)) + '(name (&rest superclasses) (&rest slots) &rest options)) + +(defmethod arglist-for-form (syntax (operator (eql 'cl:defclass)) &optional arguments) + (declare (ignore arguments)) + '(name (&rest superclasses) (&rest slots) &rest options)) + (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 @@ -520,109 +531,166 @@ relevant-completions)) completions)))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defgeneric code-for-argument-type-completion (argument-type syntax-symbol token-symbol all-completions-symbol) - (:documentation "Generate completion code for an argument of - type `argument-type'.") - (:method (argument-type syntax-symbol token-symbol all-completions-symbol) - '(call-next-method))) - - (defgeneric code-for-argument-list-modification (argument-type syntax-symbol arglist-symbol arguments-symbol) - (:documentation "Generate argument list modification code for - a form having an argument of type `argument-type'.") - (:method (argument-type syntax-symbol arglist-symbol arguments-symbol))) - - (defmacro define-argument-type (name (&optional inherit-from) - &rest options) - (let ((completion-code (rest (assoc :completion options))) - (modification-code (rest (assoc :arglist-modification options)))) - `(progn - ,(if (or completion-code inherit-from) - `(defmethod code-for-argument-type-completion ((argument-type (eql ',name)) - ,@(if completion-code - (first completion-code) - '(syntax token))) - ,(if completion-code - `'(let ((,(third (first completion-code)) - (call-next-method))) - ,@(rest completion-code)) - (code-for-argument-type-completion inherit-from 'syntax 'token 'all-completions))) - (let ((method (find-method #'code-for-argument-type-completion nil `((eql ,name) t t t) nil))) - (when method - (remove-method #'code-for-argument-type-completion method)))) - ,(if (or modification-code inherit-from) - `(defmethod code-for-argument-list-modification ((argument-type (eql ',name)) - ,@(if modification-code - (first modification-code) - '(syntax arglist arguments))) - ,(if modification-code - `'(progn ,@(rest modification-code)) - `',(code-for-argument-list-modification inherit-from 'syntax 'arglist 'arguments))) - (let ((method (find-method #'code-for-argument-list-modification nil `((eql ,name) t t t) nil))) - (when method - (remove-method #'code-for-argument-list-modification method))))))) - - (define-argument-type class-name () - (:completion (syntax token all-completions) - (loop for completion in all-completions - when (find-class (ignore-errors (read-from-string (string-upcase completion))) - nil) - collect completion)) - (:arglist-modification (syntax arglist arguments) - (if (and (plusp (length arguments)) - (listp (first arguments)) - (> (length (first arguments)) 1) - (eq (caar arguments) 'cl:quote)) - (nconc arglist - (cons '&key (get-class-keyword-parameters - (get-usable-image syntax) - (first arguments))))))) - - (define-argument-type package-designator () - (:completion (syntax token all-completions) - (declare (ignore all-completions)) - (let* ((string (token-string syntax token)) - (keyworded (char= (aref string 0) #\:))) - (loop for package in (list-all-packages) - for package-name = (if keyworded - (concatenate 'string ":" (package-name package)) - (package-name package)) - when (search string package-name - :test #'char-equal - :end2 (min (length string) - (length package-name))) - collect (if (every #'upper-case-p string) - package-name - (string-downcase package-name))))))) - -(defmacro define-form-traits ((operator &rest arguments)) +(defgeneric complete-argument-of-type (argument-type syntax token all-completions) + (:documentation "") + (:method (argument-type syntax token all-completions) + all-completions)) + +(defgeneric modify-argument-list (argument-type syntax arglist arguments arg-position) + (:documentation "") + (:method (syntax argument-type arglist arguments arg-position) + arglist)) + +(defmacro define-argument-type (name (&optional inherit-from) + &rest options) + "Define an argument type for use in `define-form-traits'." + (let ((completion-code (rest (assoc :completion options))) + (modification-code (rest (assoc :arglist-modification options)))) + (assert (or (null completion-code) (= (length (first completion-code)) 3))) + (assert (or (null modification-code) (= (length (first modification-code)) 4))) + `(progn + ,(if (or completion-code inherit-from) + (let ((lambda-list (if completion-code + (first completion-code) + '(argument-type syntax token all-completions)))) + `(defmethod complete-argument-of-type ((argument-type (eql ',name)) + ,@lambda-list) + ,@(or (rest completion-code) + `((complete-argument-of-type ',inherit-from ,@lambda-list))))) + ;; If no completion rule has been specified for this + ;; type, we must check whether an earlier definition had + ;; completion rules - if so, remove the method + ;; implementing the rules. + `(let ((method (find-method #'complete-argument-of-type nil `((eql ,name) t t t) nil))) + (when method + (remove-method #'complete-argument-of-type method)))) + ,(if (or modification-code inherit-from) + (let ((lambda-list (if modification-code + (first modification-code) + '(syntax arglist arguments arg-position)))) + `(defmethod modify-argument-list ((argument-type (eql ',name)) + ,@lambda-list) + ,@(or (rest modification-code) + `((modify-argument-list ',inherit-from ,@lambda-list))))) + ;; If no arglist modification rule has been specified + ;; for this type, we must check whether an earlier + ;; definition had arglist modification rules - if so, + ;; remove the method implementing the rules. + `(let ((method (find-method #'modify-argument-list nil '((eql ,name) t t t t) nil))) + (when method + (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)) + (:arglist-modification (syntax arglist arguments arg-position) + (if (and (> (length arguments) arg-position) + (listp (elt arguments arg-position)) + (> (length (elt arguments arg-position)) 1) + (eq (first (elt arguments arg-position)) 'cl:quote) + (ignore-errors (find-class (second (elt arguments arg-position))))) + (nconc arglist + (cons '&key (get-class-keyword-parameters + (get-usable-image syntax) + (elt arguments arg-position)))) + arglist))) + +(define-argument-type package-designator () + (:completion (syntax token all-completions) + (declare (ignore all-completions)) + (let* ((string (token-string syntax token)) + (keyworded (char= (aref string 0) #\:))) + (loop for package in (list-all-packages) + for package-name = (if keyworded + (concatenate 'string ":" (package-name package)) + (package-name package)) + when (search string package-name + :test #'char-equal + :end2 (min (length string) + (length package-name))) + collect (if (every #'upper-case-p string) + package-name + (string-downcase package-name)))))) + +(defmacro define-form-traits ((operator &rest arguments) + &key no-typed-completion no-smart-arglist) + "Define \"traits\" for a form with the operator that is eql to +`operator'. Traits is a common designator for +intelligent (type-aware) completion and intelligent modification +of argument lists (for example, adding keyword arguments for the +initargs of the class being instantiated to the arglist of +`make-instance'). + +`Arguments' is a lambda-list-like list that describes the types +of the operands of `operator'. You can use the lambda-list +keywords `&rest' and `&key' to tie all, or specific keyword +arguments, to types. + +If `no-typed-completion' or `no-smart-arglist' is non-NIL, no +code for performing typed completion or smart arglist +modification will be generated, respectively." ;; FIXME: This macro should also define indentation rules. - (labels ((build-completions-codd-body (arguments) - (append (loop for argument in arguments - for i from 0 - collect `((and (= (first indices) ,i)) - ,(cond ((listp argument) - (if (eq (first argument) 'quote) - `(cond ((typep token 'quote-form) - ,(code-for-argument-type-completion (second argument) 'syntax 'token 'all-completions)) - (t (call-next-method))) - `(cond ((not (endp (rest indices))) - (pop indices) - (cond ,@(build-completions-codd-body argument))) - (t (call-next-method))))) - (t - (code-for-argument-type-completion argument 'syntax 'token 'all-completions))))) + (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. + `((t + (let* ((keyword (token-to-object syntax (form-before syntax (1- (start-offset token))))) + (type (getf ',arguments keyword))) + (if (null type) + (call-next-method) + (complete-argument-of-type type syntax token all-completions)))))) + (process-arg-descs (arguments index) + (let ((argument (first arguments))) + (cond ((null arguments) + nil) + ((eq argument '&rest) + `(((>= (first indices) ,index) + (complete-argument-of-type ',(second arguments) syntax token all-completions)))) + ((eq argument '&key) + (process-keyword-arg-descs (rest arguments))) + ((listp argument) + `(((= (first indices) ,index) + ,(if (eq (first argument) 'quote) + `(cond ((typep token 'quote-form) + (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))))))) + (t + (cons `((= (first indices) ,index) + (complete-argument-of-type ',argument syntax token 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) - (cond ,@(build-completions-codd-body arguments))) - (defmethod arglist-for-form (syntax (operator (eql ',operator)) &optional arguments) - (let ((arglist (call-next-method))) - ,@(mapcar #'(lambda (arg) - (code-for-argument-list-modification - (unlisted arg #'second) - 'syntax 'arglist 'arguments)) - arguments)))))) + ,(if no-typed-completion + '(call-next-method) + `(let ((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) + (declare (ignorable arguments)) + (let ((arglist (call-next-method)) + (arg-position 0)) + (declare (ignorable arg-position)) + ,@(loop for arg in arguments + collect `(setf arglist + (modify-argument-list + ',(unlisted arg #'second) + syntax arglist arguments arg-position)) + collect '(incf arg-position)) + arglist)))))) (defmacro with-code-insight (mark-or-offset syntax (&key operator preceding-operand form preceding-operand-indices @@ -670,15 +738,9 @@ (indices-match-arglist (arglist-for-form ,syntax-value-sym - (form-operator - form - ,syntax-value-sym) - (form-operands - form - ,syntax-value-sym)) - (second - (multiple-value-list - (find-operand-info ,mark-value-sym ,syntax-value-sym form)))) + (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)) @@ -699,9 +761,19 @@ ;;; Form trait definitions (define-form-traits (make-instance 'class-name)) +(define-form-traits (find-class 'class-name) + :no-smart-arglist t) +(define-form-traits (change-class t 'class-name)) (define-form-traits (make-pane 'class-name)) -(define-form-traits (find-class 'class-name)) +(define-form-traits (make-instances-obsolete 'class-name) + :no-smart-arglist t) +(define-form-traits (typep t 'class-name)) (define-form-traits (in-package package-designator)) +(define-form-traits (clim-lisp:defclass t (&rest class-name)) + :no-smart-arglist t) +(define-form-traits (cl:defclass t (&rest class-name)) + :no-smart-arglist t) +(define-form-traits (define-application-frame t (&rest class-name))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1026,7 +1098,7 @@ (t (when (and (needs-saving buffer) (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer)))) - (save-buffer buffer)) + (save-buffer buffer *application-frame*)) (let ((*read-base* (base (syntax buffer)))) (multiple-value-bind (result notes) (compile-file-for-climacs (get-usable-image (syntax buffer))

1 0

[climacs-cvs] CVS climacs
by thenriksen 28 Aug '06

28 Aug '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4717 Modified Files: base.lisp lisp-syntax-swine.lisp lisp-syntax.lisp Log Message: Reversed the meaning of list arguments to `as-offsets' for unification with `let', `with-accessors', etc. --- /project/climacs/cvsroot/climacs/base.lisp 2006/08/20 13:06:39 1.58 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/08/28 17:22:58 1.59 @@ -37,14 +37,14 @@ "Bind the symbols in `marks' to the numeric offsets of the mark objects that the symbols are bound to. If a symbol in `mark' is already bound to an offset, just keep that binding. An element - of `marks' may also be a list - in this case, the first element - is used to get an offset, and the second element (which should - be a symbol) will be bound to this offset. Evaluate `body' with - these bindings." + of `marks' may also be a list - in this case, the second + element is used to get an offset, and the first element (which + should be a symbol) will be bound to this offset. Evaluate + `body' with these bindings." `(let ,(mapcar #'(lambda (mark-sym) (if (listp mark-sym) - `(,(second mark-sym) - (let ((value ,(first mark-sym))) + `(,(first mark-sym) + (let ((value ,(second mark-sym))) (if (numberp value) value (offset value)))) --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/20 13:10:31 1.1 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/28 17:22:58 1.2 @@ -361,7 +361,7 @@ (defun find-operand-info (mark-or-offset syntax operator-form) "Returns two values: The operand preceding `mark-or-offset' and the path from `operator-form' to the operand." - (as-offsets ((mark-or-offset offset)) + (as-offsets ((offset mark-or-offset)) (let* ((preceding-arg-token (form-before syntax offset)) (indexing-start-arg (let* ((candidate-before preceding-arg-token) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/20 13:10:31 1.109 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/28 17:22:58 1.110 @@ -1349,7 +1349,7 @@ found, return the package specified in the attribute list. If no package can be found at all, or the otherwise found packages are invalid, return the CLIM-USER package." - (as-offsets ((mark-or-offset offset)) + (as-offsets ((offset mark-or-offset)) (let* ((designator (rest (find offset (package-list syntax) :key #'first :test #'>=)))) @@ -1370,7 +1370,7 @@ package specified in that form does not exist. If no (in-package) form can be found, return the package specified in the attribute list. If no such package is specified, return \"CLIM-USER\"." - (as-offsets ((mark-or-offset offset)) + (as-offsets ((offset mark-or-offset)) (flet ((normalise (designator) (typecase designator (symbol @@ -1595,7 +1595,7 @@ `mark-or-offset', the form preceding `mark-or-offset' is returned. Otherwise, the form following `mark-or-offset' is returned." - (as-offsets ((mark-or-offset offset)) + (as-offsets ((offset mark-or-offset)) (or (form-around syntax offset) (form-after syntax offset) (form-before syntax offset)))) @@ -1640,13 +1640,13 @@ (defun this-form (mark-or-offset syntax) "Return a form at `mark-or-offset'. This function defines which forms the COM-FOO-this commands affect." - (as-offsets ((mark-or-offset offset)) + (as-offsets ((offset mark-or-offset)) (or (form-around syntax offset) (form-before syntax offset)))) (defun preceding-form (mark-or-offset syntax) "Return a form at `mark-or-offset'." - (as-offsets ((mark-or-offset offset)) + (as-offsets ((offset mark-or-offset)) (or (form-before syntax offset) (form-around syntax offset))))

1 0

[climacs-cvs] CVS climacs
by thenriksen 20 Aug '06

20 Aug '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv924 Modified Files: lisp-syntax.lisp lisp-syntax-swank.lisp lisp-syntax-commands.lisp Added Files: lisp-syntax-swine.lisp Log Message: Big refactoring and enhancement patch for Lisp syntax. * New file added, lisp-syntax-swine.lisp, in order to keep the size of lisp-syntax.lisp down. * `define-form-traits' macro that can be used to teach Climacs how to intelligently handle certain forms (for example, only symbols naming classes will be completed from when using `make-instance' or `make-pane'). * Taught Climacs how to handle certain forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/11 21:59:05 1.108 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/20 13:10:31 1.109 @@ -28,9 +28,9 @@ ;;; ;;; Convenience functions and macros: -(defun unlisted (obj) +(defun unlisted (obj &optional (fn #'first)) (if (listp obj) - (first obj) + (funcall fn obj) obj)) (defun listed (obj) @@ -614,57 +614,66 @@ (t (fo) (make-instance 'delimiter-lexeme))))) (defun lex-token (syntax scan) - ;; May need more work. Can recognize symbols and numbers. - (flet ((fo () (forward-object scan))) - (let ((could-be-number t) - sign-seen dot-seen slash-seen nondot-seen) - (flet ((return-token-or-number-lexeme () - (return-from lex-token - (if could-be-number - (if nondot-seen - (make-instance 'number-lexeme) - (make-instance 'dot-lexeme)) - (make-instance 'complete-token-lexeme)))) - (this-object () - (object-after scan))) - (tagbody - START + ;; May need more work. Can recognize symbols and numbers. This can + ;; get very ugly and complicated (out of necessity I believe). + (let ((could-be-number t) + sign-seen dot-seen slash-seen nondot-seen number-seen exponent-seen) + (flet ((fo () (forward-object scan)) + (return-token-or-number-lexeme () + (return-from lex-token + (if (and could-be-number + (if exponent-seen + nondot-seen t)) + (if nondot-seen + (make-instance 'number-lexeme) + (make-instance 'dot-lexeme)) + (make-instance 'complete-token-lexeme)))) + (this-object () + (object-after scan))) + (tagbody + START + (when (end-of-buffer-p scan) + (return-token-or-number-lexeme)) + (when (constituentp (object-after scan)) + (when (not (eql (this-object) #\.)) + (setf nondot-seen t)) + (cond ((or (eql (this-object) #\+) + (eql (this-object) #\-)) + (when (or sign-seen number-seen slash-seen) + (setf could-be-number nil)) + (setf sign-seen t)) + ((eql (this-object) #\.) + (when (or dot-seen exponent-seen) + (setf could-be-number nil)) + (setf dot-seen t)) + ((member (this-object) + '(#\e #\f #\l #\s #\d) + :test #'equalp) + (when exponent-seen + (setf could-be-number nil)) + (setf exponent-seen t) + (setf number-seen nil) + (setf sign-seen nil)) + ((eql (this-object) #\/) + (when (or slash-seen dot-seen exponent-seen) + (setf could-be-number nil)) + (setf slash-seen t)) + ((not (digit-char-p (this-object) + (base syntax))) + (setf could-be-number nil)) + (t (setf number-seen t))) + (fo) + (go START)) + (when (eql (object-after scan) #\\) + (fo) (when (end-of-buffer-p scan) - (return-token-or-number-lexeme)) - (when (constituentp (object-after scan)) - (when (not (eql (this-object) #\.)) - (setf nondot-seen t)) - (cond ((or (eql (this-object) #\+) - (eql (this-object) #\-)) - (when sign-seen - (setf could-be-number nil)) - (setf sign-seen t)) - ((eql (this-object) #\.) - (when dot-seen - (setf could-be-number nil)) - (setf dot-seen t)) - ((eql (this-object) #\/) - (when slash-seen - (setf could-be-number nil)) - (setf slash-seen t)) - ;; We obey the base specified in the file when - ;; determining whether or not this character is an - ;; integer. - ((not (digit-char-p (this-object) - (base syntax))) - (setf could-be-number nil))) - (fo) - (go START)) - (when (eql (object-after scan) #\\) - (fo) - (when (end-of-buffer-p scan) - (return-from lex-token (make-instance 'incomplete-lexeme))) - (fo) - (go START)) - (when (eql (object-after scan) #\|) - (fo) - (return-from lex-token (make-instance 'multiple-escape-start-lexeme))) - (return-token-or-number-lexeme)))))) + (return-from lex-token (make-instance 'incomplete-lexeme))) + (fo) + (go START)) + (when (eql (object-after scan) #\|) + (fo) + (return-from lex-token (make-instance 'multiple-escape-start-lexeme))) + (return-token-or-number-lexeme))))) (defmethod lex ((syntax lisp-syntax) (state lexer-escaped-token-state) scan) (let ((bars-seen 0)) @@ -1380,7 +1389,7 @@ (defmacro with-syntax-package ((syntax offset) &body body) "Evaluate `body' with `*package*' bound to a valid package, - preferably taken from `syntax' based on `offset'.." + preferably taken from `syntax' based on `offset'." `(let ((*package* (package-at-mark ,syntax ,offset))) ,@body)) @@ -1555,10 +1564,9 @@ (:method (form syntax) nil)) (defmethod form-operands ((form list-form) syntax) - (mapcar #'(lambda (operand) - (if (typep operand 'form) - (token-to-object syntax operand :no-error t))) - (rest-forms (children form)))) + (loop for operand in (rest-forms (children form)) + when (typep operand 'form) + collect (token-to-object syntax operand :no-error t))) (defun form-toplevel (form syntax) "Return the top-level form of `form'." @@ -1588,9 +1596,9 @@ returned. Otherwise, the form following `mark-or-offset' is returned." (as-offsets ((mark-or-offset offset)) - (or (form-around syntax offset) - (form-after syntax offset) - (form-before syntax offset)))) + (or (form-around syntax offset) + (form-after syntax offset) + (form-before syntax offset)))) (defun definition-at-mark (mark-or-offset syntax) "Return the top-level form at `mark-or-offset'. If `mark-or-offset' is just after, @@ -1611,6 +1619,24 @@ form)))) (unwrap-form (expression-at-mark mark-or-offset syntax)))) +(defun fully-quoted-form (token) + "Return the top token object for `token', return `token' or the +top quote-form that `token' is buried in. " + (labels ((ascend (form) + (cond ((typep (parent form) 'quote-form) + (ascend (parent form))) + (t form)))) + (ascend token))) + +(defun fully-unquoted-form (token) + "Return the bottom token object for `token', return `token' or +the form that `token' quotes, peeling away all quote forms." + (labels ((descend (form) + (cond ((typep form 'quote-form) + (descend (first-form (children form)))) + (t form)))) + (descend token))) + (defun this-form (mark-or-offset syntax) "Return a form at `mark-or-offset'. This function defines which forms the COM-FOO-this commands affect." @@ -2597,7 +2623,7 @@ (if (null (cdr path)) ;; top level (let* ((arglist (when (fboundp symbol) - (arglist-for-form symbol))) + (arglist-for-form syntax symbol))) (body-or-rest-pos (or (position '&body arglist) (position '&rest arglist)))) (if (and (or (macro-function symbol) @@ -2609,7 +2635,7 @@ ;; &body arg. (values (elt-noncomment (children tree) 1) 1) ;; non-&body-arg. - (values (elt-noncomment (children tree) 1) 3)) + (values (elt-noncomment (children tree) 1) 1)) ;; normal form. (if (= (car path) 2) ;; indent like first child @@ -2867,1222 +2893,3 @@ (defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2) (line-uncomment-region syntax mark1 mark2)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Swine - -;;; Compiler note hyperlinking code - -(defun make-compiler-note (note-list) - (let ((severity (getf note-list :severity)) - (message (getf note-list :message)) - (location (getf note-list :location)) - (references (getf note-list :references)) - (short-message (getf note-list :short-message))) - (make-instance - (ecase severity - (:error 'error-compiler-note) - (:read-error 'read-error-compiler-note) - (:warning 'warning-compiler-note) - (:style-warning 'style-warning-compiler-note) - (:note 'note-compiler-note)) - :message message :location location - :references references :short-message short-message))) - -(defclass compiler-note () - ((message :initarg :message :initform nil :accessor message) - (location :initarg :location :initform nil :accessor location) - (references :initarg :references :initform nil :accessor references) - (short-message :initarg :short-message :initform nil :accessor short-message)) - (:documentation "The base for all compiler-notes.")) - -(defclass error-compiler-note (compiler-note) ()) - -(defclass read-error-compiler-note (compiler-note) ()) - -(defclass warning-compiler-note (compiler-note) ()) - -(defclass style-warning-compiler-note (compiler-note) ()) - -(defclass note-compiler-note (compiler-note) ()) - -(defclass location ()() - (:documentation "The base for all locations.")) - -(defclass error-location (location) - ((error-message :initarg :error-message :accessor error-message))) - -(defclass actual-location (location) - ((source-position :initarg :position :accessor source-position) - (snippet :initarg :snippet :accessor snippet :initform nil)) - (:documentation "The base for all non-error locations.")) - -(defclass buffer-location (actual-location) - ((buffer-name :initarg :buffer :accessor buffer-name))) - -(defclass file-location (actual-location) - ((file-name :initarg :file :accessor file-name))) - -(defclass source-location (actual-location) - ((source-form :initarg :source-form :accessor source-form))) - -(defclass basic-position () () - (:documentation "The base for all positions.")) - -(defclass char-position (basic-position) - ((char-position :initarg :position :accessor char-position) - (align-p :initarg :align-p :initform nil :accessor align-p))) - -(defun make-char-position (position-list) - (make-instance 'char-position :position (second position-list) - :align-p (third position-list))) - -(defclass line-position (basic-position) - ((start-line :initarg :line :accessor start-line) - (end-line :initarg :end-line :initform nil :accessor end-line))) - -(defun make-line-position (position-list) - (make-instance 'line-position :line (second position-list) - :end-line (third position-list))) - -(defclass function-name-position (basic-position) - ((function-name :initarg :function-name))) - -(defun make-function-name-position (position-list) - (make-instance 'function-name-position :function-name (second position-list))) - -(defclass source-path-position (basic-position) - ((path :initarg :source-path :accessor path) - (start-position :initarg :start-position :accessor start-position))) - -(defun make-source-path-position (position-list) - (make-instance 'source-path-position :source-path (second position-list) - :start-position (third position-list))) - -(defclass text-anchored-position (basic-position) - ((start :initarg :text-anchored :accessor start) - (text :initarg :text :accessor text) - (delta :initarg :delta :accessor delta))) - -(defun make-text-anchored-position (position-list) - (make-instance 'text-anchored-position :text-anchored (second position-list) - :text (third position-list) - :delta (fourth position-list))) - -(defclass method-position (basic-position) - ((name :initarg :method :accessor name) - (specializers :initarg :specializers :accessor specializers) - (qualifiers :initarg :qualifiers :accessor qualifiers))) - -(defun make-method-position (position-list) - (make-instance 'method-position :method (second position-list) - :specializers (third position-list) - :qualifiers (last position-list))) - -(defun make-location (location-list) - (ecase (first location-list) - (:error (make-instance 'error-location :error-message (second location-list))) - (:location - (destructuring-bind (l buf pos hints) location-list - (declare (ignore l)) - (let ((location - (apply #'make-instance - (ecase (first buf) - (:file 'file-location) - (:buffer 'buffer-location) - (:source-form 'source-location)) - buf)) - (position - (funcall - (ecase (first pos) - (:position #'make-char-position) - (:line #'make-line-position) - (:function-name #'make-function-name-position) - (:source-path #'make-source-path-position) - (:text-anchored #'make-text-anchored-position) - (:method #'make-method-position)) - pos))) - (setf (source-position location) position) - (when hints - (setf (snippet location) (rest hints))) - location))))) - -(defmethod initialize-instance :after ((note compiler-note) &rest args) - (declare (ignore args)) - (setf (location note) (make-location (location note)))) - -(defun show-note-counts (notes &optional seconds) - (loop with nerrors = 0 - with nwarnings = 0 - with nstyle-warnings = 0 - with nnotes = 0 - for note in notes - do (etypecase note - (error-compiler-note (incf nerrors)) - (read-error-compiler-note (incf nerrors)) - (warning-compiler-note (incf nwarnings)) - (style-warning-compiler-note (incf nstyle-warnings)) - (note-compiler-note (incf nnotes))) - finally - (esa:display-message "Compilation finished: ~D error~:P ~ - ~D warning~:P ~D style-warning~:P ~D note~:P ~ - ~@[[~D secs]~]" - nerrors nwarnings nstyle-warnings nnotes seconds))) - -(defun one-line-ify (string) - "Return a single-line version of STRING. -Each newline and following whitespace is replaced by a single space." - (loop with count = 0 - while (< count (length string)) - with new-string = (make-array 0 :element-type 'character :adjustable t - :fill-pointer 0) - when (char= (char string count) #\Newline) - do (loop while (and (< count (length string)) - (whitespacep nil (char string count))) - do (incf count) - ;; Just ignore whitespace if it is last in the - ;; string. - finally (when (< count (length string)) - (vector-push-extend #\Space new-string))) - else - do (vector-push-extend (char string count) new-string) - (incf count) - finally (return new-string))) - -(defgeneric print-for-menu (object stream)) - -(defun print-note-for-menu (note stream severity ink) [1033 lines skipped] --- /project/climacs/cvsroot/climacs/lisp-syntax-swank.lisp 2006/07/05 13:52:17 1.1 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swank.lisp 2006/08/20 13:10:31 1.2 @@ -47,7 +47,7 @@ (handler-case (asdf:oos 'asdf:load-op :swank) (asdf:missing-component () (esa:display-message "Swank not available."))))) - (setf (image (syntax (current-buffer))) + (setf (image (syntax (current-buffer *application-frame*))) (make-instance 'swank-local-image))) (defmethod compile-string-for-climacs ((image swank-local-image) string package buffer buffer-mark) --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/08/11 21:59:05 1.15 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/08/20 13:10:31 1.16 @@ -88,13 +88,13 @@ (define-command (com-set-base :name t :command-table lisp-table) ((base '(integer 2 36))) "Set the base for the current buffer." - (setf (base (syntax (current-buffer))) + (setf (base (syntax (current-buffer *application-frame*))) base)) (define-command (com-set-package :name t :command-table lisp-table) ((package 'package)) "Set the package for the current buffer." - (setf (option-specified-package (syntax (current-buffer))) + (setf (option-specified-package (syntax (current-buffer *application-frame*))) package)) (define-command (com-indent-expression :name t :command-table lisp-table) --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/20 13:10:31 NONE +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/20 13:10:31 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-LISP-SYNTAX -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; (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. ;;; Functionality designed to aid development of Common Lisp code. (in-package :climacs-lisp-syntax) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Code interrogation/form analysis (defparameter +cl-arglist-keywords+ lambda-list-keywords) (defparameter +cl-garbage-keywords+ '(&whole &environment)) (defun arglist-keyword-p (arg) "Return T if `arg' is an arglist keyword. NIL otherwise." (when (member arg +cl-arglist-keywords+) t)) (defun split-arglist-on-keywords (arglist) "Return an alist keying lambda list keywords of `arglist' to the symbols affected by the keywords." (let ((sing-result '()) (env (position '&environment arglist))) (when env (push (list '&environment (elt arglist (1+ env))) sing-result) (setf arglist (remove-if (constantly t) arglist :start env :end (+ env 2)))) (when (eq '&whole (first arglist)) (push (subseq arglist 0 2) sing-result) (setf arglist (cddr arglist))) (do ((llk '(&mandatory &optional &key &allow-other-keys &aux &rest &body)) (args (if (arglist-keyword-p (first arglist)) arglist (cons '&mandatory arglist)) (cdr args)) (chunk '()) (result '())) ((null args) (when chunk (push (nreverse chunk) result)) (nreverse (nconc sing-result result))) (if (member (car args) llk) (progn (when chunk (push (nreverse chunk) result)) (setf chunk (list (car args)))) (push (car args) chunk))))) (defun find-optional-argument-values (arglist provided-args &optional (split-arglist (split-arglist-on-keywords arglist))) "Return an association list mapping symbols of optional or keyword arguments from `arglist' to the specified values in `provided-args'. `Split-arglist' should be either a split arglist or nil, in which case it will be calculated from `arglist'." (flet ((get-args (keyword) (rest (assoc keyword split-arglist)))) (let* ((mandatory-args-count (length (get-args '&mandatory))) (optional-args-count (length (get-args '&optional))) (keyword-args-count (length (get-args '&key))) (provided-args-count (length provided-args)) (nonmandatory-args-count (+ keyword-args-count optional-args-count))) ;; First we check whether any optional arguments have even been ;; provided. (when (> provided-args-count mandatory-args-count) ;; We have optional arguments. (let ( ;; Find the part of the provided arguments that concern ;; optional arguments. (opt-args-values (subseq provided-args mandatory-args-count (min provided-args-count nonmandatory-args-count))) ;; Find the part of the provided arguments that concern ;; keyword arguments. (keyword-args-values (subseq provided-args (min (+ mandatory-args-count optional-args-count) provided-args-count)))) (append (mapcar #'cons (mapcar #'unlisted (get-args '&optional)) opt-args-values) (loop ;; Loop over the provided keyword symbols and ;; values in the argument list. Note that ;; little checking is done to ensure that the ;; given symbols are valid - this is not a ;; compiler, so extra mappings do not ;; matter. for (keyword value) on keyword-args-values by #'cddr if (keywordp keyword) collect (let ((argument-symbol (unlisted (find (symbol-name keyword) (get-args '&key) :key #'(lambda (arg) (symbol-name (unlisted arg))) :test #'string=)))) ;; We have to find the associated ;; symbol in the argument list... ugly. (cons argument-symbol value))))))))) (defun find-affected-simple-arguments (arglist current-arg-index preceding-arg &optional (split-arglist (split-arglist-on-keywords arglist))) "Find the simple arguments of `arglist' that would be affected if an argument was intered at index `current-arg-index' in the arglist. If `current-arg-index' is nil, no calculation will be done (this function will just return nil). `Preceding-arg' should either be nil or the argument directly preceding point. `Split-arglist' should either be a split arglist or nil, in which case `split-arglist' will be computed from `arglist'. This function returns two values: The primary value is a list of symbols that should be emphasized, the secondary value is a list of symbols that should be highlighted." (when current-arg-index (flet ((get-args (keyword) (rest (assoc keyword split-arglist)))) (let ((mandatory-argument-count (length (get-args '&mandatory)))) (cond ((> mandatory-argument-count current-arg-index) ;; We are in the main, mandatory, positional arguments. (let ((relevant-arg (elt (get-args '&mandatory) current-arg-index))) ;; We do not handle complex argument lists here, only ;; pure standard arguments. (unless (and (listp relevant-arg) (< current-arg-index mandatory-argument-count)) (values nil (list (unlisted relevant-arg)))))) ((> (+ (length (get-args '&optional)) (length (get-args '&mandatory))) current-arg-index) ;; We are in the &optional arguments. (values nil (list (unlisted (elt (get-args '&optional) (- current-arg-index (length (get-args '&mandatory)))))))) (t (let ((body-or-rest-args (or (get-args '&rest) (get-args '&body))) (key-arg (find (format nil "~A" preceding-arg) (get-args '&key) :test #'string= :key #'(lambda (arg) (symbol-name (unlisted arg)))))) ;; We are in the &body, &rest or &key arguments. (values ;; Only emphasize the &key ;; symbol if we are in a position to add a new ;; keyword-value pair, and not just in a position to ;; specify a value for a keyword. (when (and (null key-arg) (get-args '&key)) '(&key)) (append (when key-arg (list (unlisted key-arg))) body-or-rest-args))))))))) (defun analyze-arglist-impl (arglist current-arg-indices preceding-arg provided-args) "The implementation for `analyze-arglist'." (let* ((split-arglist (split-arglist-on-keywords arglist)) (user-supplied-arg-values (find-optional-argument-values arglist provided-args split-arglist)) (mandatory-argument-count (length (rest (assoc '&mandatory split-arglist)))) (current-arg-index (or (first current-arg-indices) 0)) ret-arglist emphasized-symbols highlighted-symbols) ;; First, we find any standard arguments that should be ;; highlighted or emphasized, more complex, destructuring ;; arguments will be handled specially. (multiple-value-bind (es hs) (find-affected-simple-arguments arglist ;; If `current-arg-indices' is ;; nil, that means that we do ;; not have enough information ;; to properly highlight ;; symbols in the arglist. (and current-arg-indices current-arg-index) preceding-arg split-arglist) (setf emphasized-symbols es) (setf highlighted-symbols hs)) ;; We loop over the arglist and build a new list, and if we have a ;; default value for a given argument, we insert it into the ;; list. Also, whenever we encounter a list in a mandatory ;; argument position, we assume that it is a destructuring arglist ;; and recursively call `analyze-arglist' on it to find the ;; arglist and emphasized and highlighted symbols for it. (labels ((generate-arglist (arglist) (loop for arg-element in arglist for arg-name = (unlisted arg-element) for index from 0 if (and (listp arg-element) (> mandatory-argument-count index)) collect (multiple-value-bind (arglist sublist-emphasized-symbols sublist-highlighted-symbols) (analyze-arglist arg-element (rest current-arg-indices) preceding-arg (when (< index (length provided-args)) (listed (elt provided-args index)))) ;; Unless our `current-arg-index' ;; actually refers to this sublist, its ;; highlighted and emphasized symbols ;; are ignored. Also, if ;; `current-arg-indices' is nil, we do ;; not have enough information to ;; properly highlight symbols in the ;; arglist. (when (and current-arg-indices (= index current-arg-index)) (if (and (rest current-arg-indices)) (setf emphasized-symbols (union (mapcar #'unlisted sublist-emphasized-symbols) emphasized-symbols) highlighted-symbols (union sublist-highlighted-symbols highlighted-symbols)) (setf emphasized-symbols (union (mapcar #'unlisted arg-element) emphasized-symbols)))) arglist) else if (assoc arg-name user-supplied-arg-values) collect (list arg-name (rest (assoc arg-name user-supplied-arg-values))) else collect arg-element))) (setf ret-arglist (generate-arglist arglist))) (list ret-arglist emphasized-symbols highlighted-symbols))) (defun analyze-arglist (arglist current-arg-indices preceding-arg provided-args) "Analyze argument list and provide information for highlighting it. `Arglist' is the argument list that is to be analyzed, `current-arg-index' is the index where the next argument would be written (0 is just after the operator), `preceding-arg' is the written argument preceding point and `provided-args' is a list of the args already written. Three values are returned: * An argument list with values for &optional and &key arguments inserted from `provided-args'. * A list of symbols that should be emphasized. * A list of symbols that should be highlighted." (apply #'values (analyze-arglist-impl arglist current-arg-indices preceding-arg provided-args))) (defun cleanup-arglist (arglist) "Remove elements of `arglist' that we are not interested in." (loop for arg in arglist with in-&aux ; If non-NIL, we are in the ; &aux parameters that should ; not be displayed. with in-garbage ; If non-NIL, the next ; argument is a garbage ; parameter that should not be ; displayed. if in-garbage do (setf in-garbage nil) else if (not in-&aux) if (eq arg '&aux) do (setf in-&aux t) else if (member arg +cl-garbage-keywords+ :test #'eq) do (setf in-garbage t) else collect arg)) (defgeneric arglist-for-form (syntax operator &optional arguments) (:documentation "Return an arglist for `operator'") (:method (syntax operator &optional arguments) (declare (ignore arguments)) (cleanup-arglist (arglist (get-usable-image syntax) operator)))) (defmethod arglist-for-form (syntax (operator list) &optional arguments) (declare (ignore arguments)) (case (first operator) ('cl:lambda (cleanup-arglist (second operator))))) (defun find-argument-indices-for-operand (syntax operand-form operator-form) "Return a list of argument indices for `argument-form' relative to `operator-form'. These lists take the form of (n m p), which means (aref form-operand-list n m p). A list of argument indices can have arbitrary length (but they are practically always at most 2 elements long). " (declare (ignore syntax)) (let ((operator (first-form (children operator-form)))) (labels ((worker (operand-form &optional the-first) ;; Cannot find index for top-level-form. (when (parent operand-form) (let ((form-operand-list (remove-if #'(lambda (form) (or (not (typep form 'form)) (eq form operator))) (children (parent operand-form))))) (let ((operand-position (position operand-form form-operand-list)) (go-on (not (eq operator-form (parent operand-form))))) ;; If we find anything, we have to increment the ;; position by 1, since we consider the existance ;; of a first operand to mean point is at operand ;; 2. Likewise, a position of nil is interpreted ;; as 0. (cons (if operand-position (if (or the-first) (1+ operand-position) operand-position) 0) (when go-on (worker (parent operand-form))))))))) (nreverse (worker operand-form t))))) (defun find-operand-info (mark-or-offset syntax operator-form) "Returns two values: The operand preceding `mark-or-offset' and the path from `operator-form' to the operand." (as-offsets ((mark-or-offset offset)) (let* ((preceding-arg-token (form-before syntax offset)) (indexing-start-arg (let* ((candidate-before preceding-arg-token) (candidate-after (when (null candidate-before) (let ((after (form-after syntax offset))) (when after (parent after))))) (candidate-around (when (null candidate-after) (form-around syntax offset))) (candidate (or candidate-before candidate-after candidate-around))) (if (or (and candidate-before (typep candidate-before 'incomplete-list-form)) (and (null candidate-before) (typep (or candidate-after candidate-around) 'list-form))) ;; HACK: We should not attempt to find the location of [971 lines skipped]

1 0

[climacs-cvs] CVS climacs
by thenriksen 20 Aug '06

20 Aug '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv721 Modified Files: search-commands.lisp prolog2paiprolog.lisp pane.lisp packages.lisp misc-commands.lisp io.lisp gui.lisp file-commands.lisp core.lisp climacs.asd base.lisp Log Message: Changed Climacs to use the ESA-IO and ESA-BUFFER functionality instead of duplicating essentially the same code across multiple projects. This is rather invasive as some of the ESA functions have a subtly different signature. --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/27 10:39:32 1.12 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/08/20 13:06:38 1.13 @@ -168,7 +168,7 @@ (isearch-from-mark pane mark string forwardp)))) (define-command (com-isearch-append-word :name t :command-table isearch-climacs-table) () - (let ((syntax (syntax (current-buffer)))) + (let ((syntax (syntax (current-buffer *application-frame*)))) (isearch-append-text #'(lambda (mark) (forward-word mark syntax))))) --- /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp 2005/11/23 17:39:28 1.1 +++ /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp 2006/08/20 13:06:38 1.2 @@ -44,7 +44,7 @@ (let ((buffer (make-instance 'prolog-buffer))) (when (probe-file filepath) (with-open-file (stream filepath :direction :input) - (input-from-stream stream buffer 0))) + (save-buffer-to-stream stream buffer))) (setf (filepath buffer) filepath (offset (low-mark buffer)) 0 (offset (high-mark buffer)) (size buffer)) --- /project/climacs/cvsroot/climacs/pane.lisp 2006/08/20 10:29:17 1.48 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/08/20 13:06:38 1.49 @@ -237,11 +237,6 @@ (defparameter +climacs-textual-view+ (make-instance 'climacs-textual-view)) -(defclass file-mixin () - ((filepath :initform nil :accessor filepath) - (file-saved-p :initform nil :accessor file-saved-p) - (file-write-time :initform nil :accessor file-write-time))) - ;(defgeneric indent-tabs-mode (climacs-buffer)) (defclass extended-standard-buffer (read-only-mixin standard-buffer undo-mixin abbrev-mixin) () @@ -250,7 +245,7 @@ (defclass extended-binseq2-buffer (read-only-mixin binseq2-buffer p-undo-mixin abbrev-mixin) () (:documentation "Extensions accessible via marks.")) -(defclass climacs-buffer (delegating-buffer file-mixin name-mixin) +(defclass climacs-buffer (delegating-buffer esa-buffer-mixin) ((needs-saving :initform nil :accessor needs-saving) (syntax :accessor syntax) (point :initform nil :initarg :point :accessor point) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/08/11 21:59:05 1.111 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/08/20 13:06:38 1.112 @@ -76,7 +76,7 @@ (:documentation "An implementation of a kill ring.")) (defpackage :climacs-base - (:use :clim-lisp :climacs-buffer :climacs-kill-ring) + (:use :clim-lisp :climacs-buffer :climacs-kill-ring :esa-buffer) (:export #:as-offsets #:do-buffer-region #:do-buffer-region-lines @@ -91,7 +91,6 @@ #:just-n-spaces #:buffer-whitespacep #:buffer-region-case - #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-looking-at #:looking-at #:buffer-search-forward #:buffer-search-backward @@ -171,7 +170,7 @@ (defpackage :climacs-pane (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev - :climacs-syntax :flexichain :undo) + :climacs-syntax :flexichain :undo :esa-buffer :esa-io) (:export #:climacs-buffer #:needs-saving #:filepath #:file-saved-p #:file-write-time #:read-only-p #:buffer-read-only @@ -316,7 +315,7 @@ (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax :climacs-motion :climacs-kill-ring :climacs-pane :clim-extensions - :undo :esa :climacs-editing :climacs-motion) + :undo :esa :climacs-editing :climacs-motion :esa-buffer :esa-io) ;;(:import-from :lisp-string) (:export #:climacs ; Frame. @@ -370,7 +369,7 @@ (defpackage :climacs-core (:use :clim-lisp :climacs-base :climacs-buffer :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring - :climacs-editing :climacs-gui :clim :climacs-abbrev :esa) + :climacs-editing :climacs-gui :clim :climacs-abbrev :esa :esa-buffer :esa-io) (:export #:display-string #:object-equal #:object= @@ -397,7 +396,8 @@ #:set-syntax #:switch-to-buffer - #:make-buffer + #:make-new-buffer + #:make-new-named-buffer #:erase-buffer #:kill-buffer @@ -405,11 +405,15 @@ #:update-attribute-line #:evaluate-attribute-line #:directory-pathname-p - #:find-file + #:find-file #:find-file-read-only #:directory-of-buffer - #:set-visited-file-name + #:set-visited-filename #:check-file-times - #:save-buffer) + #:save-buffer + + #:input-from-stream + #:save-buffer-to-stream + #:make-buffer-from-stream) (:documentation "Package for editor functionality that is syntax-aware, but yet not specific to certain syntaxes. Contains stuff like indentation, filling and other @@ -439,7 +443,7 @@ (defpackage :climacs-prolog-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane) + :climacs-syntax :flexichain :climacs-pane :climacs-core) (:shadow #:atom #:close #:exp #:integer #:open #:variable)) (defpackage :climacs-cl-syntax --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/27 19:55:26 1.21 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/08/20 13:06:39 1.22 @@ -255,8 +255,8 @@ (let* ((pane (current-window)) (point (point pane))) (insert-object point #\Newline) - (update-syntax (current-buffer) - (syntax (current-buffer))) + (update-syntax (current-buffer *application-frame*) + (syntax (current-buffer *application-frame*))) (indent-current-line pane point))) (set-key 'com-newline-and-indent @@ -453,7 +453,7 @@ :prompt "Name of syntax")) "Prompts for a syntax to set for the current buffer. Setting a syntax will cause the buffer to be reparsed using the new syntax." - (set-syntax (current-buffer) syntax)) + (set-syntax (current-buffer *application-frame*) syntax)) ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands --- /project/climacs/cvsroot/climacs/io.lisp 2006/03/03 19:38:57 1.4 +++ /project/climacs/cvsroot/climacs/io.lisp 2006/08/20 13:06:39 1.5 @@ -1,7 +1,9 @@ -;;; -*- Mode: Lisp; Package: CLIMACS-BUFFER -*- +;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*- ;;; (c) copyright 2004 by ;;; Robert Strandh (strandh(a)labri.fr) +;;; (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 @@ -20,20 +22,23 @@ ;;; Input/Output of buffers to and from streams. -(in-package :climacs-base) +(in-package :climacs-core) + +(defmethod save-buffer-to-stream ((buffer climacs-buffer) stream) + (let ((seq (buffer-sequence buffer 0 (size buffer)))) + (write-sequence seq stream))) (defun input-from-stream (stream buffer offset) - (loop with vec = (make-array 10000 :element-type 'character) - for count = (#+mcclim read-sequence #-mcclim cl:read-sequence - vec stream) - while (plusp count) - do (if (= count (length vec)) - (insert-buffer-sequence buffer offset vec) - (insert-buffer-sequence buffer offset - (subseq vec 0 count))) - (incf offset count))) - -(defun output-to-stream (stream buffer offset1 offset2) - (loop for offset from offset1 below offset2 - when (characterp (buffer-object buffer offset)) - do (write-char (buffer-object buffer offset) stream))) + (let* ((seq (make-string (file-length stream))) + (count (#+mcclim read-sequence #-mcclim cl:read-sequence + seq stream))) + (if (= count (length seq)) + (insert-buffer-sequence buffer offset + (if (= count (length seq)) + seq + (subseq seq 0 count)))))) + +(defmethod make-buffer-from-stream (stream (application-frame climacs)) + (let* ((buffer (make-new-buffer application-frame))) + (input-from-stream stream buffer 0) + buffer)) --- /project/climacs/cvsroot/climacs/gui.lisp 2006/08/11 21:59:05 1.227 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/08/20 13:06:39 1.228 @@ -133,6 +133,7 @@ (kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring)) (:command-table (global-climacs-table :inherit-from (global-esa-table + esa-io-table keyboard-macro-table climacs-help-table base-table @@ -201,9 +202,9 @@ "Return the current panes point." (point (current-window))) -(defun current-buffer () +(defmethod current-buffer ((application-frame climacs)) "Return the current buffer." - (buffer (current-window))) + (buffer (car (windows application-frame)))) (define-presentation-type read-only ()) (define-presentation-method highlight-presentation --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/08/01 16:06:37 1.23 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/08/20 13:06:39 1.24 @@ -24,7 +24,9 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; File (and buffer) commands for the Climacs editor. +;;; File (and buffer) commands for the Climacs editor. Note that many +;;; basic commands (such as Find File) are defined in ESA and made +;;; available to Climacs via the ESA-IO-TABLE command table. (in-package :climacs-commands) @@ -151,52 +153,6 @@ (update-attribute-line (buffer (current-window))) (evaluate-attribute-line (buffer (current-window)))) -(define-command (com-find-file :name t :command-table buffer-table) - ((filepath 'pathname - :prompt "Find File" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t)) - "Prompt for a filename then edit that file. -If a buffer is already visiting that file, switch to that buffer. Does not create a file if the filename given does not name an existing file." - (find-file filepath)) - -(set-key `(com-find-file ,*unsupplied-argument-marker*) - 'buffer-table - '((#\x :control) (#\f :control))) - -(define-command (com-find-file-read-only :name t :command-table buffer-table) - ((filepath 'pathname :Prompt "Find file read only" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t)) - "Prompt for a filename then open that file readonly. -If a buffer is already visiting that file, switch to that buffer. If the filename given does not name an existing file, signal an error." - (find-file filepath t)) - -(set-key `(com-find-file-read-only ,*unsupplied-argument-marker*) - 'buffer-table - '((#\x :control) (#\r :control))) - -(define-command (com-read-only :name t :command-table buffer-table) () - "Toggle the readonly status of the current buffer. -When a buffer is readonly, attempts to change the contents of the buffer signal an error." - (let ((buffer (buffer (current-window)))) - (setf (read-only-p buffer) (not (read-only-p buffer))))) - -(set-key 'com-read-only - 'buffer-table - '((#\x :control) (#\q :control))) - -(define-command (com-set-visited-file-name :name t :command-table buffer-table) - ((filename 'pathname :prompt "New file name" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t)) - "Prompt for a new filename for the current buffer. -The next time the buffer is saved it will be saved to a file with that filename." - (set-visited-file-name filename (buffer (current-window)))) - (define-command (com-insert-file :name t :command-table buffer-table) ((filename 'pathname :prompt "Insert File" :default (directory-of-buffer (buffer (current-window))) @@ -243,42 +199,6 @@ (display-message "No file ~A" filepath) (beep)))))) -(define-command (com-save-buffer :name t :command-table buffer-table) () - "Write the contents of the buffer to a file. -If there is filename associated with the buffer, write to that file, replacing its contents. If not, prompt for a filename." - (let ((buffer (buffer (current-window)))) - (if (or (null (filepath buffer)) - (needs-saving buffer)) - (save-buffer buffer) - (display-message "No changes need to be saved from ~a" (name buffer))))) - -(set-key 'com-save-buffer - 'buffer-table - '((#\x :control) (#\s :control))) - -(define-command (com-write-buffer :name t :command-table buffer-table) - ((filepath 'pathname :prompt "Write Buffer to File" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t)) - "Prompt for a filename and write the current buffer to it. -Changes the file visted by the buffer to the given file." - (let ((buffer (buffer (current-window)))) - (cond - ((directory-pathname-p filepath) - (display-message "~A is a directory name." filepath)) - (t - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (output-to-stream stream buffer 0 (size buffer))) - (setf (filepath buffer) filepath - (name buffer) (filepath-filename filepath) - (needs-saving buffer) nil) - (display-message "Wrote: ~a" (filepath buffer)))))) - -(set-key `(com-write-buffer ,*unsupplied-argument-marker*) - 'buffer-table - '((#\x :control) (#\w :control))) - (defun load-file (file-name) (cond ((directory-pathname-p file-name) (display-message "~A is a directory name." file-name) @@ -334,7 +254,7 @@ '((#\x :control) (#\k))) (define-command (com-toggle-read-only :name t :command-table base-table) - ((buffer 'buffer :default (current-buffer))) + ((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 @@ -344,7 +264,7 @@ (list object)) (define-command (com-toggle-modified :name t :command-table base-table) - ((buffer 'buffer :default (current-buffer))) + ((buffer 'buffer :default (current-buffer *application-frame*))) (setf (needs-saving buffer) (not (needs-saving buffer)))) (define-presentation-to-command-translator toggle-modified --- /project/climacs/cvsroot/climacs/core.lisp 2006/08/11 18:49:48 1.4 +++ /project/climacs/cvsroot/climacs/core.lisp 2006/08/20 13:06:39 1.5 @@ -336,10 +336,14 @@ ;;; ;;; Buffer handling -(defun make-buffer (&optional name) +(defmethod make-new-buffer ((application-frame climacs)) (let ((buffer (make-instance 'climacs-buffer))) + (push buffer (buffers application-frame)) + buffer)) + +(defun make-new-named-buffer (&optional name) + (let ((buffer (make-new-buffer *application-frame*))) (when name (setf (name buffer) name)) - (push buffer (buffers *application-frame*)) buffer)) (defgeneric erase-buffer (buffer)) @@ -399,7 +403,7 @@ (let ((buffer (find name (buffers *application-frame*) :key #'name :test #'string=))) (switch-to-buffer (or buffer - (make-buffer name))))) + (make-new-named-buffer name))))) ;;placeholder (defmethod switch-to-buffer ((symbol (eql 'nil))) @@ -422,11 +426,11 @@ (error () (progn (beep) (display-message "Invalid answer") (return-from kill-buffer nil))))) - (save-buffer buffer)) + (save-buffer buffer *application-frame*)) (setf buffers (remove buffer buffers)) ;; Always need one buffer. (when (null buffers) - (make-buffer "*scratch*")) + (make-new-named-buffer "*scratch*")) (setf (buffer (current-window)) (car buffers)) (full-redisplay (current-window)) (buffer (current-window)))) @@ -594,7 +598,7 @@ (and (or (null name) (eql name :unspecific)) (or (null type) (eql type :unspecific))))) -(defun find-file (filepath &optional readonlyp) +(defun find-file-impl (filepath &optional readonlyp) (cond ((null filepath) (display-message "No file name given.") (beep)) @@ -603,9 +607,9 @@ (beep)) (t (flet ((usable-pathname (pathname) - (if (probe-file pathname) - (truename pathname) - pathname))) + (if (probe-file pathname) + (truename pathname) + pathname))) (let ((existing-buffer (find filepath (buffers *application-frame*) :key #'filepath :test #'(lambda (fp1 fp2) @@ -619,36 +623,36 @@ (unless (probe-file filepath) (beep) (display-message "No such file: ~A" filepath) - (return-from find-file nil))) - (let ((buffer (make-buffer)) + (return-from find-file-impl nil))) + (let ((buffer (if (probe-file filepath) + (with-open-file (stream filepath :direction :input) + (make-buffer-from-stream stream *application-frame*)) + (make-new-buffer *application-frame*))) (pane (current-window))) ;; Clear the pane's cache; otherwise residue from the ;; previously displayed buffer may under certain ;; circumstances be displayed. (clear-cache pane) - (setf (syntax buffer) nil) - (setf (offset (point (buffer pane))) (offset (point pane))) - (setf (buffer (current-window)) buffer) - (setf (syntax buffer) - (make-instance (syntax-class-name-for-filepath filepath) - :buffer buffer)) - ;; Don't want to create the file if it doesn't exist. - (when (probe-file filepath) - (with-open-file (stream filepath :direction :input) - (input-from-stream stream buffer 0)) - (setf (file-write-time buffer) (file-write-date filepath)) - ;; A file! That means we may have a local options - ;; line to parse. - (evaluate-attribute-line buffer)) + (setf (offset (point (buffer pane))) (offset (point pane)) + (buffer (current-window)) buffer + (syntax buffer) (make-instance (syntax-class-name-for-filepath filepath) + :buffer buffer) + (file-write-time buffer) (file-write-date filepath)) + (evaluate-attribute-line buffer) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) - (needs-saving buffer) nil (read-only-p buffer) readonlyp) (beginning-of-buffer (point pane)) (update-syntax buffer (syntax buffer)) (clear-modify buffer) buffer)))))))) +(defmethod find-file (filepath (application-frame climacs)) + (find-file-impl filepath nil)) + +(defmethod find-file-read-only (filepath (application-frame climacs)) + (find-file-impl filepath t)) + (defun directory-of-buffer (buffer) "Extract the directory part of the filepath to the file in BUFFER. If BUFFER does not have a filepath, the path to the user's home @@ -659,34 +663,13 @@ (or (filepath buffer) (user-homedir-pathname))))) -(defun set-visited-file-name (filename buffer) - (setf (filepath buffer) filename +(defmethod set-visited-filename (filepath buffer (application-frame climacs)) + (setf (filepath buffer) filepath (file-saved-p buffer) nil (file-write-time buffer) nil - (name buffer) (filepath-filename filename) + (name buffer) (filepath-filename filepath) (needs-saving buffer) t)) -(defun extract-version-number (pathname) - "Extracts the emacs-style version-number from a pathname." - (let* ((type (pathname-type pathname)) - (length (length type))) - (when (and (> length 2) (char= (char type (1- length)) #\~)) - (let ((tilde (position #\~ type :from-end t :end (- length 2)))) - (when tilde - (parse-integer type :start (1+ tilde) :junk-allowed t)))))) - -(defun version-number (pathname) - "Return the number of the highest versioned backup of PATHNAME -or 0 if there is no versioned backup. Looks for name.type~X~, -returns highest X." - (let* ((wildpath (merge-pathnames (make-pathname :type :wild) pathname)) - (possibilities (directory wildpath))) - (loop for possibility in possibilities - for version = (extract-version-number possibility) - if (numberp version) - maximize version into max - finally (return max)))) - (defun check-file-times (buffer filepath question answer) "Return NIL if filepath newer than buffer and user doesn't want to overwrite." @@ -701,32 +684,6 @@ nil)) t))) -(defun save-buffer (buffer) - (let ((filepath (or (filepath buffer) - (accept 'pathname :prompt "Save Buffer to File")))) - (cond - ((directory-pathname-p filepath) - (display-message "~A is a directory." filepath) - (beep)) - (t - (unless (check-file-times buffer filepath "Overwrite" "written") - (return-from save-buffer)) - (when (and (probe-file filepath) (not (file-saved-p buffer))) - (let ((backup-name (pathname-name filepath)) - (backup-type (format nil "~A~~~D~~" - (pathname-type filepath) - (1+ (version-number filepath))))) - (rename-file filepath (make-pathname :name backup-name - :type backup-type))) - (setf (file-saved-p buffer) t)) - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (output-to-stream stream buffer 0 (size buffer))) - (setf (filepath buffer) filepath - (file-write-time buffer) (file-write-date filepath) - (name buffer) (filepath-filename filepath)) - (display-message "Wrote: ~a" filepath) - (setf (needs-saving buffer) nil))))) - (defmethod frame-exit :around ((frame climacs) #-mcclim &key) (loop for buffer in (buffers frame) when (and (needs-saving buffer) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/07/27 10:39:32 1.50 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/08/20 13:06:39 1.51 @@ -63,7 +63,6 @@ :depends-on ("packages" "buffer" "Persistent")) (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring")) - (:file "io" :depends-on ("packages" "buffer")) (:file "abbrev" :depends-on ("packages" "buffer" "base")) (:file "syntax" :depends-on ("packages" "buffer" "base")) (:file "text-syntax" :depends-on ("packages" "base" "buffer" "syntax" "motion")) @@ -86,14 +85,16 @@ "pane")) (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane" "window-commands" "gui")) - (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands" - "misc-commands" "window-commands" "file-commands" "core")) + (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) + (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "motion-commands" + "editing-commands" "misc-commands")) #.(if (find-swank) '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) (values)) (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" - "kill-ring" "io" "text-syntax" + "kill-ring" "text-syntax" "abbrev" "editing" "motion")) + (:file "io" :depends-on ("packages" "gui")) (:file "core" :depends-on ("gui")) (:file "climacs" :depends-on ("gui" "core")) ;; (:file "buffer-commands" :depends-on ("gui")) --- /project/climacs/cvsroot/climacs/base.lisp 2006/07/24 16:33:16 1.57 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/08/20 13:06:39 1.58 @@ -297,8 +297,6 @@ ;;; ;;; Named objects -(defgeneric name (obj)) - (defclass name-mixin () ((name :initarg :name :accessor name)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 20 Aug '06

20 Aug '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv30619 Modified Files: kill-ring-test.lisp Log Message: Oops. Fixed silly bug in test case. --- /project/climacs/cvsroot/climacs/kill-ring-test.lisp 2006/07/27 10:39:32 1.1 +++ /project/climacs/cvsroot/climacs/kill-ring-test.lisp 2006/08/20 12:52:07 1.2 @@ -27,7 +27,7 @@ t) (deftest kill-ring-standard-push.test-1 - (let* ((random-size (min 3 (random 20))) + (let* ((random-size (max 3 (random 20))) (instance (make-instance 'kill-ring :max-size random-size))) (kill-ring-standard-push instance #(#\A)) (kill-ring-standard-push instance #(#\B))

1 0

[climacs-cvs] CVS esa
by thenriksen 20 Aug '06

20 Aug '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv8074 Modified Files: esa.lisp esa-io.lisp Log Message: Added file-time-checking to `save-buffer', improved the reporting of arguments for key bindings in the on-line help. --- /project/climacs/cvsroot/esa/esa.lisp 2006/07/21 07:58:42 1.20 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/08/20 10:43:40 1.21 @@ -927,8 +927,14 @@ (format stream ".~%") (when command-args (apply #'format stream - "This binding invokes the command with the arguments ~@{~A~^, ~}.~%" - command-args)) + "This binding invokes the command with these arguments: ~@{~A~^, ~}.~%" + (mapcar #'(lambda (arg) + (cond ((eq arg *unsupplied-argument-marker*) + "unsupplied-argument") + ((or (eq arg *numeric-argument-marker*) + (eq arg *numeric-argument-p*)) + "numeric-argument") + (t arg))) command-args))) (terpri stream) (print-docstring-for-command command-name command-table stream) (scroll-extent stream 0 0)))) --- /project/climacs/cvsroot/esa/esa-io.lisp 2006/08/20 10:08:23 1.3 +++ /project/climacs/cvsroot/esa/esa-io.lisp 2006/08/20 10:43:40 1.4 @@ -269,6 +269,20 @@ maximize version into max finally (return max)))) +(defun check-file-times (buffer filepath question answer) + "Return NIL if filepath newer than buffer and user doesn't want +to overwrite." + (let ((f-w-d (file-write-date filepath)) + (f-w-t (file-write-time buffer))) + (if (and f-w-d f-w-t (> f-w-d f-w-t)) + (if (accept 'boolean + :prompt (format nil "File has changed on disk. ~a anyway?" + question)) + t + (progn (display-message "~a not ~a" filepath answer) + nil)) + t))) + (defmethod save-buffer (buffer application-frame) (let ((filepath (or (filepath buffer) (accept 'pathname :prompt "Save Buffer to File")))) @@ -277,7 +291,9 @@ (display-message "~A is a directory." filepath) (beep)) (t - (when (probe-file filepath) + (unless (check-file-times buffer filepath "Overwrite" "written") + (return-from save-buffer)) + (when (and (probe-file filepath) (not (file-saved-p buffer))) (let ((backup-name (pathname-name filepath)) (backup-type (format nil "~A~~~D~~" (pathname-type filepath)

1 0

[climacs-cvs] CVS climacs
by thenriksen 20 Aug '06

20 Aug '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv6234 Modified Files: pane.lisp Log Message: Improve performance slighly by changing the use of `updating-output' --- /project/climacs/cvsroot/climacs/pane.lisp 2006/07/27 13:58:57 1.47 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/08/20 10:29:17 1.48 @@ -371,6 +371,7 @@ (unless (null saved-index) (let ((contents (coerce (subseq line saved-index index) 'string))) (updating-output (pane :unique-id (incf id) + :id-test #'= :cache-value contents :cache-test #'string=) (present-contents contents pane))) @@ -400,13 +401,16 @@ ((characterp obj) (output-word index) (updating-output (pane :unique-id (incf id) - :cache-value obj) + :id-test #'= + :cache-value obj + :cache-test #'equal) (present obj 'character :stream pane))) (t (output-word index) (updating-output (pane :unique-id (incf id) + :id-test #'= :cache-value obj - :cache-test #'eq) + :cache-test #'equal) (present obj 'character :stream pane)))) (incf scan) finally (output-word index) @@ -547,15 +551,12 @@ for id from 0 below (nb-elements cache) do (setf scan start-offset) (updating-output - (pane :unique-id (element* cache id) - :cache-value (if (<= start-offset - (offset (point pane)) - (+ start-offset (length (element* cache id)))) - (cons nil nil) - (element* cache id)) - :cache-test #'eq) - (display-line pane (element* cache id) start-offset - (syntax (buffer pane)) (stream-default-view pane))) + (pane :unique-id id + :id-test #'equal + :cache-value (element* cache id) + :cache-test #'equal) + (display-line pane (element* cache id) start-offset + (syntax (buffer pane)) (stream-default-view pane))) (incf start-offset (1+ (length (element* cache id))))) (when (mark= scan (point pane)) (multiple-value-bind (x y) (stream-cursor-position pane)

1 0

[climacs-cvs] CVS esa
by thenriksen 20 Aug '06

20 Aug '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv3479 Modified Files: packages.lisp esa-io.lisp esa-buffer.lisp Log Message: Expanded `esa-buffer-mixin', added docstrings to some commands and expanded some commands to prepare for the use of ESA-IO in Climacs. --- /project/climacs/cvsroot/esa/packages.lisp 2006/05/13 17:15:10 1.5 +++ /project/climacs/cvsroot/esa/packages.lisp 2006/08/20 10:08:23 1.6 @@ -18,7 +18,7 @@ (defpackage :esa-buffer (:use :clim-lisp :clim :esa) (:export #:make-buffer-from-stream #:save-buffer-to-stream - #:filepath #:name #:needs-saving + #:filepath #:name #:needs-saving #:file-write-time #:file-saved-p #:esa-buffer-mixin #:make-new-buffer #:read-only-p)) --- /project/climacs/cvsroot/esa/esa-io.lisp 2006/05/10 09:53:55 1.2 +++ /project/climacs/cvsroot/esa/esa-io.lisp 2006/08/20 10:08:23 1.3 @@ -158,6 +158,9 @@ buffer))))) (defun directory-of-current-buffer () + "Extract the directory part of the filepath to the file in the current buffer. + If the current buffer does not have a filepath, the path to + the user's home directory will be returned." (make-pathname :directory (pathname-directory @@ -165,9 +168,16 @@ (user-homedir-pathname))))) (define-command (com-find-file :name t :command-table esa-io-table) - ((filepath 'pathname :prompt "Find File: " :prompt-mode :raw - :default (directory-of-current-buffer) :default-type 'pathname + ((filepath 'pathname + :prompt "Find File: " + :prompt-mode :raw + :default (directory-of-current-buffer) + :default-type 'pathname :insert-default t)) + "Prompt for a filename then edit that file. +If a buffer is already visiting that file, switch to that +buffer. Does not create a file if the filename given does not +name an existing file." (find-file filepath *application-frame*)) (set-key `(com-find-file ,*unsupplied-argument-marker*) @@ -196,13 +206,26 @@ nil)))))) (define-command (com-find-file-read-only :name t :command-table esa-io-table) - ((filepath 'pathname :prompt "Find File read-only: " :prompt-mode :raw)) + ((filepath 'pathname + :prompt "Find File read-only: " + :prompt-mode :raw + :default (directory-of-current-buffer) + :default-type 'pathname + :insert-default t)) + "Prompt for a filename then open that file readonly. +If a buffer is already visiting that file, switch to that +buffer. If the filename given does not name an existing file, +signal an error." (find-file-read-only filepath *application-frame*)) (set-key `(com-find-file-read-only ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\r :control))) -(define-command (com-read-only :name t :command-table esa-io-table) () +(define-command (com-read-only :name t :command-table esa-io-table) + () + "Toggle the readonly status of the current buffer. +When a buffer is readonly, attempts to change the contents of the +buffer signal an error." (let ((buffer (current-buffer *application-frame*))) (setf (read-only-p buffer) (not (read-only-p buffer))))) @@ -214,11 +237,38 @@ (needs-saving buffer) t)) (define-command (com-set-visited-file-name :name t :command-table esa-io-table) - ((filename 'pathname :prompt "New file name: " :prompt-mode :raw - :default (directory-of-current-buffer) :insert-default t - :default-type 'pathname)) + ((filename 'pathname :prompt "New filename: " + :prompt-mode :raw + :default (directory-of-current-buffer) + :insert-default t + :default-type 'pathname + :insert-default t)) + "Prompt for a new filename for the current buffer. +The next time the buffer is saved it will be saved to a file with +that filename." (set-visited-file-name filename (current-buffer *application-frame*) *application-frame*)) +(defun extract-version-number (pathname) + "Extracts the emacs-style version-number from a pathname." + (let* ((type (pathname-type pathname)) + (length (length type))) + (when (and (> length 2) (char= (char type (1- length)) #\~)) + (let ((tilde (position #\~ type :from-end t :end (- length 2)))) + (when tilde + (parse-integer type :start (1+ tilde) :junk-allowed t)))))) + +(defun version-number (pathname) + "Return the number of the highest versioned backup of PATHNAME +or 0 if there is no versioned backup. Looks for name.type~X~, +returns highest X." + (let* ((wildpath (merge-pathnames (make-pathname :type :wild) pathname)) + (possibilities (directory wildpath))) + (loop for possibility in possibilities + for version = (extract-version-number possibility) + if (numberp version) + maximize version into max + finally (return max)))) + (defmethod save-buffer (buffer application-frame) (let ((filepath (or (filepath buffer) (accept 'pathname :prompt "Save Buffer to File")))) @@ -229,17 +279,23 @@ (t (when (probe-file filepath) (let ((backup-name (pathname-name filepath)) - (backup-type (concatenate 'string (pathname-type filepath) "~"))) + (backup-type (format nil "~A~~~D~~" + (pathname-type filepath) + (1+ (version-number filepath))))) (rename-file filepath (make-pathname :name backup-name :type backup-type)))) (with-open-file (stream filepath :direction :output :if-exists :supersede) (save-buffer-to-stream buffer stream)) (setf (filepath buffer) filepath + (file-write-time buffer) (file-write-date filepath) (name buffer) (filepath-filename filepath)) (display-message "Wrote: ~a" (filepath buffer)) (setf (needs-saving buffer) nil))))) (define-command (com-save-buffer :name t :command-table esa-io-table) () + "Write the contents of the buffer to a file. +If there is filename associated with the buffer, write to that +file, replacing its contents. If not, prompt for a filename." (let ((buffer (current-buffer *application-frame*))) (if (or (null (filepath buffer)) (needs-saving buffer)) @@ -264,6 +320,8 @@ ((filepath 'pathname :prompt "Write Buffer to File: " :prompt-mode :raw :default (directory-of-current-buffer) :insert-default t :default-type 'pathname)) + "Prompt for a filename and write the current buffer to it. +Changes the file visted by the buffer to the given file." (let ((buffer (current-buffer *application-frame*))) (write-buffer buffer filepath *application-frame*))) --- /project/climacs/cvsroot/esa/esa-buffer.lisp 2006/03/25 00:08:07 1.1.1.1 +++ /project/climacs/cvsroot/esa/esa-buffer.lisp 2006/08/20 10:08:23 1.2 @@ -31,16 +31,11 @@ (:documentation "Save the entire BUFFER to STREAM in the appropriate external representation")) -(defgeneric filepath (buffer)) -(defgeneric (setf filepath) (filepath buffer)) -(defgeneric name (buffer)) -(defgeneric (setf name) (name buffer)) -(defgeneric needs-saving (buffer)) -(defgeneric (setf needs-saving) (needs-saving buffer)) - (defclass esa-buffer-mixin () ((%filepath :initform nil :accessor filepath) (%name :initarg :name :initform "*scratch*" :accessor name) (%needs-saving :initform nil :accessor needs-saving) + (%file-write-time :initform nil :accessor file-write-time) + (%file-saved-p :initform nil :accessor file-saved-p) (%read-only-p :initform nil :accessor read-only-p)))

1 0

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

11 Aug '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26134 Modified Files: syntax.lisp packages.lisp lisp-syntax.lisp lisp-syntax-commands.lisp gui.lisp Log Message: * Added `display-syntax-name' generic function so syntaxes can do more than just return a string for their info-pane. * Changed package display for Lisp syntax so the package specified by the `in-package' form preceding point will be displayed, whether or not the package can be found in the image. If it cannot be found, the specified package name will be displayed in italics in the info-pane. * Changed `with-syntax-package' to rebind `*package*' instead of just being a glorified `let'-wrapper. * Changed other bits and pieces that depended on the prior behavior of the above three changes. --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/08/01 16:06:37 1.68 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/08/11 21:59:05 1.69 @@ -114,6 +114,10 @@ (:documentation "Return the name that should be used for the info-pane for panes displaying a buffer in this syntax.")) +(defgeneric display-syntax-name (syntax stream &key &allow-other-keys) + (:documentation "Draw the name of the syntax `syntax' to + `stream'. This is meant to be called for the info-pane.")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax completion @@ -266,6 +270,9 @@ (defmethod name-for-info-pane ((syntax basic-syntax) &key) (name syntax)) +(defmethod display-syntax-name ((syntax basic-syntax) stream &rest args &key) + (princ (apply #'name-for-info-pane syntax args) stream)) + (defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax)) (declare (ignore mark tab-width)) 0) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/08/01 16:06:37 1.110 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/08/11 21:59:05 1.111 @@ -140,6 +140,7 @@ #:parse-stack-parse-trees #:map-over-parse-trees #:no-such-operation #:no-expression #:name-for-info-pane + #:display-syntax-name #:syntax-line-indentation #:forward-expression #:backward-expression #:eval-defun --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/01 21:06:45 1.107 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/11 21:59:05 1.108 @@ -80,9 +80,11 @@ (option-specified-package :accessor option-specified-package :initform nil :documentation "The package - specified in the attribute - line (may be overridden - by (in-package) forms).") + specified in the attribute line (may + be overridden by (in-package) + forms). This may be either a + string (the name of the intended + package) or a package object.") (image :accessor image :initform nil :documentation "An image object (or NIL) that @@ -130,7 +132,16 @@ (defmethod name-for-info-pane ((syntax lisp-syntax) &key pane) (format nil "Lisp~@[:~(~A~)~]" - (package-name (package-at-mark syntax (point pane))))) + (provided-package-name-at-mark syntax (point pane)))) + +(defmethod display-syntax-name ((syntax lisp-syntax) (stream extended-output-stream) &key pane) + (princ "Lisp:" stream) ; FIXME: should be `present'ed + ; as something. + (let ((package-name (provided-package-name-at-mark syntax (point pane)))) + (if (find-package package-name) + (present (find-package package-name) 'package :stream stream) + (with-text-face (stream :italic) + (princ package-name stream))))) (defgeneric default-image () (:documentation "The default image for when the current syntax @@ -1336,14 +1347,41 @@ (or (handler-case (find-package designator) (type-error () nil)) + (let ((osp (option-specified-package syntax))) + (typecase osp + (package osp) + (string osp))) (find-package (option-specified-package syntax)) (find-package :clim-user))))) -(defmacro with-syntax-package (syntax offset (package-sym) &body +(defun provided-package-name-at-mark (syntax mark-or-offset) + "Get the name of the specified Lisp package for the +syntax. This will return a normalised version of +whatever (in-package) form precedes `mark-or-offset', even if the +package specified in that form does not exist. If no (in-package) +form can be found, return the package specified in the attribute +list. If no such package is specified, return \"CLIM-USER\"." + (as-offsets ((mark-or-offset offset)) + (flet ((normalise (designator) + (typecase designator + (symbol + (symbol-name designator)) + (string + designator) + (package + (package-name designator))))) + (let* ((designator (rest (find offset (package-list syntax) + :key #'first + :test #'>=)))) + (normalise (or designator + (option-specified-package syntax) + :clim-user)))))) + +(defmacro with-syntax-package ((syntax offset) &body body) - "Evaluate `body' with `package-sym' bound to a valid package, + "Evaluate `body' with `*package*' bound to a valid package, preferably taken from `syntax' based on `offset'.." - `(let ((,package-sym (package-at-mark ,syntax ,offset))) + `(let ((*package* (package-at-mark ,syntax ,offset))) ,@body)) (defun need-to-update-package-list-p (buffer syntax) @@ -2340,16 +2378,16 @@ ;; Ensure that every symbol that is READ will be looked up ;; in the correct package. Also handle quoting. (flet ((act () - (with-syntax-package syntax (start-offset token) - (syntax-package) - (let ((*package* (or package syntax-package))) - (cond (read - (read-from-string (token-string syntax token))) - (quote - (setf (getf args :quote) nil) - `',(call-next-method)) - (t - (call-next-method))))))) + (let ((*package* (or package + (package-at-mark + syntax (start-offset token))))) + (cond (read + (read-from-string (token-string syntax token))) + (quote + (setf (getf args :quote) nil) + `',(call-next-method)) + (t + (call-next-method)))))) (if no-error (ignore-errors (act)) (act)))) @@ -3115,9 +3153,8 @@ (defun eval-region (start end syntax) ;; Must be (mark>= end start). - (with-syntax-package syntax start (package) - (let ((*package* package) - (*read-base* (base syntax))) + (with-syntax-package (syntax start) + (let ((*read-base* (base syntax))) (let* ((string (buffer-substring (buffer start) (offset start) (offset end))) @@ -3129,19 +3166,19 @@ (esa:display-message result))))) (defun compile-definition-interactively (mark syntax) - (with-syntax-package syntax mark (package) - (let* ((token (definition-at-mark mark syntax)) - (string (token-string syntax token)) - (m (clone-mark mark)) - (buffer-name (name (buffer syntax))) - (*read-base* (base syntax))) + (let* ((token (definition-at-mark mark syntax)) + (string (token-string syntax token)) + (m (clone-mark mark)) + (buffer-name (name (buffer syntax))) + (*read-base* (base syntax))) + (with-syntax-package (syntax mark) (forward-definition m syntax) (backward-definition m syntax) (multiple-value-bind (result notes) (compile-form-for-climacs (get-usable-image syntax) (token-to-object syntax token :read t - :package package) + :package (package-at-mark syntax mark)) (buffer syntax) m) (show-note-counts notes (second result)) @@ -3150,17 +3187,19 @@ (one-line-ify (subseq string 0 (min (length string) 20))))))))) (defun compile-file-interactively (buffer &optional load-p) - (when (and (needs-saving buffer) - (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer)))) - (save-buffer buffer)) - (with-syntax-package (syntax buffer) 0 (package) - (let ((*read-base* (base (syntax buffer)))) - (multiple-value-bind (result notes) - (compile-file-for-climacs (get-usable-image (syntax buffer)) - (filepath buffer) - package load-p) - (show-note-counts notes (second result)) - (when notes (show-notes notes (name buffer) "")))))) + (cond ((null (filepath buffer)) + (esa:display-message "Buffer ~A is not associated with a file" (name buffer))) + (t + (when (and (needs-saving buffer) + (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer)))) + (save-buffer buffer)) + (let ((*read-base* (base (syntax buffer)))) + (multiple-value-bind (result notes) + (compile-file-for-climacs (get-usable-image (syntax buffer)) + (filepath buffer) + (package-at-mark (syntax buffer) 0) load-p) + (show-note-counts notes (second result)) + (when notes (show-notes notes (name buffer) ""))))))) ;;; Parameter hinting @@ -4012,27 +4051,27 @@ (typep token 'complete-token-lexeme) (not (= (start-offset token) (offset mark)))) - (with-syntax-package syntax mark (package) - (multiple-value-bind (longest completions) (funcall fn syntax token package) - (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")))) + (multiple-value-bind (longest completions) + (funcall fn syntax token (package-at-mark syntax mark)) + (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))) (defun complete-symbol-at-mark (syntax mark) --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/08/01 16:06:37 1.14 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/08/11 21:59:05 1.15 @@ -115,9 +115,8 @@ (mark (point (current-window))) (token (form-before syntax (offset mark)))) (if token - (with-syntax-package syntax mark (package) - (let ((*package* package) - (*read-base* (base syntax))) + (with-syntax-package (syntax mark) + (let ((*read-base* (base syntax))) (climacs-commands::com-eval-expression (token-to-object syntax token :read t) insertp))) --- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/27 14:35:35 1.226 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/08/11 21:59:05 1.227 @@ -257,7 +257,7 @@ (column-number point))) (with-text-family (pane :sans-serif) (princ #\( pane) - (princ (name-for-info-pane (syntax buffer) :pane (master-pane pane)) pane) + (display-syntax-name (syntax buffer) pane :pane (master-pane pane)) (format pane "~{~:[~*~; ~A~]~}" (list (slot-value master-pane 'overwrite-mode) "Ovwrt"

1 0