mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Backends/CLX
by ahefner 14 Jan '08

14 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv15001 Modified Files: port.lisp Log Message: Better handle the situation where the DISPLAY variable is not set, which often causes problems on fringe platforms such as Win32 or the Macintosh. Specifically, McCLIM merged the user-provided server path against the server path read from the environment, which is wrong. Worse, it errored unless the environment variable was set, even if the user supplied their own server path. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/14 00:01:04 1.130 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/14 04:53:11 1.131 @@ -167,8 +167,7 @@ (selection-timestamp :initform nil :accessor selection-timestamp) (font-families :accessor font-families))) -(defun parse-clx-server-path (path) - (pop path) +(defun automagic-clx-server-path () (let ((name (get-environment-variable "DISPLAY"))) (assert name (name) "Environment variable DISPLAY is not set") @@ -178,13 +177,13 @@ (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) (host (subseq name (1+ slash-i) colon-i)) (dot-i (and colon-i (position #\. name :start colon-i))) - (display (when colon-i + (display (and colon-i (parse-integer name :start (if decnet-colon-p (+ colon-i 2) (1+ colon-i)) :end dot-i))) - (screen (when dot-i + (screen (and dot-i (parse-integer name :start (1+ dot-i)))) (protocol (cond ((or (string= host "") (string-equal host "unix")) :local) @@ -194,10 +193,20 @@ :keyword)) (t :internet)))) (list :clx - :host (getf path :host host) - :display-id (getf path :display-id (or display 0)) - :screen-id (getf path :screen-id (or screen 0)) - :protocol protocol)))) + :host host + :display-id (or display 0) + :screen-id (or screen 0) + :protocol protocol)))) + +(defun parse-clx-server-path (path) + (pop path) + (if path + (list :clx + :host (getf path :host "localhost") + :display-id (getf path :display-id 0) + :screen-id (getf path :screen-id 0) + :protocol (getf path :protocol :internet)) + (automagic-clx-server-path))) (setf (get :x11 :port-type) 'clx-port) (setf (get :x11 :server-path-parser) 'parse-clx-server-path)

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by ahefner 14 Jan '08

14 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv28382 Modified Files: port.lisp Log Message: Surely we mean finish rather than force output. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2007/09/11 19:54:40 1.129 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/14 00:01:04 1.130 @@ -279,7 +279,7 @@ #'clx-error-handler) #+nil ;; Uncomment this when debugging CLX backend if asynchronous errors become troublesome.. - (setf (xlib:display-after-function (clx-port-display port)) #'xlib:display-force-output)) + (setf (xlib:display-after-function (clx-port-display port)) #'xlib:display-finish-output)) (setf (clx-port-screen port) (nth (getf options :screen-id)

1 0

[mcclim-cvs] CVS mcclim/Experimental/freetype
by ahefner 13 Jan '08

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv16465 Modified Files: freetype-fonts.lisp Log Message: Attempt to workaround nil text style issue. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/13 20:23:59 1.16 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/13 23:02:34 1.17 @@ -461,6 +461,7 @@ (let ((display (clim-clx::clx-port-display port))) (setf face (or face :roman)) + (setf family (or family :fix)) (setf size (or size :normal)) (cond (size (setf size (getf *sizes* size size))

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 13 Jan '08

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv8307/ESA Modified Files: esa-io.lisp packages.lisp Log Message: Added facility for ESA for controlling whether or not a buffer is "saveable". Could be used for more than it currently is (such as integrating the user-confirmation stuff when the file already exists). --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2007/12/27 16:34:59 1.5 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/13 22:22:06 1.6 @@ -2,7 +2,7 @@ ;;; (c) copyright 2006 by ;;; Robert Strandh (strandh(a)labri.fr) -;;; (c) copyright 2007 by +;;; (c) copyright 2007-2008 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or @@ -29,9 +29,45 @@ 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 check-buffer-writability (application-frame filepath buffer) + (:documentation "Check that `buffer' can be written to +`filepath', which can be an arbitrary pathname. If there is a +problem, an error that is a subclass of +`buffer-writing-error'should be signalled.")) (defgeneric frame-save-buffer (application-frame buffer)) (defgeneric frame-write-buffer (application-frame filepath buffer)) +(define-condition buffer-writing-error (error) + ((%buffer :reader buffer + :initarg :buffer + :initform (error "A buffer must be provided") + :documentation "The buffer that was attempted written when this error occured.") + (%filepath :reader filepath + :initarg :filepath + :initform (error "A filepath must be provided") + :documentation "The filepath that the buffer was attempted to be saved to when this error occured")) + (:report (lambda (condition stream) + (format stream "~A could not be saved to ~A" + (name (buffer condition)) (filepath condition)))) + (:documentation "An error that is a subclass of +`buffer-writing-error' will be signalled when a buffer is +attempted saved to a file, but something goes wrong. Not all +error cases will result in the signalling of a +`buffer-writing-error', but some defined cases will.")) + +(define-condition filepath-is-directory (buffer-writing-error) + () + (:report (lambda (condition stream) + (format stream "Cannot save buffer ~A to just a directory" + (name (buffer condition))))) + (:documentation "This error is signalled when a buffer is +attempted saved to a directory.")) + +(defun filepath-is-directory (buffer filepath) + "Signal an error of type `filepath-is-directory' with the +buffer `buffer' and the filepath `filepath'." + (error 'filepath-is-directory :buffer buffer :filepath filepath)) + (defun find-file (file-path) (frame-find-file *application-frame* file-path)) (defun find-file-read-only (file-path) @@ -170,6 +206,12 @@ that filename." (set-visited-file-name filename (current-buffer))) +(defmethod check-buffer-writability (application-frame (filepath pathname) + (buffer esa-buffer-mixin)) + ;; Cannot write to a directory. + (when (directory-pathname-p filepath) + (filepath-is-directory buffer filepath))) + (defun extract-version-number (pathname) "Extracts the emacs-style version-number from a pathname." (let* ((type (pathname-type pathname)) @@ -208,27 +250,23 @@ (defmethod frame-save-buffer (application-frame buffer) (let ((filepath (or (filepath buffer) (accept 'pathname :prompt "Save Buffer to File")))) - (cond - ((directory-pathname-p filepath) - (display-message "~A is a directory." filepath) - (beep)) - (t - (unless (check-file-times buffer filepath "Overwrite" "written") - (return-from 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~~" - (pathname-type filepath) - (1+ (version-number filepath))))) - (rename-file filepath (make-pathname :name backup-name - :type backup-type)))) - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (save-buffer-to-stream buffer stream)) - (setf (filepath buffer) filepath - (file-write-time buffer) (file-write-date filepath) - (name buffer) (filepath-filename filepath)) - (display-message "Wrote: ~a" (filepath buffer)) - (setf (needs-saving buffer) nil))))) + (check-buffer-writability application-frame filepath buffer) + (unless (check-file-times buffer filepath "Overwrite" "written") + (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~~" + (pathname-type filepath) + (1+ (version-number filepath))))) + (rename-file filepath (make-pathname :name backup-name + :type backup-type)))) + (with-open-file (stream filepath :direction :output :if-exists :supersede) + (save-buffer-to-stream buffer stream)) + (setf (filepath buffer) filepath + (file-write-time buffer) (file-write-date filepath) + (name buffer) (filepath-filename filepath)) + (display-message "Wrote: ~a" (filepath buffer)) + (setf (needs-saving buffer) nil))) (define-command (com-save-buffer :name t :command-table esa-io-table) () "Write the contents of the buffer to a file. @@ -237,22 +275,23 @@ (let ((buffer (current-buffer))) (if (or (null (filepath buffer)) (needs-saving buffer)) - (save-buffer buffer) + (handler-case (save-buffer buffer) + (buffer-writing-error (e) + (with-minibuffer-stream (minibuffer) + (let ((*print-escape* nil)) + (print-object e minibuffer))))) (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 frame-write-buffer (application-frame filepath buffer) - (cond - ((directory-pathname-p filepath) - (display-message "~A is a directory name." filepath)) - (t - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (save-buffer-to-stream buffer stream)) - (setf (filepath buffer) filepath - (name buffer) (filepath-filename filepath) - (needs-saving buffer) nil) - (display-message "Wrote: ~a" (filepath buffer))))) + (check-buffer-writability application-frame filepath buffer) + (with-open-file (stream filepath :direction :output :if-exists :supersede) + (save-buffer-to-stream buffer stream)) + (setf (filepath buffer) filepath + (name buffer) (filepath-filename filepath) + (needs-saving buffer) nil) + (display-message "Wrote: ~a" (filepath buffer))) (define-command (com-write-buffer :name t :command-table esa-io-table) ((filepath 'pathname :prompt "Write Buffer to File: " :prompt-mode :raw @@ -261,7 +300,11 @@ "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 filepath buffer))) + (handler-case (write-buffer filepath buffer) + (buffer-writing-error (e) + (with-minibuffer-stream (minibuffer) + (let ((*print-escape* nil)) + (print-object e minibuffer))))))) (set-key `(com-write-buffer ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\w :control))) --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/11 02:44:14 1.11 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/13 22:22:06 1.12 @@ -2,7 +2,7 @@ ;;; (c) copyright 2004-2006 by ;;; Robert Strandh (strandh(a)labri.fr) -;;; (c) copyright 2006 by +;;; (c) copyright 2006-2008 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or @@ -106,8 +106,11 @@ (:export #:frame-find-file #:find-file #:frame-find-file-read-only #:find-file-read-only #:frame-set-visited-file-name #:set-visited-filename + #:check-buffer-writability #:frame-save-buffer #:save-buffer #:frame-write-buffer #:write-buffer + #:buffer-writing-error #:buffer #:filepath + #:filepath-is-directory #:esa-io-table)) #-(or mcclim building-mcclim)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 13 Jan '08

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8307/Drei Modified Files: packages.lisp Log Message: Added facility for ESA for controlling whether or not a buffer is "saveable". Could be used for more than it currently is (such as integrating the user-confirmation stuff when the file already exists). --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/13 10:33:09 1.40 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/13 22:22:05 1.41 @@ -28,6 +28,8 @@ (defpackage :drei-buffer (:use :clim-lisp :flexichain :binseq :esa-utils) + ;; Kludge to remove symbol conflicts. + (:import-from :esa-io :buffer) (:export #:buffer #:standard-buffer #:mark #:left-sticky-mark #:right-sticky-mark #:standard-left-sticky-mark #:standard-right-sticky-mark

1 0

[mcclim-cvs] CVS mcclim/Drei
by dmurray 13 Jan '08

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv2728/Drei Modified Files: drei-redisplay.lisp Log Message: Initial support for non-graphic characters, including #\Tabs. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/09 12:47:31 1.24 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/13 22:01:31 1.25 @@ -176,13 +176,18 @@ area taken up by the stroke. If `modified' is true, this stroke object might output something different than the last time it was redisplayed, and should thus update any caches or similar. When -`modified' is set, `dirty' probably also should be set." +`modified' is set, `dirty' probably also should be set. +`widths' is an array of cumulative screen-resolution widths of +the `parts', being a run of characters or a non-graphic character: +see ANALYSE-STROKE-STRING." (start-offset) (end-offset) (drawing-options +default-drawing-options+) (dirty t) (modified t) - (dimensions (make-dimensions))) + (dimensions (make-dimensions)) + (widths) + (parts)) (defstruct (displayed-line (:conc-name line-)) "A line on display. A line delimits a buffer region (always @@ -377,15 +382,18 @@ (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) -(defun record-stroke (stroke x1 y1 x2 y2 +(defun record-stroke (stroke parts widths x1 y1 x2 y2 &optional (center (/ (- y2 y1) 2))) - "Record the fact that `stroke' has been drawn, and that it + "Record the fact that `stroke' has been drawn, that it consists +of parts `parts' with the widths `widths', and that it covers the specified area on screen. Updates the dirty- and modified-bits of `stroke' as well as the dimensions." (let ((dimensions (stroke-dimensions stroke))) (setf (stroke-dirty stroke) nil (stroke-modified stroke) nil - (x1 dimensions) x1 + (stroke-parts stroke) parts + (stroke-widths stroke) widths + (x1 dimensions) x1 (y1 dimensions) y1 (x2 dimensions) x2 (y2 dimensions) y2 @@ -395,6 +403,39 @@ "A text style specifying a roman face, but with unspecified family and size.") +(defun analyse-stroke-string (string) + "Return a list of parts of `string', where each part is a continuous +run of graphic characters or a single non-graphic character. Each element +in the list is of the form START, END, and one of NIL (meaning a run +of graphic characters) or an object representing the non-graphic char." + (loop with len = (length string) + for left = 0 then (+ right 1) + for right = (or (position-if-not #'graphic-char-p string :start left) + len) + unless (= left right) + collect (list left right) + into parts + until (>= right len) + collect (list right + (+ right 1) + (non-graphic-char-rep (aref string right))) + into parts + finally (return parts))) + +(defun non-graphic-char-rep (object) + "Return the appropriate representation of `object', a non-graphic char. +This will be a string of the format \"^[letter]\" for non-graphic chars +with a char-code of less than #o200, \"\\[octal code]\" for those above +#o200, and the #\\Tab character in the case of a #\\Tab. +NOTE: Assumes an ASCII/Unicode character encoding." + (let ((code (char-code object))) + (cond ((eql object #\Tab) + object) + ((< code #o200) + (format nil "^~C" (code-char (+ code (char-code #\@))))) + (t + (format nil "\\~O" code))))) + (defun stroke-drawing-fn (stream view stroke cursor-x cursor-y) "Draw `stroke' to `stream' at the position (`cursor-x', `cursor-y'). `View' is the view object that `stroke' belongs @@ -406,7 +447,9 @@ (with-accessors ((start-offset stroke-start-offset) (end-offset stroke-end-offset) (dimensions stroke-dimensions) - (drawing-options stroke-drawing-options)) stroke + (drawing-options stroke-drawing-options) + (widths stroke-widths) + (parts stroke-parts)) stroke (let* ((stroke-string (in-place-buffer-substring (buffer view) (cache-string view) start-offset end-offset)) @@ -421,25 +464,66 @@ (text-style-ascent (text-style-ascent roman-text-style (sheet-medium stream))) (text-style-descent (text-style-descent roman-text-style (sheet-medium stream))) (text-style-height (+ text-style-ascent text-style-descent))) - (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2) (center center)) dimensions - (multiple-value-bind (width ignore1 ignore2 ignore3 baseline) - (if (stroke-modified stroke) - (text-size stream stroke-string - :text-style merged-text-style) - (values (- x2 x1) (- y2 y1) nil nil center)) - (declare (ignore ignore1 ignore2 ignore3)) - (clear-rectangle* stream cursor-x cursor-y - (+ cursor-x width) (+ cursor-y text-style-height - (stream-vertical-spacing stream))) - (draw-text* stream stroke-string cursor-x (+ cursor-y - (- text-style-ascent - baseline)) - :text-style merged-text-style - :ink (face-ink (drawing-options-face drawing-options)) - :align-y :top) - (record-stroke stroke cursor-x cursor-y - (+ width cursor-x) (+ text-style-height cursor-y) - baseline)))))) + (with-accessors ((x1 x1) (x2 x2) (center center)) dimensions + (multiple-value-bind (stroke-parts width baseline part-widths) + (if (stroke-modified stroke) + (loop with parts = (analyse-stroke-string stroke-string) + with width = 0 + with baseline = 0 + with widths = (make-array 1 :adjustable t :fill-pointer t) + with tab-width + for (start end object) in parts + do (cond ((and object (eql object #\Tab)) + (incf width + (- (or tab-width (setf tab-width (tab-width stream view))) + (mod (+ width cursor-x) tab-width))) + (vector-push-extend width widths)) + (object + (multiple-value-bind (w ignore1 ignore2 ignore3 b) + (text-size stream object + :text-style merged-text-style) + (declare (ignore ignore1 ignore2 ignore3)) + (incf width w) + (setf baseline (max baseline b)) + (vector-push-extend width widths))) + (t + (multiple-value-bind (w ignore1 ignore2 ignore3 b) + (text-size stream stroke-string + :start start :end end + :text-style merged-text-style) + (declare (ignore ignore1 ignore2 ignore3)) + (incf width w) + (setf baseline (max baseline b)) + (vector-push-extend width widths)))) + finally (return (values parts width baseline widths))) + (values parts (- x2 x1) center widths)) + (clear-rectangle* stream cursor-x cursor-y + (+ cursor-x width) (+ cursor-y text-style-height + (stream-vertical-spacing stream))) + (loop for (start end object) in stroke-parts + for width across part-widths + do (cond ((and object (eq object #\Tab)) + nil) + (object + (draw-text* stream object (+ cursor-x width) + (+ cursor-y + (- text-style-ascent + baseline)) + :text-style merged-text-style + :ink +darkblue+ + :align-y :top)) + (t + (draw-text* stream stroke-string (+ cursor-x width) + (+ cursor-y + (- text-style-ascent + baseline)) + :start start :end end + :text-style merged-text-style + :ink (face-ink (drawing-options-face drawing-options)) + :align-y :top)))) + (record-stroke stroke stroke-parts part-widths cursor-x cursor-y + (+ width cursor-x) (+ text-style-height cursor-y) + baseline)))))) (defun draw-stroke (stream view stroke cursor-x cursor-y) "Draw `stroke' on `stream' at (`cursor-x', `cursor-y'). Nothing @@ -551,7 +635,9 @@ expects its stroke to cover a single-object non-character buffer region, which will be presented with its appropriate presentation type (found via `presentation-type-of') to generate output." - (let (output-record) + (let (output-record + (widths (make-array 2 :initial-contents (list 0 0))) + (parts (list 0 1))) #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn) (declare (ignore default-drawing-fn)) @@ -573,7 +659,9 @@ (+ cursor-x width) (+ cursor-y height (stream-vertical-spacing stream))) (replay output-record stream) - (record-stroke stroke cursor-x cursor-y (+ width cursor-x) + (setf (aref widths 1) width) + (record-stroke stroke parts widths + cursor-x cursor-y (+ width cursor-x) (+ (if (zerop height) (text-style-height (medium-text-style stream) stream) height) @@ -644,15 +732,25 @@ "Calculate the position in device units of `offset' in `stroke', relative to the starting position of `stroke'. `Offset' is an absolute offset into the buffer of `view'," - (text-size stream (in-place-buffer-substring - (buffer view) (cache-string view) - (stroke-start-offset stroke) offset) - :end (- offset (stroke-start-offset stroke)) - :text-style (merge-text-styles - (face-style - (drawing-options-face - (stroke-drawing-options stroke))) - (medium-merged-text-style (sheet-medium stream))))) + (let ((string (in-place-buffer-substring + (buffer view) (cache-string view) + (stroke-start-offset stroke) offset))) + (loop with pos = (- offset (stroke-start-offset stroke)) + for width across (stroke-widths stroke) + for next upfrom 1 + for (start end object) in (stroke-parts stroke) + when (and object (= pos end)) + do (return (aref (stroke-widths stroke) next)) + when (<= start pos end) + do (return (+ width + (text-size stream string + :start start + :end pos + :text-style (merge-text-styles + (face-style + (drawing-options-face + (stroke-drawing-options stroke))) + (medium-merged-text-style (sheet-medium stream))))))))) (defgeneric offset-to-screen-position (pane view offset) (:documentation "Returns the position of offset as a screen

1 0

[mcclim-cvs] CVS mcclim/Experimental/freetype
by ahefner 13 Jan '08

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv8112 Modified Files: freetype-fonts.lisp Log Message: Attempt to improve handling of broken freetype paths. Error immediately when a TTF file cannot be found. If call-next-method here was a feature, I hope no one misses it. Added potentially helpful restart. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/06 01:37:06 1.15 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/13 20:23:59 1.16 @@ -137,7 +137,7 @@ (or (pop (display-free-glyph-ids display)) (incf (display-free-glyph-id-counter display)))) -(defvar *font-hash* +(defparameter *font-hash* (make-hash-table :test #'equalp)) (defstruct (glyph-info (:constructor glyph-info (id width height left right top))) @@ -386,7 +386,6 @@ ;;; Here are alternate mappings for the DejaVu family of fonts, which ;;; are a derivative of Vera with improved unicode coverage. - #+NIL (defparameter *families/faces* '(((:FIX :ROMAN) . "DejaVuSansMono.ttf") @@ -436,6 +435,24 @@ (defparameter *free-type-face-hash* (make-hash-table :test #'equal)) +(define-condition missing-font (simple-error) + ((filename :reader missing-font-filename :initarg :filename)) + (:report (lambda (condition stream) + (format stream "Cannot access ~W~%Your *freetype-font-path* is currently ~W~%The following files should exist:~&~{ ~A~^~%~}" + (missing-font-filename condition) + *freetype-font-path* + (mapcar #'cdr *families/faces*))))) + +(defun invoke-with-freetype-path-restart (continuation) + (restart-case (funcall continuation) + (change-font-path (new-path) + :report (lambda (stream) (format stream "Retry with alternate freetype font path")) + :interactive (lambda () + (format t "Enter new value: ") + (list (read-line))) + (setf *freetype-font-path* new-path) + (invoke-with-freetype-path-restart continuation)))) + (let (lookaside) (defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) (text-style standard-text-style)) (flet ((f () @@ -453,14 +470,18 @@ (let* ((font-path-relative (cdr (assoc (list family face) *families/faces* :test #'equal))) (font-path (namestring (merge-pathnames font-path-relative *freetype-font-path*)))) + (unless (and font-path (probe-file font-path)) + (error 'missing-font :filename font-path)) + #+NIL (if (and font-path (probe-file font-path)) (make-free-type-face display font-path size) - (call-next-method))))))) + (call-next-method)) + (make-free-type-face display font-path size)))))) (t - (call-next-method))))))) + (call-next-method))))))) (cdr (if (eq (car lookaside) text-style) lookaside - (setf lookaside (cons text-style (f)))))))) + (setf lookaside (cons text-style (invoke-with-freetype-path-restart #'f)))))))) (defmethod clim-clx::text-style-to-X-font ((port clim-clx::clx-port) text-style) (error "You lost: ~S." text-style))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 13 Jan '08

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27483/Drei Modified Files: lisp-syntax.lisp Log Message: Fixed the list-down movement commands for Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/12 11:37:21 1.66 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/13 17:10:24 1.67 @@ -1984,7 +1984,7 @@ (defun find-list-parent (form) "Find a list parent of `form' and return it. If a list parent -cannot be found, return nil" +cannot be found, return nil." (let ((parent (parent form))) (typecase parent (list-form parent) @@ -2000,23 +2000,23 @@ (when list-parent (funcall fn list-parent)))) -(defun find-list-child-offset (form fn &optional (min-offset 0)) - "Find a list child of `token' with a minimum start -offset of `min-offset' and return `fn' applied to this child token. -`Fn' should be a function that returns an offset when applied to a -token (eg. `start-offset' or `end-offset'). If a list child cannot -be found, return nil." - (labels ((has-list-child (form) - (some #'(lambda (child) - (if (and (form-list-p child) - (>= (start-offset child) - min-offset)) - child - (has-list-child child))) - (children form)))) - (let ((list-child (has-list-child form))) - (when (not (null list-child)) - (funcall fn list-child))))) +(defun find-list-child (form) + "Find the first list child of `form' and return it. If a list +child cannot be found, return nil." + (find-if #'(lambda (child) + (typecase child + (list-form child) + (form (find-list-child child)))) + (children form))) + +(defun find-list-child-offset (form fn) + "Find a list child of `form' and return `fn' applied to this child. +`Fn' should be a function that returns an offset when applied to +a form (eg. `start-offset' or `end-offset'). If a list child +cannot be found, return nil." + (let ((list-child (find-list-child form))) + (when list-child + (funcall fn list-child)))) (defmethod backward-one-expression (mark (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) @@ -2137,12 +2137,16 @@ (defun down-list (mark syntax selector next-offset-fn target-offset-fn) (update-parse syntax 0 (offset mark)) - (labels ((find-offset (potential-form) + (labels ((next (continue-from) + (find-offset (funcall selector syntax + (funcall next-offset-fn continue-from)))) + (find-offset (potential-form) (typecase potential-form (list-form (funcall target-offset-fn potential-form)) + (form (or (find-list-child-offset potential-form target-offset-fn) + (next potential-form))) (null nil) - (t (find-offset (funcall selector syntax - (funcall next-offset-fn potential-form))))))) + (t (next potential-form))))) (let ((new-offset (find-offset (funcall selector syntax (offset mark))))) (when new-offset (setf (offset mark) new-offset)

1 0

[mcclim-cvs] CVS mcclim/Drei/Tests
by thenriksen 13 Jan '08

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv27483/Drei/Tests Modified Files: lisp-syntax-tests.lisp Log Message: Fixed the list-down movement commands for Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/12 11:37:20 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/13 17:10:24 1.14 @@ -838,6 +838,12 @@ (motion-fun-one-test (down lisp-syntax) (1 53 (15 16 13) "(defun list () (&rest elements) +(append elements nil))") + (2 54 (16 17 14) + "'(defun list () (&rest elements) +(append elements nil))") + (3 55 (17 18 15) + "#'(defun list () (&rest elements) (append elements nil))")) (motion-fun-one-test (up lisp-syntax)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 13 Jan '08

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31563/Drei Modified Files: drei.lisp packages.lisp syntax.lisp views.lisp Log Message: Updated Drei documentation. Should now build, at least. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/11 02:44:13 1.25 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/13 10:33:09 1.26 @@ -345,7 +345,12 @@ ;; Main redisplay entry point. (defgeneric display-drei (drei) - (:documentation "Display the given Drei instance.")) + (:documentation "`Drei' must be an object of type `drei' and +`frame' must be a CLIM frame containing the editor pane of +`drei'. If you define a new subclass of `drei', you must define a +method for this generic function. In most cases, methods defined +on this function will merely be a trampoline to a function +specific to the given Drei variant.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/10 11:17:00 1.39 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/13 10:33:09 1.40 @@ -145,7 +145,7 @@ (defpackage :drei-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :flexichain :esa-utils) - (:export #:syntax #:syntax-command-tables #:update-parse #:syntaxp + (:export #:syntax #:syntax-command-tables #:updater-fns #:update-parse #:syntaxp #:define-syntax #:*default-syntax* #:syntax-command-table #:additional-command-tables #:define-syntax-command-table #:eval-option --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/13 10:32:11 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/13 10:33:10 1.14 @@ -29,7 +29,14 @@ :reader command-table) (%updater-fns :initarg :updater-fns :initform '() - :accessor updater-fns)) + :accessor updater-fns + :documentation "A list of functions that are +called whenever a syntax function needs up-to-date syntax +information. `Update-syntax' is never called directly by syntax +commands. Each function should take two arguments, integer +offsets into the buffer of the syntax delimiting the region that +must have an up-to-date parse. These arguments should be passed +on to a call to `update-syntax'.")) (:metaclass modual-class) (:documentation "The base class for all syntaxes.")) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/11 02:44:13 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/13 10:33:10 1.18 @@ -502,7 +502,9 @@ :initform (make-instance 'drei-buffer) :initarg :buffer :type drei-buffer - :accessor buffer) + :accessor buffer + :documentation "The buffer that is observed by this +buffer view.") (%top :accessor top :documentation "The top of the displayed buffer, that is, the mark indicating the first visible object in the buffer.") @@ -533,7 +535,9 @@ is, used for display right now.")) (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' -object.")) +object. The buffer is displayed on a simple line-by-line basis, +with top and bot marks delimiting the visible region. These marks +are automatically set if applicable.")) (defmethod initialize-instance :after ((view drei-buffer-view) &rest initargs) (declare (ignore initargs)) @@ -566,7 +570,9 @@ (invalidate-line-strokes line :modified t))))) (defclass drei-syntax-view (drei-buffer-view) - ((%syntax :accessor syntax) + ((%syntax :accessor syntax + :documentation "An instance of the syntax class used +for this syntax view.") (%prefix-size :accessor prefix-size :initform 0 :documentation "The number of unchanged objects @@ -763,7 +769,11 @@ (%dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) (%overwrite-mode :initform nil :accessor overwrite-mode)) (:metaclass modual-class) - (:default-initargs :use-editor-commands t)) + (:default-initargs :use-editor-commands t) + (:documentation "The \"default\" Drei view class. It displays a +textual representation of the buffer, possibly with syntax +highlighting, and maintains point and mark marks into the buffer, +in order to permit useful editing commands.")) (defmethod create-view-cursors nconc ((output-stream extended-output-stream) (view textual-drei-syntax-view))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs