climacs-cvs June 2006

climacs-cvs@common-lisp.net

2 participants
16 discussions

[climacs-cvs] CVS climacs
by thenriksen 04 Jun '06

04 Jun '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4814 Modified Files: syntax.lisp lisp-syntax.lisp gui.lisp Log Message: Added optional keyword parameters to the `name-for-info-pane' generic function. --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/05/06 11:57:23 1.64 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/06/04 16:21:06 1.65 @@ -151,7 +151,9 @@ ;;; ;;; Name for info-pane -(defgeneric name-for-info-pane (syntax)) +(defgeneric name-for-info-pane (syntax &key &allow-other-keys) + (:documentation "Return the name that should be used for the + info-pane for panes displaying a buffer in this syntax.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -289,7 +291,7 @@ (declare (ignore buffer from to)) nil) -(defmethod name-for-info-pane ((syntax basic-syntax)) +(defmethod name-for-info-pane ((syntax basic-syntax) &key) (name syntax)) (defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax)) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/03 13:40:20 1.82 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/04 16:21:06 1.83 @@ -71,7 +71,7 @@ (with-slots (buffer scan) syntax (setf scan (clone-mark (low-mark buffer) :left)))) -(defmethod name-for-info-pane ((syntax lisp-syntax)) +(defmethod name-for-info-pane ((syntax lisp-syntax) &key) (format nil "Lisp~@[:~(~A~)~]" (let ((package (slot-value syntax 'package))) (typecase package --- /project/climacs/cvsroot/climacs/gui.lisp 2006/05/14 17:42:21 1.215 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/06/04 16:21:06 1.216 @@ -288,7 +288,7 @@ size))))))) (with-text-family (pane :sans-serif) (princ #\( pane) - (princ (name-for-info-pane (syntax buffer)) pane) + (princ (name-for-info-pane (syntax buffer) :pane pane) pane) (format pane "~{~:[~*~; ~A~]~}" (list (slot-value master-pane 'overwrite-mode) "Ovwrt"

1 0

[climacs-cvs] CVS climacs
by dmurray 03 Jun '06

03 Jun '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19455 Modified Files: misc-commands.lisp Log Message: Some fixups (Transpose Objects, Count Lines Page, Count Lines Region, What Cursor Position) --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/16 20:59:16 1.13 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/06/03 17:58:04 1.14 @@ -210,21 +210,19 @@ (unless (beginning-of-buffer-p mark) (when (end-of-line-p mark) (backward-object mark)) - (let ((object (object-after mark))) - (delete-range mark) - (backward-object mark) - (insert-object mark object) - (forward-object mark)))) + (unless (beginning-of-buffer-p mark) + (let ((object (object-after mark))) + (delete-range mark) + (backward-object mark) + (insert-object mark object) + (forward-object mark))))) (define-command (com-transpose-objects :name t :command-table editing-table) () "Transpose the objects before and after point, advancing point. At the end of a line transpose the previous two objects without advancing point. At the beginning of the buffer do nothing. At the beginning of any line other than the first effectively -move the first object of that line to the end of the previous line. - -FIXME: at the end of a single object line at the beginning of -the buffer deletes that object." +move the first object of that line to the end of the previous line." (transpose-objects (point (current-window)))) (set-key 'com-transpose-objects @@ -269,8 +267,7 @@ (setf ew1 (offset mark)) (forward-word mark) (when (= (offset mark) ew1) - ;; this is emacs' message in the minibuffer - (error "Don't have two things to transpose")) + (display-message "Don't have two things to transpose")) (setf ew2 (offset mark)) (backward-word mark) (setf bw2 (offset mark)) @@ -1271,8 +1268,7 @@ (define-command (com-count-lines-page :name t :command-table info-table) () "Print the number of lines in the current page. -Also prints the number of lines before and after point (as '(b + a)'). -FIXME: the count is off by one." +Also prints the number of lines before and after point (as '(b + a)')." (let* ((pane (current-window)) (point (point pane)) (start (clone-mark point)) @@ -1282,7 +1278,7 @@ (let ((total (number-of-lines-in-region start end)) (before (number-of-lines-in-region start point)) (after (number-of-lines-in-region point end))) - (display-message "Page has ~A lines (~A + ~A)" total before after)))) + (display-message "Page has ~A lines (~A + ~A)" (1+ total) before after)))) (set-key 'com-count-lines-page 'info-table @@ -1290,14 +1286,13 @@ (define-command (com-count-lines-region :name t :command-table info-table) () "Print the number of lines in the region. -Also prints the number of objects (as 'o character[s]'). -FIXME: line count is off by one." +Also prints the number of objects (as 'o character[s]')." (let* ((pane (current-window)) (point (point pane)) (mark (mark pane)) (lines (number-of-lines-in-region point mark)) (chars (abs (- (offset point) (offset mark))))) - (display-message "Region has ~D line~:P, ~D character~:P." lines chars))) + (display-message "Region has ~D line~:P, ~D character~:P." (1+ lines) chars))) (set-key 'com-count-lines-region 'info-table @@ -1315,11 +1310,14 @@ (buffer (buffer pane)) (offset (offset point)) (size (size buffer)) - (char (object-after point)) + (char (or (end-of-buffer-p point) (object-after point))) (column (column-number point))) - (display-message "Char: ~:C (#o~O ~:*~D ~:*#x~X) point=~D of ~D (~D%) column ~D" - char (char-code char) offset size - (round (* 100 (/ offset size))) column))) + (display-message "Char: ~:[none~*~;~:*~:C (#o~O ~:*~D ~:*#x~X)~] point=~D of ~D (~D%) column ~D" + (and (characterp char) char) + (and (characterp char) (char-code char)) + offset size + (if size (round (* 100 (/ offset size))) 100) + column))) (set-key 'com-what-cursor-position 'info-table

1 0

[climacs-cvs] CVS climacs
by thenriksen 03 Jun '06

03 Jun '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19772 Modified Files: lisp-syntax.lisp Log Message: Changed the lambda list of `token-to-object', hopefully fixing an incompatible-lambda-list-error in OpenMCL. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/03 12:32:36 1.81 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/03 13:40:20 1.82 @@ -2040,7 +2040,7 @@ :case case :no-error t)) -(defgeneric token-to-object (syntax token &rest args &key no-error package quote read &allow-other-keys) +(defgeneric token-to-object (syntax token &key) (:documentation "Return the Lisp object `token' would evaluate to if read. An attempt will be made to construct objects from incomplete tokens. This function may signal an error if

1 0

[climacs-cvs] CVS climacs
by thenriksen 03 Jun '06

03 Jun '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12591 Modified Files: lisp-syntax.lisp Log Message: Added `display-parse-tree' method specialized on `incomplete-list-form' to highlight unmatched left parentheses. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/03 12:06:00 1.80 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/03 12:32:36 1.81 @@ -1627,7 +1627,7 @@ (let* ((children (children parse-symbol)) (point-offset (the fixnum (offset (point pane)))) ;; The following is set to true if the location if the point - ;; warrants highlighting of a set of matching parantheses. + ;; warrants highlighting of a set of matching parentheses. (should-highlight (or (= (the fixnum (end-offset parse-symbol)) point-offset) (= (the fixnum (start-offset parse-symbol)) point-offset)))) (if should-highlight @@ -1640,6 +1640,20 @@ (display-parse-tree (car child-list) syntax pane)) else do (display-parse-tree (car child-list) syntax pane)))) + +(defmethod display-parse-tree ((parse-symbol incomplete-list-form) (syntax lisp-syntax) pane) + (let* ((children (children parse-symbol)) + (point-offset (the fixnum (offset (point pane)))) + ;; The following is set to true if the location if the point + ;; warrants highlighting of the beginning parenthesis + (should-highlight (= (the fixnum (start-offset parse-symbol)) point-offset))) + (with-face (:error) + (if should-highlight + (with-text-face (pane :bold) + (display-parse-tree (car children) syntax pane)) + (display-parse-tree (car children) syntax pane))) + (loop for child in (cdr children) do + (display-parse-tree child syntax pane)))) (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax lisp-syntax) current-p) (with-slots (top bot) pane

1 0

[climacs-cvs] CVS climacs
by thenriksen 03 Jun '06

03 Jun '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv8830 Modified Files: lisp-syntax.lisp Log Message: Don't eat conditions in `token-to-object'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/31 14:47:28 1.79 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/03 12:06:00 1.80 @@ -2028,43 +2028,43 @@ (defgeneric token-to-object (syntax token &rest args &key no-error package quote read &allow-other-keys) (:documentation "Return the Lisp object `token' would evaluate - to if read. An attempt will be made to construct objects from - incomplete tokens. This function may signal an error if - `no-error' is nil and `token' cannot be converted to a Lisp - object. Otherwise, nil will be returned.") +to if read. An attempt will be made to construct objects from +incomplete tokens. This function may signal an error if +`no-error' is nil and `token' cannot be converted to a Lisp +object. Otherwise, nil will be returned.") (:method :around (syntax token &rest args &key no-error package quote read) ;; Ensure that every symbol that is READ will be looked up ;; in the correct package. Also handle quoting. - (handler-case (let ((*package* (if (and (slot-boundp syntax 'package) - (slot-value syntax 'package) - (typep (slot-value syntax 'package) 'package)) - (slot-value syntax 'package) - (or (when package - (if (packagep package) - package - (find-package package))) - (find-package :common-lisp))))) - (cond (read - (read-from-string (token-string syntax token))) - (quote - (setf (getf args :quote) nil) - `',(call-next-method)) - (t - (call-next-method)))) - (t () - ;; Needs more usable error. - (unless no-error - (error "Cannot convert token to Lisp object: ~A" token))))) + (flet ((act () + (let ((*package* (if (and (slot-boundp syntax 'package) + (slot-value syntax 'package) + (typep (slot-value syntax 'package) 'package)) + (slot-value syntax 'package) + (or (when package + (if (packagep package) + package + (find-package package))) + (find-package :common-lisp))))) + (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)))) (:method (syntax (token t) &key no-error) - (declare (ignore no-error)) - ;; We ignore `no-error' as it is truly a bug in Climacs if no - ;; handler method is specialized on this form. - (error "Cannot convert token to Lisp object: ~A" - token)) + (declare (ignore no-error)) + ;; We ignore `no-error' as it is truly a bug in Climacs if no + ;; handler method is specialized on this form. + (error "Cannot convert token to Lisp object: ~A" + token)) (:method (syntax (token incomplete-form-mixin) &key no-error) - (unless no-error - (error "Cannot convert incomplete form to Lisp object: ~A" - token)))) + (unless no-error + (error "Cannot convert incomplete form to Lisp object: ~A" + token)))) (defmethod token-to-object (syntax (token complete-token-lexeme) &key no-error

1 0

[climacs-cvs] CVS climacs
by thenriksen 01 Jun '06

01 Jun '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv5957 Modified Files: file-commands.lisp Log Message: Use truenames (if available) when comparing pathnames in `find-file'. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/14 20:35:44 1.18 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/06/01 22:51:40 1.19 @@ -235,48 +235,56 @@ ((directory-pathname-p filepath) (display-message "~A is a directory name." filepath) (beep)) - (t - (let ((existing-buffer (find filepath (buffers *application-frame*) - :key #'filepath :test #'equal))) - (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t)) - (switch-to-buffer existing-buffer) - (progn - (when readonlyp - (unless (probe-file filepath) - (beep) - (display-message "No such file: ~A" filepath) - (return-from find-file nil))) - (let ((buffer (make-buffer)) - (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) - ;; 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-attributes-line buffer)) - ;; If the local options line didn't set a syntax, do - ;; it now. - (when (null (syntax buffer)) - (setf (syntax buffer) - (make-instance (syntax-class-name-for-filepath filepath) - :buffer 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))))))) + (t + (flet ((usable-pathname (pathname) + (if (probe-file pathname) + (truename pathname) + pathname))) + (let ((existing-buffer (find filepath (buffers *application-frame*) + :key #'filepath + :test #'(lambda (fp1 fp2) + (and fp1 fp2 + (equal (usable-pathname fp1) + (usable-pathname fp2))))))) + (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t)) + (switch-to-buffer existing-buffer) + (progn + (when readonlyp + (unless (probe-file filepath) + (beep) + (display-message "No such file: ~A" filepath) + (return-from find-file nil))) + (let ((buffer (make-buffer)) + (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) + ;; 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-attributes-line buffer)) + ;; If the local options line didn't set a syntax, do + ;; it now. + (when (null (syntax buffer)) + (setf (syntax buffer) + (make-instance (syntax-class-name-for-filepath filepath) + :buffer 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)))))))) (defun directory-of-buffer (buffer) "Extract the directory part of the filepath to the file in BUFFER.

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs June 2006