mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

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

06 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv601/Experimental/freetype Modified Files: freetype-fonts.lisp Log Message: Eliminate duplicated medium-gcontext method in freetype (it had fallen behind in maintenance, anyway). Reduced or eliminated consing while setting medium clipping region. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/05 23:04:15 1.14 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/06 01:37:06 1.15 @@ -458,9 +458,9 @@ (call-next-method))))))) (t (call-next-method))))))) - (if (eq (car lookaside) text-style) - (cdr lookaside) - (cdr (setf lookaside (cons text-style (f)))))))) + (cdr (if (eq (car lookaside) text-style) + lookaside + (setf lookaside (cons text-style (f)))))))) (defmethod clim-clx::text-style-to-X-font ((port clim-clx::clx-port) text-style) (error "You lost: ~S." text-style)) @@ -569,7 +569,7 @@ (let* ((drawable (sheet-mirror (medium-sheet medium))) (port (port medium))) (let ((gc (xlib:create-gcontext :drawable drawable))) - (Let ((fn (text-style-to-X-font port text-style))) + (let ((fn (text-style-to-X-font port text-style))) (if (typep fn 'xlib:font) (setf (xlib:gcontext-font gc) fn))) (setf @@ -623,48 +623,6 @@ (setf (xlib:gcontext-font gc) fn)))))))) -(defmethod medium-gcontext ((medium clx-medium) (ink color)) - (let* ((port (port medium)) - (mirror (port-lookup-mirror port (medium-sheet medium))) - (line-style (medium-line-style medium))) - (with-slots (gc) medium - (unless gc - (setq gc (xlib:create-gcontext :drawable mirror)) - ;; this is kind of false, since the :unit should be taken - ;; into account -RS 2001-08-24 - (setf (xlib:gcontext-line-width gc) (line-style-thickness line-style) - (xlib:gcontext-cap-style gc) (line-style-cap-shape line-style) - (xlib:gcontext-join-style gc) (line-style-joint-shape line-style)) - (let ((dashes (line-style-dashes line-style))) - (unless (null dashes) - (setf (xlib:gcontext-line-style gc) :dash - (xlib:gcontext-dashes gc) (if (eq dashes t) 3 - dashes))))) - (setf (xlib:gcontext-function gc) boole-1) - (let ((fn (text-style-to-X-font port (medium-text-style medium)))) - (when (typep fn 'xlib:font) - (setf (xlib:gcontext-font gc) fn))) - (setf (xlib:gcontext-foreground gc) (X-pixel port ink) - (xlib:gcontext-background gc) (X-pixel port (medium-background medium))) - ;; Here is a bug with regard to clipping ... ;-( --GB ) - #-nil ; being fixed at the moment, a bit twitchy though -- BTS - (let ((clipping-region (medium-device-region medium))) - (if (region-equal clipping-region +nowhere+) - (setf (xlib:gcontext-clip-mask gc) #()) - (let ((rect-seq (clipping-region->rect-seq clipping-region))) - (when rect-seq - #+nil - ;; ok, what McCLIM is generating is not :yx-banded... - ;; (currently at least) - (setf (xlib:gcontext-clip-mask gc :yx-banded) rect-seq) - #-nil - ;; the region code doesn't support yx-banding... - ;; or does it? what does y-banding mean in this implementation? - ;; well, apparantly it doesn't mean what y-sorted means - ;; to clx :] we stick with :unsorted until that can be sorted out - (setf (xlib:gcontext-clip-mask gc :unsorted) rect-seq))))) - gc))) - ;;; ;;; This fixes the worst offenders making the assumption that drawing ;;; would be idempotent.

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 06 Jan '08

06 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv32761 Modified Files: listener.lisp wholine.lisp Log Message: Aesthetic tweaks for freetype. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/12/31 23:34:53 1.37 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/01/06 01:33:25 1.38 @@ -153,7 +153,7 @@ (get-frame-pane frame 'interactor)) (defun run-listener (&key (new-process nil) - (width 760) + (width 790) (height 550) port frame-manager --- /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2007/03/04 22:27:51 1.2 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2008/01/06 01:33:25 1.3 @@ -79,13 +79,18 @@ #-(or allegro cmu scl) (getenv "USER") "luser")) ; sorry.. (sitename (machine-instance)) + ;; :sans-serif :roman :small is the best looking jaggy font. + ;; But :small looks awful using freetype, perhaps because the + ;; fonts are, for whatever reason, slightly smaller. + ;; Very distressing. + (text-size (if (find-package :mcclim-freetype) :normal :small)) (memusage #+(or cmu scl) (lisp::dynamic-usage) #+sbcl (sb-kernel:dynamic-usage) #+lispworks (getf (system:room-values) :total-allocated) #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) #+clisp (values (sys::%room)) #-(or cmu scl sbcl lispworks openmcl clisp) 0)) - (with-text-style (t (make-text-style :sans-serif :roman :small)) + (with-text-style (t (make-text-style :sans-serif :roman text-size)) (formatting-table (t :x-spacing '(3 :character)) (formatting-row (t) (macrolet ((cell ((align-x) &body body)

1 0

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

05 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv25588 Modified Files: freetype-fonts.lisp Log Message: Didn't mean to leave any of those in there. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/05 22:58:57 1.13 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/05 23:04:15 1.14 @@ -306,7 +306,6 @@ (defmethod clim-clx::font-draw-glyphs ((font freetype-face) mirror gc x y string &key start end translate) (declare (optimize (speed 3))) (when (< (length buffer) (- end start)) - (hef:debugf "fuck!") (setf buffer (make-array (* 256 (ceiling (- end start) 256)) :element-type '(unsigned-byte 32) :adjustable nil :fill-pointer nil)))

1 0

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

05 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv21988 Modified Files: freetype-fonts.lisp Log Message: Make go fast. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2006/03/10 10:56:01 1.12 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/05 22:58:57 1.13 @@ -24,7 +24,7 @@ (in-package :MCCLIM-FREETYPE) -(declaim (optimize (speed 3) (safety 3) (debug 1) (space 3))) +(declaim (optimize (speed 1) (safety 3) (debug 1) (space 0))) ;;;; Notes @@ -35,6 +35,9 @@ ((lib :initarg :lib) (filename :initarg :filename))) +;;; I can't say I understand this vague vs. concrete font distinction, +;;; but I'll leave it around. -Hefner + (defparameter *vague-font-hash* (make-hash-table :test #'equal)) (defun make-vague-font (filename) @@ -52,6 +55,10 @@ (defparameter *concrete-font-hash* (make-hash-table :test #'equal)) +;;; One "concrete font" is shared for a given face, regardless of text size, +;;; presumably to conserve resources. Therefore, we must configure it for +;;; the correct text size with set-concrete-font-size before using it. + (defun make-concrete-font (vague-font size &key (dpi *dpi*)) (with-slots (lib filename) vague-font (let* ((key (cons lib filename)) @@ -63,12 +70,12 @@ (setf val (setf (gethash key *concrete-font-hash*) (deref facef))) (error "Freetype error in make-concrete-font")))) - (let ((face val)) - (declare (type (alien freetype:face) face)) - (freetype:set-char-size face 0 (round (* size 64)) (round dpi) (round dpi)) - face)))) + val))) -(declaim (inline make-concrete-font)) +(defun set-concrete-font-size (face size dpi) + (declare (type (alien freetype:face) face)) + (freetype:set-char-size face 0 (round (* size 64)) (round dpi) (round dpi)) + face) (defun glyph-pixarray (face char) (declare (optimize (speed 3) (debug 1)) @@ -100,26 +107,19 @@ (/ (slot (slot glyph 'freetype:advance) 'freetype:x) 64) (/ (slot (slot glyph 'freetype:advance) 'freetype:y) 64))))) -(defun glyph-advance (face char) - (freetype:load-glyph face (freetype:get-char-index face (char-code char)) 0) - (let* ((glyph (slot face 'freetype:glyph))) - (values - (/ (slot (slot glyph 'freetype:advance) 'freetype:x) 64) - (/ (slot (slot glyph 'freetype:advance) 'freetype:y) 64)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun display-glyph-cache (display) - (or (getf (xlib:display-plist display) 'glyph-cache) - (setf (getf (xlib:display-plist display) 'glyph-cache) - (make-hash-table :test #'equalp)))) - -(defun display-the-glyph-set (display) - (or (getf (xlib:display-plist display) 'the-glyph-set) - (setf (getf (xlib:display-plist display) 'the-glyph-set) - (xlib::render-create-glyph-set - (first (xlib::find-matching-picture-formats display - :alpha 8 :red 0 :green 0 :blue 0)))))) +(let ((lookaside nil)) + (defun display-the-glyph-set (display) + (if (eq (car lookaside) display) + (cdr lookaside) + (let ((glyph-set (or (getf (xlib:display-plist display) 'the-glyph-set) + (setf (getf (xlib:display-plist display) 'the-glyph-set) + (xlib::render-create-glyph-set + (first (xlib::find-matching-picture-formats display + :alpha 8 :red 0 :green 0 :blue 0))))))) + (setf lookaside (cons display glyph-set)) + glyph-set)))) (defun display-free-glyph-ids (display) (getf (xlib:display-plist display) 'free-glyph-ids)) @@ -137,23 +137,36 @@ (or (pop (display-free-glyph-ids display)) (incf (display-free-glyph-id-counter display)))) -(defun display-get-glyph (display font matrix glyph-index) - (or (gethash (list font matrix glyph-index) (display-glyph-cache display)) - (setf (gethash (list font matrix glyph-index) (display-glyph-cache display)) - (display-generate-glyph display font matrix glyph-index)))) - (defvar *font-hash* (make-hash-table :test #'equalp)) -(defun display-generate-glyph (display font matrix glyph-index) - (let* ((glyph-id (display-draw-glyph-id display)) - (font (or (gethash font *font-hash*) - (setf (gethash font *font-hash*) - (make-vague-font font)))) - (face (make-concrete-font font matrix))) +(defstruct (glyph-info (:constructor glyph-info (id width height left right top))) + id ; FIXME: Types? + width height + left right top) + +(defun font-generate-glyph (font glyph-index) + (let* ((display (freetype-face-display font)) + (glyph-id (display-draw-glyph-id display)) + (face (freetype-face-concrete-font font))) + (set-concrete-font-size face (freetype-face-matrix font) *dpi*) (multiple-value-bind (arr left top dx dy) (glyph-pixarray face (code-char glyph-index)) + (with-slots (fixed-width) font + (when (and (numberp fixed-width) + (/= fixed-width dx)) + (setf fixed-width t) + (warn "Font ~A is fixed width, but the glyph width appears to vary. + Disabling fixed width optimization for this font. ~A vs ~A" + font dx fixed-width)) + (unless (or fixed-width + (zerop (logand (slot face 'freetype:face-flags) + 4))) ; FT_FACE_FLAG_FIXED_WIDTH + (setf fixed-width dx))) + (when (= (array-dimension arr 0) 0) - (setf arr (make-array (list 1 1) :element-type '(unsigned-byte 8) :initial-element 0))) + (setf arr (make-array (list 1 1) + :element-type '(unsigned-byte 8) + :initial-element 0))) (xlib::render-add-glyph (display-the-glyph-set display) glyph-id :data arr :x-origin (- left) @@ -161,51 +174,108 @@ :x-advance dx :y-advance dy) (let ((right (+ left (array-dimension arr 1)))) - (list glyph-id dx dy left right top))))) + (glyph-info glyph-id dx dy left right top))))) ;;;;;;; mcclim interface (defclass freetype-face () - ((display :initarg :display) - (font :initarg :font) - (matrix :initarg :matrix) - (ascent :initarg :ascent) - (descent :initarg :descent))) + ((display :initarg :display :reader freetype-face-display) + (font :initarg :font :reader freetype-face-name) + (matrix :initarg :matrix :reader freetype-face-matrix) + (ascent :initarg :ascent :reader freetype-face-ascent) + (descent :initarg :descent :reader freetype-face-descent) + (concrete-font :initarg :concrete-font :reader freetype-face-concrete-font) + (fixed-width :initform nil) + (glyph-id-cache :initform (make-gcache)) + (glyph-width-cache :initform (make-gcache)) + (char->glyph-info :initform (make-hash-table :size 256)))) + +(defmethod print-object ((object freetype-face) stream) + (print-unreadable-object (object stream :type t :identity nil) + (with-slots (font matrix ascent descent) object + (format stream "~A size=~A ~A/~A" font matrix ascent descent)))) + +(defun font-glyph-info (font character) + (with-slots (char->glyph-info) font + (or (gethash character char->glyph-info) + (setf (gethash character char->glyph-info) + (font-generate-glyph font (char-code character)))))) + +(defun font-glyph-id (font character) + (glyph-info-id (font-glyph-info font character))) (defmethod clim-clx::font-ascent ((font freetype-face)) - (with-slots (ascent) font - ascent)) + (freetype-face-ascent font)) (defmethod clim-clx::font-descent ((font freetype-face)) - (with-slots (descent) font - descent)) + (freetype-face-descent font)) (defmethod clim-clx::font-glyph-width ((font freetype-face) char) - (with-slots (display font matrix) font - (nth 1 (display-get-glyph display font matrix char)))) + (glyph-info-width (font-glyph-info font char))) + (defmethod clim-clx::font-glyph-left ((font freetype-face) char) - (with-slots (display font matrix) font - (nth 3 (display-get-glyph display font matrix char)))) + (glyph-info-left (font-glyph-info font char))) + (defmethod clim-clx::font-glyph-right ((font freetype-face) char) - (with-slots (display font matrix) font - (nth 4 (display-get-glyph display font matrix char)))) + (glyph-info-right (font-glyph-info font char))) + + +(defun make-gcache () + (let ((array (make-array 512 :adjustable nil :fill-pointer nil))) + (loop for i from 0 below 256 do (setf (aref array i) (1+ i))) + array)) + +(declaim (inline gcache-get)) + +(defun gcache-get (cache key-number) + (declare (optimize (speed 3)) + (type (simple-array t (512)))) + (let ((hash (logand (the fixnum key-number) #xFF))) ; best hash function ever. + (and (= key-number (the fixnum (svref cache hash))) ; I <3 fixnums + (svref cache (+ 256 hash))))) + +(defun gcache-set (cache key-number value) + (let ((hash (logand key-number #xFF))) + (setf (svref cache hash) key-number + (svref cache (+ 256 hash)) value))) ;;; this is a hacky copy of XLIB:TEXT-EXTENTS (defmethod clim-clx::font-text-extents ((font freetype-face) string &key (start 0) (end (length string)) translate) ;; -> (width ascent descent left right ;; font-ascent font-descent direction - ;; first-not-done) - translate - (let ((width (loop for i from start below end - sum (clim-clx::font-glyph-width font (char-code (aref string i)))))) + ;; first-not-done) + (declare (optimize (speed 3))) + translate ; ??? + (let ((width + ;; We could work a little harder and maybe get the generic arithmetic + ;; out of here, but I doubt it would shave more than a few percent + ;; off a draw-text benchmark. + (macrolet ((compute () + `(loop with cache = (slot-value font 'glyph-width-cache) + for i from start below end + as char = (aref string i) + as code = (char-code char) + sum (or (gcache-get cache code) + (gcache-set cache code (clim-clx::font-glyph-width font char))) + #+NIL (clim-clx::font-glyph-width font char)))) + (if (numberp (slot-value font 'fixed-width)) + (* (slot-value font 'fixed-width) (length string)) + (typecase string + (simple-string + (locally (declare (type simple-string string)) + (compute))) + (string + (locally (declare (type string string)) + (compute))) + (t (compute))))))) (values width (clim-clx::font-ascent font) (clim-clx::font-descent font) - (clim-clx::font-glyph-left font (char-code (char string start))) - (- width (- (clim-clx::font-glyph-width font (char-code (char string (1- end)))) - (clim-clx::font-glyph-right font (char-code (char string (1- end)))))) + (clim-clx::font-glyph-left font (char string start)) + (- width (- (clim-clx::font-glyph-width font (char string (1- end))) + (clim-clx::font-glyph-right font (char string (1- end))))) (clim-clx::font-ascent font) (clim-clx::font-descent font) 0 end))) @@ -231,29 +301,45 @@ :repeat :on) pixmap))))) -(defmethod clim-clx::font-draw-glyphs ((font freetype-face) mirror gc x y string &key start end translate) - (let ((display (xlib:drawable-display mirror))) - (with-slots (font matrix) font +(let ((buffer (make-array 1024 :element-type '(unsigned-byte 32) ; TODO: thread safety + :adjustable nil :fill-pointer nil))) + (defmethod clim-clx::font-draw-glyphs ((font freetype-face) mirror gc x y string &key start end translate) + (declare (optimize (speed 3))) + (when (< (length buffer) (- end start)) + (hef:debugf "fuck!") + (setf buffer (make-array (* 256 (ceiling (- end start) 256)) + :element-type '(unsigned-byte 32) + :adjustable nil :fill-pointer nil))) + (let ((display (xlib:drawable-display mirror))) (destructuring-bind (source-picture source-pixmap) (gcontext-picture mirror gc) - (let ((fg (xlib:gcontext-foreground gc))) + (let* ((fg (xlib:gcontext-foreground gc)) + (cache (slot-value font 'glyph-id-cache)) + (glyph-ids buffer)) + (loop + for i from start below end ; TODO: Read optimization notes. Fix. Repeat. + for i* upfrom 0 + as char = (aref string i) + as code = (char-code char) + do (setf (aref buffer i*) + (or (gcache-get cache code) + (gcache-set cache code (font-glyph-id font char))))) + (xlib::render-fill-rectangle source-picture :src (list (ash (ldb (byte 8 16) fg) 8) (ash (ldb (byte 8 8) fg) 8) (ash (ldb (byte 8 0) fg) 8) #xFFFF) - 0 0 1 1)) - (setf (xlib::picture-clip-mask (drawable-picture mirror)) - (xlib::gcontext-clip-mask gc)) - (xlib::render-composite-glyphs - (drawable-picture mirror) - (display-the-glyph-set display) - source-picture - x y - (map 'vector (lambda (x) - (first - (display-get-glyph display font matrix (char-code x)))) - (subseq string start end))))))) + 0 0 1 1) + (setf (xlib::picture-clip-mask (drawable-picture mirror)) + (xlib::gcontext-clip-mask gc)) + (xlib::render-composite-glyphs + (drawable-picture mirror) + (display-the-glyph-set display) + source-picture + x y + glyph-ids + :end (- end start))))))) (let ((cache (make-hash-table :test #'equal))) (defun make-free-type-face (display font size) @@ -264,10 +350,12 @@ (make-vague-font font)))) (f (make-concrete-font f.font size))) (declare (type (alien freetype:face) f)) + (set-concrete-font-size f size *dpi*) (make-instance 'freetype-face :display display :font font :matrix size + :concrete-font f :ascent (/ (slot (slot (slot f 'freetype:size_s) 'freetype:metrics) 'freetype:ascender) 64) :descent (/ (slot (slot (slot f 'freetype:size_s) 'freetype:metrics) 'freetype:descender) -64))))))) @@ -297,6 +385,28 @@ ((:sans-serif (:italic :bold)) . "VeraBI.ttf") ((:sans-serif :bold) . "VeraBd.ttf"))) +;;; 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") + ((:FIX :ITALIC) . "DejaVuSansMono-Oblique.ttf") + ((:FIX (:BOLD :ITALIC)) . "DejaVuSansMono-BoldOblique.ttf") + ((:FIX (:ITALIC :BOLD)) . "DejaVuSansMono-BoldOblique.ttf") + ((:FIX :BOLD) . "DejaVuSansMono-Bold.ttf") + ((:SERIF :ROMAN) . "DejaVuSerif.ttf") + ((:SERIF :ITALIC) . "DejaVuSerif-Oblique.ttf") + ((:SERIF (:BOLD :ITALIC)) . "DejaVuSerif-BoldOblique.ttf") + ((:SERIF (:ITALIC :BOLD)) . "DejaVuSerif-BoldOblique.ttf") + ((:SERIF :BOLD) . "DejaVuSerif-Bold.ttf") + ((:SANS-SERIF :ROMAN) . "DejaVuSans.ttf") + ((:SANS-SERIF :ITALIC) . "DejaVuSans-Oblique.ttf") + ((:SANS-SERIF (:BOLD :ITALIC)) . "DejaVuSans-BoldOblique.ttf") + ((:SANS-SERIF (:ITALIC :BOLD)) . "DejaVuSans-BoldOblique.ttf") + ((:SANS-SERIF :BOLD) . "DejaVuSans-Bold.ttf"))) + + (defvar *freetype-font-path*) (fmakunbound 'clim-clx::text-style-to-x-font) @@ -317,6 +427,7 @@ ((port clim-clx::clx-port) (text-style climi::device-font-text-style) &optional character-set) (values (gethash text-style (clim-clx::port-text-style-mappings port)))) + (defmethod (setf text-style-mapping) :around (value (port clim-clx::clx-port) @@ -326,25 +437,31 @@ (defparameter *free-type-face-hash* (make-hash-table :test #'equal)) -(defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) (text-style standard-text-style)) - (multiple-value-bind (family face size) - (clim:text-style-components text-style) - (let ((display (clim-clx::clx-port-display port))) - (setf face (or face :roman)) - (setf size (or size :normal)) - (cond (size - (setf size (getf *sizes* size size)) - (let ((val (gethash (list display family face size) *free-type-face-hash*))) - (if val val - (setf (gethash (list display family face size) *free-type-face-hash*) - (let* ((font-path-relative (cdr (assoc (list family face) *families/faces* - :test #'equal))) - (font-path (namestring (merge-pathnames font-path-relative *freetype-font-path*)))) - (if (and font-path (probe-file font-path)) [41 lines skipped]

1 0

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

05 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv23302/Drei/Tests Modified Files: lisp-syntax-tests.lisp motion-tests.lisp Log Message: Made Backward Expression behave more like Emacs. Also added a currently-failing test case for Forward Expression, I couldn't figure out a simple way to handle the situation, and I fear special-casing will be necessary. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/12/20 10:33:35 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/05 21:07:16 1.11 @@ -823,7 +823,11 @@ (motion-fun-one-test (expression lisp-syntax) (51 0 (11 28 7) "(defun list (&rest elements) -(append elements nil))")) +(append elements nil))") + (nil nil (5 18 9) + "#+nil (list 1 2 3)") + (nil nil (0 5 nil) + "#+nil (list 1 2 3)")) (motion-fun-one-test (list lisp-syntax) (64 4 (22 41 11) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/12/20 10:33:35 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2008/01/05 21:07:16 1.8 @@ -105,8 +105,8 @@ (check-type forward-begin-offset (or integer null)) (check-type backward-end-offset (or integer null)) (check-type offset integer) - (check-type goal-forward-offset integer) - (check-type goal-backward-offset integer) + (check-type goal-forward-offset (or integer null)) + (check-type goal-backward-offset (or integer null)) `(with-buffer (buffer :initial-contents ,initial-contents) (with-view (view :buffer buffer :syntax ',syntax) (let ((syntax (syntax view)) @@ -117,7 +117,8 @@ (m2l (make-buffer-mark buffer (size buffer) :left)) (m2r (make-buffer-mark buffer (size buffer) :right))) (declare (ignore ,@(unless forward-begin-offset '(m0l)) - ,@(unless backward-end-offset '(m0r)))) + ,@(unless backward-end-offset '(m0r)) + ,@(unless goal-forward-offset '(m0r m1l)))) ,(when forward-begin-offset `(progn (is-true (,forward m0l syntax)) @@ -126,10 +127,14 @@ `(progn (is-true (,forward m0r syntax)) (is (= ,forward-begin-offset (offset m0r))))) - (is-true (,forward m1l syntax)) - (is (= ,goal-forward-offset (offset m1l))) - (is-true (,forward m1r syntax)) - (is (= ,goal-forward-offset (offset m1r))) + ,(unless (null goal-forward-offset) + `(progn + (is-true (,forward m1l syntax)) + (is (= ,goal-forward-offset (offset m1l))))) + ,(unless (null goal-forward-offset) + `(progn + (is-true (,forward m1r syntax)) + (is (= ,goal-forward-offset (offset m1r))))) (is-false (,forward m2l syntax)) (is (= (size buffer) (offset m2l))) (is-false (,forward m2r syntax)) @@ -152,15 +157,20 @@ (m1r (make-buffer-mark buffer ,offset :right)) (m2l (make-buffer-mark buffer (size buffer) :left)) (m2r (make-buffer-mark buffer (size buffer) :right))) - (declare (ignore ,@(unless backward-end-offset '(m2l m2r)))) + (declare (ignore ,@(unless backward-end-offset '(m2l m2r)) + ,@(unless goal-backward-offset '(m1l m1r)))) (is-false (,backward m0l syntax)) (is (= 0 (offset m0l))) (is-false (,backward m0r syntax)) (is (= 0 (offset m0r))) - (is-true (,backward m1l syntax)) - (is (= ,goal-backward-offset (offset m1l))) - (is-true (,backward m1r syntax)) - (is (= ,goal-backward-offset (offset m1r))) + ,(unless (null goal-backward-offset) + `(progn + (is-true (,backward m1l syntax)) + (is (= ,goal-backward-offset (offset m1l))))) + ,(unless (null goal-backward-offset) + `(progn + (is-true (,backward m1r syntax)) + (is (= ,goal-backward-offset (offset m1r))))) ,(when backward-end-offset `(progn (is-true (,backward m2l syntax))

1 0

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

05 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23302/Drei Modified Files: lisp-syntax.lisp Log Message: Made Backward Expression behave more like Emacs. Also added a currently-failing test case for Forward Expression, I couldn't figure out a simple way to handle the situation, and I fear special-casing will be necessary. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 14:23:16 1.51 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 21:07:16 1.52 @@ -2012,9 +2012,13 @@ (update-parse syntax 0 (offset mark)) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) - (when (and (not (null potential-form)) - (not (= (offset mark) (start-offset potential-form)))) - (setf (offset mark) (start-offset potential-form))))) + (loop until (null potential-form) + do (cond ((= (offset mark) (start-offset potential-form)) + (setf potential-form + (unless (form-at-top-level-p potential-form) + (parent potential-form)))) + (t (setf (offset mark) (start-offset potential-form)) + (return t)))))) (defmethod forward-one-expression (mark (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) @@ -2022,7 +2026,7 @@ (form-around syntax (offset mark))))) (when (and (not (null potential-form)) (not (= (offset mark) (end-offset potential-form)))) - (setf (offset mark) (end-offset potential-form))))) + (setf (offset mark) (end-offset potential-form))))) (defmethod forward-delete-expression (mark (syntax lisp-syntax) &optional (count 1) (limit-action #'error-limit-action))

1 0

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

05 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6678/Drei Modified Files: base.lisp editing.lisp motion.lisp packages.lisp Log Message: Fixed some word-motion and word-transposition bugs. --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2008/01/02 14:43:40 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2008/01/05 20:08:32 1.10 @@ -431,6 +431,12 @@ until (offset-end-of-line-p buffer offset) finally (return offset))) +(defun extract-region (mark-or-offset1 mark-or-offset2) + "Delete the region delimited by `mark-or-offset1' and +`mark-or-offset2', returning the extracted sequence of objects." + (prog1 (region-to-sequence mark-or-offset1 mark-or-offset2) + (delete-region mark-or-offset1 mark-or-offset2))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case --- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2007/12/21 14:22:07 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2008/01/05 20:08:32 1.10 @@ -176,42 +176,50 @@ ,(concat "Transpose two " plural " at MARK."))) (defmethod ,transpose ((mark right-sticky-mark) syntax) - (let (start1 end1 start2 end2) - (,backward mark syntax 1 nil) - (setf start1 (clone-mark mark)) - (,forward mark syntax 1 #'error-limit-action) - (setf end1 (clone-mark mark)) - (,forward mark syntax 1 #'error-limit-action) - (setf end2 (clone-mark mark)) - (,backward mark syntax 1 nil) - (setf start2 (clone-mark mark)) - (let ((obj1 (buffer-sequence (buffer mark) (offset start1) (offset end1))) - (obj2 (buffer-sequence (buffer mark) (offset start2) (offset end2)))) - (,forward-delete mark syntax 1 nil) - (insert-sequence mark obj1) - (,backward mark syntax 2 nil) - (,forward-delete mark syntax 1 nil) - (insert-sequence mark obj2) - (,forward mark syntax 1 nil)))) + (let ((start1 (clone-mark mark))) + (,backward start1 syntax 1 nil) + (let ((end1 (clone-mark start1))) + (,forward end1 syntax 1 #'error-limit-action) + (let ((start2 (clone-mark end1))) + (,forward start2 syntax 1 #'error-limit-action) + (let ((end2 (clone-mark start2))) + (,backward start2 syntax 1 nil) + (as-region (start1 end1) + (as-region (start2 end2) + (when (mark> start1 start2) + (psetf start1 start2 + end1 end2 + start2 start1 + end2 end1)) + (if (mark> end1 start2) + (error-limit-action mark (offset mark) 0 ,unit-name syntax) + (let ((obj2 (extract-region start2 end2))) + (insert-sequence start2 (extract-region start1 end1)) + (insert-sequence start1 obj2) + (setf (offset mark) (offset end2))))))))))) (defmethod ,transpose ((mark left-sticky-mark) syntax) - (let (start1 end1 start2 end2) - (,backward mark syntax 1 nil) - (setf start1 (clone-mark mark)) - (,forward mark syntax 1 #'error-limit-action) - (setf end1 (clone-mark mark)) - (,forward mark syntax 1 #'error-limit-action) - (setf end2 (clone-mark mark)) - (,backward mark syntax 1 nil) - (setf start2 (clone-mark mark)) - (let ((obj1 (buffer-sequence (buffer mark) (offset start1) (offset end1))) - (obj2 (buffer-sequence (buffer mark) (offset start2) (offset end2)))) - (,forward-delete mark syntax 1 nil) - (insert-sequence mark obj1) - (,forward mark syntax 1 nil) - (,backward mark syntax 2 nil) - (,forward-delete mark syntax 1 nil) - (insert-sequence mark obj2)))))))) + (let ((start1 (clone-mark mark))) + (,backward start1 syntax 1 nil) + (let ((end1 (clone-mark start1))) + (,forward end1 syntax 1 #'error-limit-action) + (let ((start2 (clone-mark end1))) + (,forward start2 syntax 1 #'error-limit-action) + (let ((end2 (clone-mark start2))) + (,backward start2 syntax 1 nil) + (as-region (start1 end1) + (as-region (start2 end2) + (when (mark> start1 start2) + (psetf start1 start2 + end1 end2 + start2 start1 + end2 end1)) + (if (mark> end1 start2) + (error-limit-action mark (offset mark) 0 ,unit-name syntax) + (let ((obj2 (extract-region start2 end2))) + (insert-sequence start2 (extract-region start1 end1)) + (insert-sequence start1 obj2) + (setf (offset mark) (offset end2))))))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2007/08/20 19:44:44 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2008/01/05 20:08:32 1.6 @@ -267,24 +267,24 @@ Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-word (mark syntax) - (forward-to-word-boundary mark syntax) - (and (not (end-of-buffer-p mark)) - (loop until (end-of-buffer-p mark) - while (word-constituentp syntax (object-after mark)) - do (forward-object mark) - finally (return t)))) + (unless (end-of-buffer-p mark) + (forward-to-word-boundary mark syntax) + (loop until (end-of-buffer-p mark) + while (word-constituentp syntax (object-after mark)) + do (forward-object mark) + finally (return t)))) (defgeneric backward-one-word (mark syntax) (:documentation "Move MARK backward over the previous word. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-word (mark syntax) - (backward-to-word-boundary mark syntax) - (and (not (beginning-of-buffer-p mark)) - (loop until (beginning-of-buffer-p mark) - while (word-constituentp syntax (object-before mark)) - do (backward-object mark) - finally (return t)))) + (unless (beginning-of-buffer-p mark) + (backward-to-word-boundary mark syntax) + (loop until (beginning-of-buffer-p mark) + while (word-constituentp syntax (object-before mark)) + do (backward-object mark) + finally (return t)))) (define-motion-fns word) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/05 09:17:37 1.32 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/05 20:08:32 1.33 @@ -111,6 +111,7 @@ #:offset-beginning-of-line-p #:offset-end-of-line-p #:end-of-line-offset + #:extract-region #:buffer-whitespacep #:buffer-region-case #:buffer-looking-at #:looking-at

1 0

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

05 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv6678/Drei/Tests Modified Files: editing-tests.lisp Log Message: Fixed some word-motion and word-transposition bugs. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2007/12/08 08:53:49 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2008/01/05 20:08:32 1.5 @@ -365,7 +365,8 @@ (transposition-test word ("words Many, great words!") ("") - ((8 "Many great, words words!")) + ((8 "Many great, words words!") + (10 "Many great, words words!")) "Many words, great words!") (transposition-test page

1 0

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

05 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8577/Drei Modified Files: lisp-syntax.lisp Log Message: Handle more noncharacters in the Lisp lexer. Fix dumb bug in `find-list-parent'. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 11:55:18 1.50 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 14:23:16 1.51 @@ -354,99 +354,103 @@ (t (let ((prefix 0)) (loop until (end-of-buffer-p scan) - while (digit-char-p (object-after scan)) + while (and (characterp (object-after scan)) + (digit-char-p (object-after scan))) do (setf prefix (+ (* 10 prefix) (digit-char-p (object-after scan)))) (fo)) - (if (end-of-buffer-p scan) - (make-instance 'incomplete-lexeme) - (case (object-after scan) - ((#\Backspace #\Tab #\Newline #\Linefeed - #\Page #\Return #\Space #\)) - (fo) - (make-instance 'error-lexeme)) - (#\\ (fo) - (cond ((end-of-buffer-p scan) - (make-instance 'incomplete-character-lexeme)) - ((not (constituentp (object-after scan))) - (fo) (make-instance 'complete-character-lexeme)) - (t (loop until (end-of-buffer-p scan) - while (constituentp (object-after scan)) - do (fo)) - (make-instance 'complete-character-lexeme)))) - (#\' (fo) - (make-instance 'function-lexeme)) - (#\( (fo) - (make-instance 'simple-vector-start-lexeme)) - (#\* (fo) - (loop until (end-of-buffer-p scan) - while (or (eql (object-after scan) #\1) - (eql (object-after scan) #\0)) - do (fo)) - (if (and (not (end-of-buffer-p scan)) - (constituentp (object-after scan))) - (make-instance 'error-lexeme) - (make-instance 'bit-vector-form))) - (#\: (fo) - (make-instance 'uninterned-symbol-lexeme)) - (#\. (fo) - (make-instance 'readtime-evaluation-lexeme)) - ((#\B #\b #\O #\o #\X #\x) - (let ((radix - (ecase (object-after scan) - ((#\B #\b) 2) - ((#\O #\o) 8) - ((#\X #\x) 16)))) - (fo) + (if (or (end-of-buffer-p scan) + (not (characterp (object-after scan)))) + (make-instance 'incomplete-lexeme) + (case (object-after scan) + ((#\Backspace #\Tab #\Newline #\Linefeed + #\Page #\Return #\Space #\)) + (fo) + (make-instance 'error-lexeme)) + (#\\ (fo) + (cond ((or (end-of-buffer-p scan) + (not (characterp (object-after scan)))) + (make-instance 'incomplete-character-lexeme)) + ((not (constituentp (object-after scan))) + (fo) (make-instance 'complete-character-lexeme)) + (t (loop until (end-of-buffer-p scan) + while (constituentp (object-after scan)) + do (fo)) + (make-instance 'complete-character-lexeme)))) + (#\' (fo) + (make-instance 'function-lexeme)) + (#\( (fo) + (make-instance 'simple-vector-start-lexeme)) + (#\* (fo) + (loop until (end-of-buffer-p scan) + while (or (eql (object-after scan) #\1) + (eql (object-after scan) #\0)) + do (fo)) + (if (and (not (end-of-buffer-p scan)) + (constituentp (object-after scan))) + (make-instance 'error-lexeme) + (make-instance 'bit-vector-form))) + (#\: (fo) + (make-instance 'uninterned-symbol-lexeme)) + (#\. (fo) + (make-instance 'readtime-evaluation-lexeme)) + ((#\B #\b #\O #\o #\X #\x) + (let ((radix + (ecase (object-after scan) + ((#\B #\b) 2) + ((#\O #\o) 8) + ((#\X #\x) 16)))) + (fo) (when (char= (object-after scan) #\-) (fo)) - (loop until (end-of-buffer-p scan) - while (digit-char-p (object-after scan) radix) - do (fo))) - (if (and (not (end-of-buffer-p scan)) - (constituentp (object-after scan))) - (make-instance 'error-lexeme) - (make-instance 'number-lexeme))) - ((#\R #\r) - (fo) - (cond - ((<= 2 prefix 36) - (loop until (end-of-buffer-p scan) - while (digit-char-p (object-after scan) prefix) - do (fo)) - (if (and (not (end-of-buffer-p scan)) - (constituentp (object-after scan))) - (make-instance 'error-lexeme) - (make-instance 'number-lexeme))) - (t (make-instance 'error-lexeme)))) - ;((#\C #\c) ) - ((#\A #\a) (fo) - (make-instance 'array-start-lexeme)) - ((#\S #\s) (fo) - (cond ((and (not (end-of-buffer-p scan)) - (eql (object-after scan) #\()) - (fo) - (make-instance 'structure-start-lexeme)) - ((end-of-buffer-p scan) - (make-instance 'incomplete-lexeme)) - (t (make-instance 'error-lexeme)))) - ((#\P #\p) (fo) - (make-instance 'pathname-start-lexeme)) - (#\= (fo) - (make-instance 'sharpsign-equals-lexeme)) - (#\# (fo) - (make-instance 'sharpsign-sharpsign-form)) - (#\+ (fo) - (make-instance 'reader-conditional-positive-lexeme)) - (#\- (fo) - (make-instance 'reader-conditional-negative-lexeme)) - (#\| (fo) - (make-instance 'long-comment-start-lexeme)) - (#\< (fo) - (make-instance 'error-lexeme)) - (t (fo) (make-instance 'undefined-reader-macro-lexeme)))))))) + (loop until (end-of-buffer-p scan) + while (digit-char-p (object-after scan) radix) + do (fo))) + (if (and (not (end-of-buffer-p scan)) + (constituentp (object-after scan))) + (make-instance 'error-lexeme) + (make-instance 'number-lexeme))) + ((#\R #\r) + (fo) + (cond + ((<= 2 prefix 36) + (loop until (end-of-buffer-p scan) + while (and (characterp (object-after scan)) + (digit-char-p (object-after scan) prefix)) + do (fo)) + (if (and (not (end-of-buffer-p scan)) + (constituentp (object-after scan))) + (make-instance 'error-lexeme) + (make-instance 'number-lexeme))) + (t (make-instance 'error-lexeme)))) + ;((#\C #\c) ) + ((#\A #\a) (fo) + (make-instance 'array-start-lexeme)) + ((#\S #\s) (fo) + (cond ((and (not (end-of-buffer-p scan)) + (eql (object-after scan) #\()) + (fo) + (make-instance 'structure-start-lexeme)) + ((end-of-buffer-p scan) + (make-instance 'incomplete-lexeme)) + (t (make-instance 'error-lexeme)))) + ((#\P #\p) (fo) + (make-instance 'pathname-start-lexeme)) + (#\= (fo) + (make-instance 'sharpsign-equals-lexeme)) + (#\# (fo) + (make-instance 'sharpsign-sharpsign-form)) + (#\+ (fo) + (make-instance 'reader-conditional-positive-lexeme)) + (#\- (fo) + (make-instance 'reader-conditional-negative-lexeme)) + (#\| (fo) + (make-instance 'long-comment-start-lexeme)) + (#\< (fo) + (make-instance 'error-lexeme)) + (t (fo) (make-instance 'undefined-reader-macro-lexeme)))))))) (#\| (fo) (make-instance 'multiple-escape-start-lexeme)) (t (cond ((or (constituentp object) (eql object #\\)) @@ -1975,7 +1979,7 @@ (typecase parent (list-form parent) ((or form* null) nil) - (t (find-list-parent-offset parent))))) + (t (find-list-parent parent))))) (defun find-list-parent-offset (form fn) "Find a list parent of `form' and return `fn' applied to this

1 0

[mcclim-cvs] CVS mcclim/Apps/Inspector
by thenriksen 05 Jan '08

05 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv31123/Apps/Inspector Modified Files: inspector.lisp Log Message: Use :single-box t to highlight presentations in Clouseau. Much prettier. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/01/01 23:23:07 1.40 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/01/05 12:20:34 1.41 @@ -166,7 +166,8 @@ (,evaluated-object ,object)) (with-output-as-presentation (pane ,evaluated-object - (presentation-type-of ,evaluated-object)) + (presentation-type-of ,evaluated-object) + :single-box t) (formatting-table (,evaluated-pane) (formatting-column (,evaluated-pane) (formatting-cell (,evaluated-pane)

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