July 2005 - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS update: mcclim/Webpage/downloads/index.html
by afuchs＠common-lisp.net 30 Jul '05

30 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory common-lisp.net:/tmp/cvs-serv29447/downloads Modified Files: index.html Log Message: Fix link in downloads/index.html. Date: Sat Jul 30 19:11:36 2005 Author: afuchs Index: mcclim/Webpage/downloads/index.html diff -u mcclim/Webpage/downloads/index.html:1.11 mcclim/Webpage/downloads/index.html:1.12 --- mcclim/Webpage/downloads/index.html:1.11 Sat Jul 30 19:10:48 2005 +++ mcclim/Webpage/downloads/index.html Sat Jul 30 19:11:36 2005 @@ -46,13 +46,13 @@ A compressed tar file of the <a href="http://common-lisp.net/cvs_tarballs/mcclim.tar.gz">sources</a> is made nightly. </p> <h2>Releases</h2> - The most recent release of McCLIM is 0.9.1, in March 2005, available here: <a href="downloads/mcclim-0.9.1.tar.gz">mcclim-0.9.1.tar.gz</a>. It is also available via <a href="http://cliki.net/asdf-install">ASDF-INSTALL</a>. + The most recent release of McCLIM is 0.9.1, in March 2005, available here: <a href="mcclim-0.9.1.tar.gz">mcclim-0.9.1.tar.gz</a>. It is also available via <a href="http://cliki.net/asdf-install">ASDF-INSTALL</a>. </td> </tr> </table> <br> <hr> -$Date: 2005/07/30 17:10:48 $ +$Date: 2005/07/30 17:11:36 $

1 0

[mcclim-cvs] CVS update: mcclim/Webpage/index.html
by afuchs＠common-lisp.net 30 Jul '05

30 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Webpage In directory common-lisp.net:/tmp/cvs-serv29397 Modified Files: index.html Log Message: Change website to reflect the 0.9.1 release. Date: Sat Jul 30 19:10:47 2005 Author: afuchs Index: mcclim/Webpage/index.html diff -u mcclim/Webpage/index.html:1.10 mcclim/Webpage/index.html:1.11 --- mcclim/Webpage/index.html:1.10 Mon Dec 13 16:53:02 2004 +++ mcclim/Webpage/index.html Sat Jul 30 19:10:47 2005 @@ -55,8 +55,7 @@ <h2><a name="downloads">Releases</a></h2> A compressed tar file of the <a href="http://common-lisp.net/cvs_tarballs/mcclim.tar.gz">sources</a> is made nightly. <p> - The most recent release of McCLIM was 0.9, in November - 2003. It's probably a better idea to use the CVS version instead, as there have been many bug fixes and performance improvements since then. + The most recent release of McCLIM is 0.9.1, in March 2005, available here: <a href="downloads/mcclim-0.9.1.tar.gz">mcclim-0.9.1.tar.gz</a>. It is also available via <a href="http://cliki.net/asdf-install">ASDF-INSTALL</a>. </p> <h2>Recent News</h2> <p> @@ -92,7 +91,7 @@ </div> <br> <hr> -$Date: 2004/12/13 15:53:02 $ +$Date: 2005/07/30 17:10:47 $

1 0

[mcclim-cvs] CVS update: mcclim/Webpage/downloads/index.html
by afuchs＠common-lisp.net 30 Jul '05

30 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory common-lisp.net:/tmp/cvs-serv29397/downloads Modified Files: index.html Log Message: Change website to reflect the 0.9.1 release. Date: Sat Jul 30 19:10:48 2005 Author: afuchs Index: mcclim/Webpage/downloads/index.html diff -u mcclim/Webpage/downloads/index.html:1.10 mcclim/Webpage/downloads/index.html:1.11 --- mcclim/Webpage/downloads/index.html:1.10 Sat Dec 11 21:52:02 2004 +++ mcclim/Webpage/downloads/index.html Sat Jul 30 19:10:48 2005 @@ -46,14 +46,13 @@ A compressed tar file of the <a href="http://common-lisp.net/cvs_tarballs/mcclim.tar.gz">sources</a> is made nightly. </p> <h2>Releases</h2> - The most recent release of McCLIM was 0.9, in November - 2003. It's probably a better idea to use the CVS version instead + The most recent release of McCLIM is 0.9.1, in March 2005, available here: <a href="downloads/mcclim-0.9.1.tar.gz">mcclim-0.9.1.tar.gz</a>. It is also available via <a href="http://cliki.net/asdf-install">ASDF-INSTALL</a>. </td> </tr> </table> <br> <hr> -$Date: 2004/12/11 20:52:02 $ +$Date: 2005/07/30 17:10:48 $

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-fonts.lisp mcclim/Experimental/freetype/mcclim-freetype.asd
by afuchs＠common-lisp.net 29 Jul '05

29 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv25410/Experimental/freetype Modified Files: freetype-fonts.lisp mcclim-freetype.asd Log Message: Add Bitstream Vera detection routines to mcclim-freetype's system definition. This depends on the fontconfig utilties, namely fc-match. If they're not found, it defaults to the old (warning) behavior. Date: Fri Jul 29 08:50:20 2005 Author: afuchs Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.9 mcclim/Experimental/freetype/freetype-fonts.lisp:1.10 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.9 Thu Jul 14 14:09:24 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Fri Jul 29 08:50:20 2005 @@ -487,10 +487,3 @@ (clim:with-drawing-options (m :clipping-region r) (clim:draw-design m r :ink clim:+background-ink+) (call-next-method s r))))) - -(format t -"~%~%NOTE:~%~ -* Remember to set mcclim-freetype:*freetype-font-path* to the - location of the Bitstream Vera family of fonts on disk. If you - don't have them, get them from http://www.gnome.org/fonts/~%~%~%") -(finish-output t) Index: mcclim/Experimental/freetype/mcclim-freetype.asd diff -u mcclim/Experimental/freetype/mcclim-freetype.asd:1.2 mcclim/Experimental/freetype/mcclim-freetype.asd:1.3 --- mcclim/Experimental/freetype/mcclim-freetype.asd:1.2 Sat Jun 18 03:56:43 2005 +++ mcclim/Experimental/freetype/mcclim-freetype.asd Fri Jul 29 08:50:20 2005 @@ -1,5 +1,14 @@ ;;;; -*- Lisp -*- +#| +To autoload mcclim-freetype after mcclim, link this file to a +directory in your asdf:*central-registry* and add the following to +your lisp's init file: + + (defmethod asdf:perform :after ((o asdf:load-op) (s (eql (asdf:find-system :clim-clx)))) + (asdf:oos 'asdf:load-op :mcclim-freetype)) +|# + (defpackage :mcclim-freetype-system (:use :cl :asdf)) (in-package :mcclim-freetype-system) @@ -12,9 +21,51 @@ (list (component-pathname c))) (defsystem :mcclim-freetype - :depends-on (:clim :clx) + :depends-on (:clim-clx) :serial t :components ((:file "freetype-package") (:uncompiled-cl-source-file "freetype-ffi") (:file "freetype-fonts"))) + + +;;; Freetype autodetection + +(defun parse-fontconfig-output (s) + (let* ((match-string (concatenate 'string (string #\Tab) "file:")) + (matching-line + (loop for l = (read-line s nil nil) + while l + if (= (mismatch l match-string) (length match-string)) + do (return l))) + (filename (when matching-line + (probe-file + (subseq matching-line + (1+ (position #\" matching-line :from-end nil :test #'char=)) + (position #\" matching-line :from-end t :test #'char=)))))) + (when filename + (make-pathname :directory (pathname-directory filename))))) + +(defun warn-about-unset-font-path () + (warn "~%~%NOTE:~%~ +* Remember to set mcclim-freetype:*freetype-font-path* to the + location of the Bitstream Vera family of fonts on disk. If you + don't have them, get them from http://www.gnome.org/fonts/~%~%~%")) + +#+sbcl +(defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) + (let ((fc-match (sb-ext:find-executable-in-search-path "fc-match"))) + (if (null fc-match) + (warn-about-unset-font-path) + (let* ((process (sb-ext:run-program fc-match `("-v" "Bitstream Vera") + :output :stream + :input nil)) + (font-path (parse-fontconfig-output (sb-ext:process-output process)))) + (if (null font-path) + (warn-about-unset-font-path) + (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) + font-path)))))) + +#-sbcl +(defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) + (warn-about-unset-font-path)) \ No newline at end of file

1 0

[mcclim-cvs] CVS update: mcclim/Lisp-Dep/mp-sbcl.lisp
by dbarlow＠common-lisp.net 15 Jul '05

15 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory common-lisp.net:/tmp/cvs-serv21464/Lisp-Dep Modified Files: mp-sbcl.lisp Log Message: * Lisp-Dep/mp-sbcl.lisp: more changes to keep up with the evolving thread-object API. The new version ought to be backward-compatible too. Date: Fri Jul 15 18:36:58 2005 Author: dbarlow Index: mcclim/Lisp-Dep/mp-sbcl.lisp diff -u mcclim/Lisp-Dep/mp-sbcl.lisp:1.7 mcclim/Lisp-Dep/mp-sbcl.lisp:1.8 --- mcclim/Lisp-Dep/mp-sbcl.lisp:1.7 Fri Jul 1 16:53:42 2005 +++ mcclim/Lisp-Dep/mp-sbcl.lisp Fri Jul 15 18:36:58 2005 @@ -56,9 +56,14 @@ (defvar *all-processes-lock* (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*")) +;; we implement disable-process by making the disablee attempt to lock +;; *permanent-queue*, which is already locked because we locked it +;; here. enable-process just interrupts the lock attempt. + (defvar *permanent-queue* - (sb-thread:make-mutex :name "Lock for disabled threads" - :data :permanently-queued)) + (sb-thread:make-mutex :name "Lock for disabled threads")) +(unless (sb-thread:mutex-value *permanent-queue*) + (sb-thread:get-mutex *permanent-queue* :locked nil)) (defun make-process (function &key name) (let ((p (%make-process :name name :function function))) @@ -146,16 +151,15 @@ (defmacro without-scheduling (&body body) `(progn ,@body)) -(defparameter *atomic-queue* - #+xlib xlib::*conditional-store-queue* - #-xlib (sb-thread:make-waitqueue :name "atomic incf/decf")) +(defparameter *atomic-lock* + (sb-thread:make-mutex :name "atomic incf/decf")) (defmacro atomic-incf (place) - `(sb-thread::with-spinlock (*atomic-queue*) + `(sb-thread:with-mutex (*atomic-lock*) (incf ,place))) (defmacro atomic-decf (place) - `(sb-thread::with-spinlock (*atomic-queue*) + `(sb-thread:with-mutex (*atomic-lock*) (decf ,place))) ;;; 32.3 Locks

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-fonts.lisp
by crhodes＠common-lisp.net 14 Jul '05

14 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv5783/Experimental/freetype Modified Files: freetype-fonts.lisp Log Message: make one more errant cache display-specific. Now I can destroy ports and restart Closure without too many nasty surprises. (These font caches would be better put in a slot in the port, so that we didn't hang on to dead displays in *font-info* and friends) Date: Thu Jul 14 14:09:24 2005 Author: crhodes Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.8 mcclim/Experimental/freetype/freetype-fonts.lisp:1.9 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.8 Tue Jul 12 13:45:58 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Thu Jul 14 14:09:24 2005 @@ -148,8 +148,8 @@ (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)))) + (setf (gethash font *font-hash*) + (make-vague-font font)))) (face (make-concrete-font font matrix))) (multiple-value-bind (arr left top dx dy) (glyph-pixarray face (code-char glyph-index)) (when (= (array-dimension arr 0) 0) @@ -293,24 +293,24 @@ (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) - (multiple-value-bind (family face size) (clim:text-style-components text-style) - (setf face (or face :roman)) - (setf size (or size :normal)) - (cond (size - (setf size (getf *sizes* size size)) - (let ((val (gethash (list family face size) *free-type-face-hash*))) - (if val val - (setf (gethash (list 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)) - (make-free-type-face (slot-value port 'clim-clx::display) - font-path - size) - (call-next-method))))))) - (t - (call-next-method))))) + (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)) + (make-free-type-face display font-path size) + (call-next-method))))))) + (t + (call-next-method)))))) (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 update: mcclim/Experimental/freetype/freetype-fonts.lisp
by crhodes＠common-lisp.net 12 Jul '05

12 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv16770/Experimental/freetype Modified Files: freetype-fonts.lisp Log Message: The cache for glyphs must have the display as part of the key, otherwise closing a port will cause subsequent programs using freetype to break. Date: Tue Jul 12 13:45:58 2005 Author: crhodes Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.7 mcclim/Experimental/freetype/freetype-fonts.lisp:1.8 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.7 Sat Jun 18 03:56:43 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Tue Jul 12 13:45:58 2005 @@ -246,8 +246,8 @@ (let ((cache (make-hash-table :test #'equal))) (defun make-free-type-face (display font size) - (or (gethash (list font size) cache) - (setf (gethash (list font size) cache) + (or (gethash (list display font size) cache) + (setf (gethash (list display font size) cache) (let* ((f.font (or (gethash font *font-hash*) (setf (gethash font *font-hash*) (make-vague-font font))))

1 0

[mcclim-cvs] CVS update: mcclim/Lisp-Dep/mp-sbcl.lisp
by crhodes＠common-lisp.net 01 Jul '05

01 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory common-lisp.net:/tmp/cvs-serv507 Modified Files: mp-sbcl.lisp Log Message: Support new thread-object sbcl API (as well as backwards-compatible #+#. cruft to be deleted when no-one cares about 0.9.2) Date: Fri Jul 1 16:53:42 2005 Author: crhodes Index: mcclim/Lisp-Dep/mp-sbcl.lisp diff -u mcclim/Lisp-Dep/mp-sbcl.lisp:1.6 mcclim/Lisp-Dep/mp-sbcl.lisp:1.7 --- mcclim/Lisp-Dep/mp-sbcl.lisp:1.6 Mon Feb 23 11:48:28 2004 +++ mcclim/Lisp-Dep/mp-sbcl.lisp Fri Jul 1 16:53:42 2005 @@ -40,41 +40,54 @@ state whostate function - id) + thread) (defvar *current-process* - (%make-process :name "initial process" :function nil :id (sb-thread:current-thread-id))) + (%make-process + :name "initial process" :function nil + :thread + #+#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) + sb-thread:*current-thread* + #-#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) + (sb-thread:current-thread-id))) (defvar *all-processes* (list *current-process*)) +(defvar *all-processes-lock* + (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*")) + (defvar *permanent-queue* (sb-thread:make-mutex :name "Lock for disabled threads" :data :permanently-queued)) (defun make-process (function &key name) - (let ((p (%make-process :name name - :function function))) - (pushnew p *all-processes*) + (let ((p (%make-process :name name :function function))) + (sb-thread:with-mutex (*all-processes-lock*) + (pushnew p *all-processes*)) (restart-process p))) (defun restart-process (p) (labels ((boing () (let ((*current-process* p)) (funcall (process-function p) )))) - (when (process-id p) (sb-thread:terminate-thread p)) - (when (setf (process-id p) (sb-thread:make-thread #'boing)) + (when (process-thread p) (sb-thread:terminate-thread p)) + (when (setf (process-thread p) (sb-thread:make-thread #'boing)) p))) (defun destroy-process (process) - ;;; ew threadsafety - (setf *all-processes* (delete process *all-processes*)) - (sb-thread:terminate-thread (process-id process))) + (sb-thread:with-mutex (*all-processes-lock*) + (setf *all-processes* (delete process *all-processes*))) + (sb-thread:terminate-thread (process-thread process))) (defun current-process () *current-process*) (defun all-processes () - *all-processes*) + ;; we're calling DELETE on *ALL-PROCESSES*. If we look up the value + ;; while that delete is executing, we could end up with nonsense. + ;; Better use a lock (or call REMOVE instead in DESTROY-PROCESS). + (sb-thread:with-mutex (*all-processes-lock*) + *all-processes*)) ;;; people should be shot for using these, honestly. Use a queue! (declaim (inline yield)) @@ -113,17 +126,17 @@ (setf (process-whostate *current-process*) old-state)))) (defun process-interrupt (process function) - (sb-thread:interrupt-thread (process-id process) function)) + (sb-thread:interrupt-thread (process-thread process) function)) (defun disable-process (process) (sb-thread:interrupt-thread - (process-id process) + (process-thread process) (lambda () (catch 'interrupted-wait (sb-thread:get-mutex *permanent-queue*))))) (defun enable-process (process) (sb-thread:interrupt-thread - (process-id process) (lambda () (throw 'interrupted-wait nil)))) + (process-thread process) (lambda () (throw 'interrupted-wait nil)))) (defun process-yield () (sleep .1))

1 0

[mcclim-cvs] CVS update: mcclim/Lisp-Dep/mp-openmcl.lisp
by tmoore＠common-lisp.net 01 Jul '05

01 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory common-lisp.net:/tmp/cvs-serv25618/Lisp-Dep Modified Files: mp-openmcl.lisp Log Message: In condition-wait, pass through return value of OpenMCL function. Date: Fri Jul 1 14:59:40 2005 Author: tmoore Index: mcclim/Lisp-Dep/mp-openmcl.lisp diff -u mcclim/Lisp-Dep/mp-openmcl.lisp:1.4 mcclim/Lisp-Dep/mp-openmcl.lisp:1.5 --- mcclim/Lisp-Dep/mp-openmcl.lisp:1.4 Mon Feb 23 11:48:28 2004 +++ mcclim/Lisp-Dep/mp-openmcl.lisp Fri Jul 1 14:59:40 2005 @@ -142,17 +142,15 @@ (let ((lock-error nil)) (unwind-protect (progn - (handler-bind ((ccl::lock-not-owner #'(lambda (c) - (declare (ignore c)) - (setq lock-error t)))) + (handler-bind + ((ccl::lock-not-owner #'(lambda (c) + (declare (ignore c)) + (setq lock-error t)))) (ccl:release-lock lock)) - ;; OS error return value? (if timeout - (progn - (ccl:timed-wait-on-semaphore cv timeout) - t) - (ccl:wait-on-semaphore cv))) - (unless lock-error + (ccl:timed-wait-on-semaphore cv timeout) + (ccl:wait-on-semaphore cv))) ;XXX nil here is some kind of error + (unless lock-error ; We didn't have the lock. (ccl:grab-lock lock))))) (defun condition-notify (cv)

1 0

[mcclim-cvs] CVS update: mcclim/input.lisp
by tmoore＠common-lisp.net 01 Jul '05

01 Jul '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv25618 Modified Files: input.lisp Log Message: In condition-wait, pass through return value of OpenMCL function. Date: Fri Jul 1 14:59:39 2005 Author: tmoore Index: mcclim/input.lisp diff -u mcclim/input.lisp:1.32 mcclim/input.lisp:1.33 --- mcclim/input.lisp:1.32 Sun Oct 31 02:46:31 2004 +++ mcclim/input.lisp Fri Jul 1 14:59:39 2005 @@ -228,33 +228,33 @@ (check-schedule eq) (let ((lock (event-queue-lock eq))) (with-lock-held (lock) - (with-slots (schedule-time) eq - (flet ((pred () - (not (null (event-queue-head eq))))) - (cond - (timeout - (loop as timeout-time = (+ now timeout) - with now = (now) - do (when (pred) - (return t)) - do (when (>= now timeout-time) - (return nil)) - do (let ((timeout (if schedule-time - (min (- schedule-time now) - (- timeout-time now)) - (- timeout-time now)))) - (condition-wait (event-queue-processes eq) - lock timeout)) - do (check-schedule eq))) - (schedule-time - (loop do (when (pred) - (return t)) - do (condition-wait - (event-queue-processes eq) lock (- schedule-time (now))) - do (check-schedule eq))) - (t - (or (pred) - (progn + (with-slots (schedule-time) eq + (flet ((pred () + (not (null (event-queue-head eq))))) + (cond + (timeout + (loop as timeout-time = (+ now timeout) + with now = (now) + do (when (pred) + (return t)) + do (when (>= now timeout-time) + (return nil)) + do (let ((timeout (if schedule-time + (min (- schedule-time now) + (- timeout-time now)) + (- timeout-time now)))) + (condition-wait (event-queue-processes eq) + lock timeout)) + do (check-schedule eq))) + (schedule-time + (loop do (when (pred) + (return t)) + do (condition-wait + (event-queue-processes eq) lock (- schedule-time (now))) + do (check-schedule eq))) + (t + (or (pred) + (progn (condition-wait (event-queue-processes eq) lock) t)))))))))

1 0