- climacs-cvs@common-lisp.net - mailman3.common-lisp.net

[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

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

09 Sep '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29495 Modified Files: io.lisp Log Message: Fix related to ESA changes. --- /project/climacs/cvsroot/climacs/io.lisp 2006/09/08 18:12:03 1.7 +++ /project/climacs/cvsroot/climacs/io.lisp 2006/09/09 18:21:02 1.8 @@ -38,6 +38,6 @@ (subseq seq 0 count))))) (defmethod frame-make-buffer-from-stream ((application-frame climacs) stream) - (let* ((buffer (make-new-buffer application-frame))) + (let* ((buffer (make-new-buffer))) (input-from-stream stream buffer 0) buffer))

1 0

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

08 Sep '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26340 Modified Files: lisp-syntax-swine.lisp io.lisp groups.lisp core.lisp Log Message: Update to work with recent ESA changes. --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/30 19:32:23 1.3 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/08 18:12:03 1.4 @@ -1016,7 +1016,7 @@ (namestring path))))))) (if buffer (switch-to-buffer buffer) - (find-file (file-name location) *application-frame*)) + (find-file (file-name location))) (goto-position (point (current-window)) (char-position (source-position location))))) @@ -1098,7 +1098,7 @@ (t (when (and (needs-saving buffer) (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer)))) - (save-buffer buffer *application-frame*)) + (save-buffer buffer)) (let ((*read-base* (base (syntax buffer)))) (multiple-value-bind (result notes) (compile-file-for-climacs (get-usable-image (syntax buffer)) @@ -1173,7 +1173,7 @@ Returns NIL if an arglist cannot be displayed." (multiple-value-bind (arglist emphasized-symbols highlighted-symbols) (analyze-arglist - (arglist-for-form (syntax (current-buffer *application-frame*)) operator arguments) + (arglist-for-form (syntax (current-buffer)) operator arguments) current-arg-indices preceding-arg arguments) @@ -1230,7 +1230,7 @@ (defun edit-definition (symbol &optional type) (let ((all-definitions (find-definitions-for-climacs - (get-usable-image (syntax (current-buffer *application-frame*))) + (get-usable-image (syntax (current-buffer))) symbol))) (let ((definitions (if (not type) all-definitions --- /project/climacs/cvsroot/climacs/io.lisp 2006/09/02 11:41:41 1.6 +++ /project/climacs/cvsroot/climacs/io.lisp 2006/09/08 18:12:03 1.7 @@ -24,7 +24,7 @@ (in-package :climacs-core) -(defmethod save-buffer-to-stream ((buffer climacs-buffer) stream) +(defmethod frame-save-buffer-to-stream ((application-frame climacs) (buffer climacs-buffer) stream) (let ((seq (buffer-sequence buffer 0 (size buffer)))) (write-sequence seq stream))) @@ -37,7 +37,7 @@ seq (subseq seq 0 count))))) -(defmethod make-buffer-from-stream (stream (application-frame climacs)) +(defmethod frame-make-buffer-from-stream ((application-frame climacs) stream) (let* ((buffer (make-new-buffer application-frame))) (input-from-stream stream buffer 0) buffer)) --- /project/climacs/cvsroot/climacs/groups.lisp 2006/09/06 20:07:21 1.1 +++ /project/climacs/cvsroot/climacs/groups.lisp 2006/09/08 18:12:03 1.2 @@ -287,7 +287,7 @@ (unwind-protect (progn ,@body) (unless ,keep (loop for buffer in ,buffer-diff-sym - do (save-buffer buffer *application-frame*) + do (save-buffer buffer) do (kill-buffer buffer)))))))) (defmacro define-group (name (group-arg &rest args) &body body) --- /project/climacs/cvsroot/climacs/core.lisp 2006/09/06 20:07:21 1.8 +++ /project/climacs/cvsroot/climacs/core.lisp 2006/09/08 18:12:03 1.9 @@ -334,16 +334,12 @@ ;;; ;;; Buffer handling -(defmethod make-new-buffer ((application-frame climacs)) - (let ((buffer (make-instance 'climacs-buffer))) +(defmethod frame-make-new-buffer ((application-frame climacs) + &key (name "*scratch*")) + (let ((buffer (make-instance 'climacs-buffer :name name))) (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)) - buffer)) - (defgeneric erase-buffer (buffer)) (defmethod erase-buffer ((buffer string)) @@ -401,7 +397,7 @@ (let ((buffer (find name (buffers *application-frame*) :key #'name :test #'string=))) (switch-to-buffer (or buffer - (make-new-named-buffer name))))) + (make-new-buffer :name name))))) ;;placeholder (defmethod switch-to-buffer ((symbol (eql 'nil))) @@ -424,11 +420,11 @@ (error () (progn (beep) (display-message "Invalid answer") (return-from kill-buffer nil))))) - (save-buffer buffer *application-frame*)) + (save-buffer buffer)) (setf buffers (remove buffer buffers)) ;; Always need one buffer. (when (null buffers) - (make-new-named-buffer "*scratch*")) + (make-new-buffer :name "*scratch*")) (setf (buffer (current-window)) (car buffers)) (full-redisplay (current-window)) (buffer (current-window)))) @@ -621,7 +617,7 @@ file if necessary." (when (and (findablep pathname) (not (find-buffer-with-pathname pathname))) - (find-file pathname *application-frame*))) + (find-file pathname))) (defun find-file-impl (filepath &optional readonlyp) (cond ((null filepath) @@ -642,8 +638,8 @@ (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*))) + (make-buffer-from-stream stream)) + (make-new-buffer))) (pane (current-window))) (setf (offset (point (buffer pane))) (offset (point pane)) (buffer (current-window)) buffer @@ -659,10 +655,10 @@ (clear-modify buffer) buffer))))))) -(defmethod find-file (filepath (application-frame climacs)) +(defmethod frame-find-file ((application-frame climacs) filepath) (find-file-impl filepath nil)) -(defmethod find-file-read-only (filepath (application-frame climacs)) +(defmethod frame-find-file-read-only ((application-frame climacs) filepath) (find-file-impl filepath t)) (defun directory-of-buffer (buffer) @@ -675,7 +671,7 @@ (or (filepath buffer) (user-homedir-pathname))))) -(defmethod set-visited-filename (filepath buffer (application-frame climacs)) +(defmethod frame-set-visited-filename ((application-frame climacs) filepath buffer) (setf (filepath buffer) filepath (file-saved-p buffer) nil (file-write-time buffer) nil @@ -705,7 +701,7 @@ (error () (progn (beep) (display-message "Invalid answer") (return-from frame-exit nil))))) - do (save-buffer buffer frame)) + do (save-buffer buffer)) (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer))) (buffers frame)) (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")

1 0

[climacs-cvs] CVS esa
by thenriksen 08 Sep '06

08 Sep '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv26054 Modified Files: packages.lisp esa.asd esa-io.lisp esa-buffer.lisp Log Message: Changed some generic functions to be nongeneric trampolines calling generic functions with *application-frame* as the argument. This is because 99% of the time, these functions will always be called with *application-frame* as the frame argument, so there's no need to make it explicit in every call. --- /project/climacs/cvsroot/esa/packages.lisp 2006/09/03 21:22:05 1.7 +++ /project/climacs/cvsroot/esa/packages.lisp 2006/09/08 18:08:03 1.8 @@ -17,18 +17,21 @@ (defpackage :esa-buffer (:use :clim-lisp :clim :esa) - (:export #:make-buffer-from-stream #:save-buffer-to-stream + (:export #:frame-make-buffer-from-stream #:make-buffer-from-stream + #:frame-save-buffer-to-stream #:save-buffer-to-stream #:filepath #:name #:needs-saving #:file-write-time #:file-saved-p #:esa-buffer-mixin - #:make-new-buffer + #:frame-make-new-buffer #:make-new-buffer #:read-only-p)) (defpackage :esa-io (:use :clim-lisp :clim :esa :esa-buffer) (:export #:buffers #:frame-current-buffer #:current-buffer - #:find-file #:find-file-read-only - #:set-visited-filename - #:save-buffer #:write-buffer + #:frame-find-file #:find-file + #:frame-find-file-read-only #:find-file-read-only + #:frame-set-visited-filename #:set-visited-filename + #:frame-save-buffer #:save-buffer + #:frame-write-buffer #:write-buffer #:esa-io-table)) #-mcclim --- /project/climacs/cvsroot/esa/esa.asd 2006/05/10 09:52:05 1.5 +++ /project/climacs/cvsroot/esa/esa.asd 2006/09/08 18:08:03 1.6 @@ -4,5 +4,5 @@ (:file "colors" :depends-on ("packages")) (:file "esa" :depends-on ("colors" "packages")) (:file "esa-buffer" :depends-on ("packages" "esa")) - (:file "esa-io" :depends-on ("packages" "esa")) + (:file "esa-io" :depends-on ("packages" "esa" "esa-buffer")) (:file "esa-command-parser" :depends-on ("packages" "esa")))) --- /project/climacs/cvsroot/esa/esa-io.lisp 2006/09/03 21:22:05 1.5 +++ /project/climacs/cvsroot/esa/esa-io.lisp 2006/09/08 18:08:03 1.6 @@ -31,19 +31,29 @@ calls `frame-current-buffer' with `frame' as argument." (frame-current-buffer frame)) -(defgeneric find-file (file-path application-frame)) -(defgeneric find-file-read-only (file-path application-frame)) -(defgeneric set-visited-filename (filepath buffer application-frame)) -(defgeneric save-buffer (buffer application-frame)) -(defgeneric write-buffer (buffer filepath application-frame)) +(defgeneric frame-find-file (application-frame file-path) + (:documentation "If a buffer with the file-path already exists, +return it, else if a file with the right name exists, return a +fresh buffer created from the file, else return a new empty +buffer having the associated file name.")) +(defgeneric frame-find-file-read-only (application-frame file-path)) +(defgeneric frame-set-visited-file-name (application-frame filepath buffer)) +(defgeneric frame-save-buffer (application-frame buffer)) +(defgeneric frame-write-buffer (application-frame filepath buffer)) + +(defun find-file (file-path) + (frame-find-file *application-frame* file-path)) +(defun find-file-read-only (file-path) + (frame-find-file-read-only *application-frame* file-path)) +(defun set-visited-file-name (filepath buffer) + (frame-set-visited-file-name *application-frame* filepath buffer)) +(defun save-buffer (buffer) + (frame-save-buffer *application-frame* buffer)) +(defun write-buffer (filepath buffer) + (frame-write-buffer *application-frame* filepath buffer)) (make-command-table 'esa-io-table :errorp nil) -(defgeneric find-file (file-path application-frame) - (:documentation "if a buffer with the file-path already exists, return it, -else if a file with the right name exists, return a fresh buffer created from -the file, else return a new empty buffer having the associated file name.")) - (defun filename-completer (so-far mode) (flet ((remove-trail (s) (subseq s 0 (let ((pos (position #\/ s :from-end t))) @@ -143,7 +153,7 @@ (concatenate 'string (pathname-name pathname) "." (pathname-type pathname)))) -(defmethod find-file (filepath application-frame) +(defmethod frame-find-file (application-frame filepath) (cond ((null filepath) (display-message "No file name given.") (beep)) @@ -155,8 +165,8 @@ :key #'filepath :test #'equal) (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*)))) + (make-buffer-from-stream stream)) + (make-new-buffer)))) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (needs-saving buffer) nil) @@ -183,12 +193,12 @@ 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*)) + (find-file filepath)) (set-key `(com-find-file ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\f :control))) -(defmethod find-file-read-only (filepath application-frame) +(defmethod frame-find-file-read-only (application-frame filepath) (cond ((null filepath) (display-message "No file name given.") (beep)) @@ -200,7 +210,7 @@ :key #'filepath :test #'equal) (if (probe-file filepath) (with-open-file (stream filepath :direction :input) - (let ((buffer (make-buffer-from-stream stream *application-frame*))) + (let ((buffer (make-buffer-from-stream stream))) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (read-only-p buffer) t @@ -221,7 +231,7 @@ 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*)) + (find-file-read-only filepath)) (set-key `(com-find-file-read-only ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\r :control))) @@ -236,9 +246,9 @@ (set-key 'com-read-only 'esa-io-table '((#\x :control) (#\q :control))) -(defmethod set-visited-file-name (filename buffer application-frame) - (setf (filepath buffer) filename - (name buffer) (filepath-filename filename) +(defmethod frame-set-visited-file-name (application-frame filepath buffer) + (setf (filepath buffer) filepath + (name buffer) (filepath-filename filepath) (needs-saving buffer) t)) (define-command (com-set-visited-file-name :name t :command-table esa-io-table) @@ -251,7 +261,7 @@ "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*)) + (set-visited-file-name filename (current-buffer))) (defun extract-version-number (pathname) "Extracts the emacs-style version-number from a pathname." @@ -288,7 +298,7 @@ nil)) t))) -(defmethod save-buffer (buffer application-frame) +(defmethod frame-save-buffer (application-frame buffer) (let ((filepath (or (filepath buffer) (accept 'pathname :prompt "Save Buffer to File")))) (cond @@ -297,7 +307,7 @@ (beep)) (t (unless (check-file-times buffer filepath "Overwrite" "written") - (return-from save-buffer)) + (return-from frame-save-buffer)) (when (and (probe-file filepath) (not (file-saved-p buffer))) (let ((backup-name (pathname-name filepath)) (backup-type (format nil "~A~~~D~~" @@ -320,12 +330,12 @@ (let ((buffer (current-buffer))) (if (or (null (filepath buffer)) (needs-saving buffer)) - (save-buffer buffer *application-frame*) + (save-buffer buffer) (display-message "No changes need to be saved from ~a" (name buffer))))) (set-key 'com-save-buffer 'esa-io-table '((#\x :control) (#\s :control))) -(defmethod write-buffer (buffer filepath application-frame) +(defmethod frame-write-buffer (application-frame filepath buffer) (cond ((directory-pathname-p filepath) (display-message "~A is a directory name." filepath)) @@ -344,7 +354,7 @@ "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))) - (write-buffer buffer filepath *application-frame*))) + (write-buffer buffer filepath))) (set-key `(com-write-buffer ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\w :control))) --- /project/climacs/cvsroot/esa/esa-buffer.lisp 2006/08/20 10:08:23 1.2 +++ /project/climacs/cvsroot/esa/esa-buffer.lisp 2006/09/08 18:08:03 1.3 @@ -20,17 +20,31 @@ (in-package :esa-buffer) -(defgeneric make-buffer-from-stream (stream application-frame) +(defgeneric frame-make-buffer-from-stream (application-frame stream) (:documentation "Create a fresh buffer by reading the external representation from STREAM")) -(defgeneric make-new-buffer (application-frame) - (:documentation "Create a empty buffer for the application frame")) +(defun make-buffer-from-stream (stream) + "Create a fresh buffer by reading the external representation +from STREAM" + (frame-make-buffer-from-stream *application-frame* stream)) + +(defgeneric frame-make-new-buffer (application-frame &key &allow-other-keys) + (:documentation "Create a empty buffer for the application frame.")) + +(defun make-new-buffer (&key &allow-other-keys) + "Create a empty buffer for the current frame." + (frame-make-new-buffer *application-frame*)) -(defgeneric save-buffer-to-stream (buffer stream) +(defgeneric frame-save-buffer-to-stream (application-frame buffer stream) (:documentation "Save the entire BUFFER to STREAM in the appropriate external representation")) +(defun save-buffer-to-stream (buffer stream) + "Save the entire BUFFER to STREAM in the appropriate external +representation" + (frame-save-buffer-to-stream *application-frame* buffer stream)) + (defclass esa-buffer-mixin () ((%filepath :initform nil :accessor filepath) (%name :initarg :name :initform "*scratch*" :accessor name)

1 0