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

[mcclim-cvs] CVS update: mcclim/builtin-commands.lisp mcclim/commands.lisp
by tmoore＠common-lisp.net 22 Jun '05

22 Jun '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv22538 Modified Files: builtin-commands.lisp commands.lisp Log Message: Fixed the Help command to not display duplicates i.e., commands accessible via more than one inherited command table. Fixed a bug in command-line-name-for-command; it wasn't looking in inherited command tables. Changed the presentation method for command-name to output the symbol if the command isn't accessable instead of pretending that nothing's wrong and creating a command line name. Date: Wed Jun 22 13:41:35 2005 Author: tmoore Index: mcclim/builtin-commands.lisp diff -u mcclim/builtin-commands.lisp:1.19 mcclim/builtin-commands.lisp:1.20 --- mcclim/builtin-commands.lisp:1.19 Wed Jun 22 11:49:15 2005 +++ mcclim/builtin-commands.lisp Wed Jun 22 13:41:34 2005 @@ -42,15 +42,18 @@ (push (cons name command) command-names)) command-table) + (setf command-names (remove-duplicates command-names :key #'cdr)) (setf command-names (sort command-names #'(lambda (a b) (string-lessp (car a) (car b))))) (formatting-item-list (*query-io*) - (loop for (nil . command) in command-names - do (progn - (formatting-cell (*query-io*) - (present command `(command-name :command-table ,command-table) - :stream *query-io*)))))))) + (loop + for (nil . command) in command-names + do (formatting-cell (*query-io*) + (present command + `(command-name :command-table ,command-table) + :stream *query-io*))))))) + ;;; Describe command. I don't know if this should go in the global command ;;; table, but we don't exactly have a surplus of commands yet... Index: mcclim/commands.lisp diff -u mcclim/commands.lisp:1.52 mcclim/commands.lisp:1.53 --- mcclim/commands.lisp:1.52 Wed Jun 22 11:49:15 2005 +++ mcclim/commands.lisp Wed Jun 22 13:41:35 2005 @@ -316,20 +316,17 @@ (defun command-line-name-for-command (command-name command-table &key (errorp t)) - (block exit ; save typing - (do-command-table-inheritance (table command-table) - (let* ((command-item (gethash command-name (slot-value table 'commands))) - (command-line-name (and command-item - (command-line-name command-item)))) - (cond ((stringp command-line-name) - (return-from exit command-line-name)) - ((eq errorp :create) - (return-from exit (command-name-from-symbol command-name))) - (errorp - (error 'command-not-accessible)) - (t nil)))) - nil)) - + (do-command-table-inheritance (table command-table) + (let* ((command-item (gethash command-name (slot-value table 'commands))) + (command-line-name (and command-item + (command-line-name command-item)))) + (when (stringp command-line-name) + (return-from command-line-name-for-command command-line-name)))) + (cond ((eq errorp :create) + (command-name-from-symbol command-name)) + (errorp + (error 'command-not-accessible)) + (t nil))) (defun find-menu-item (menu-name command-table &key (errorp t)) (let* ((table (find-command-table command-table)) @@ -1081,11 +1078,13 @@ (define-presentation-method present (object (type command-name) stream (view textual-view) - &key acceptably for-context-type) + &key) (declare (ignore acceptably for-context-type)) - (princ (command-line-name-for-command object command-table :errorp :create) - stream)) - + (let ((command-line-name (command-line-name-for-command object command-table + :errorp nil))) + (if command-line-name + (write-string command-line-name stream) + (prin1 object stream)))) (define-presentation-method accept ((type command-name) stream (view textual-view)

1 0

[mcclim-cvs] CVS update: mcclim/builtin-commands.lisp mcclim/commands.lisp mcclim/input-editing.lisp mcclim/panes.lisp mcclim/presentation-defs.lisp
by tmoore＠common-lisp.net 22 Jun '05

22 Jun '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15930 Modified Files: builtin-commands.lisp commands.lisp input-editing.lisp panes.lisp presentation-defs.lisp Log Message: Added some improvements to accept-from-string so that random accept methods and default processing are more likely to work with it. Added a null command and null-command presentation type so that the REPL doesn't print something obnoxious when the user enters an empty command. Some fixes to default processing. Date: Wed Jun 22 11:49:16 2005 Author: tmoore Index: mcclim/builtin-commands.lisp diff -u mcclim/builtin-commands.lisp:1.18 mcclim/builtin-commands.lisp:1.19 --- mcclim/builtin-commands.lisp:1.18 Sat Jan 22 09:42:40 2005 +++ mcclim/builtin-commands.lisp Wed Jun 22 11:49:15 2005 @@ -24,6 +24,10 @@ ;;; Global help command +(define-command (com-null-command :command-table global-command-table :name nil) + () + nil) + (define-command (com-help :command-table global-command-table :name "Help") ((kind '(completion (("Keyboard" keyboard) ("Commands" commands)) :value-key cadr) Index: mcclim/commands.lisp diff -u mcclim/commands.lisp:1.51 mcclim/commands.lisp:1.52 --- mcclim/commands.lisp:1.51 Mon Jan 24 10:36:00 2005 +++ mcclim/commands.lisp Wed Jun 22 11:49:15 2005 @@ -1216,6 +1216,23 @@ (position *unsupplied-argument-marker* command))) (t (values command type))))) +;;; A presentation type for empty input at the command line; something for +;;; read-command to supply as a default. The command is defined in +;;; builtin-commands.lisp. + +(define-presentation-type null-command + () + :inherit-from '(command :command-table global-command-table)) + +(define-presentation-method presentation-typep (object (type null-command)) + (and (consp object) (eq (car object) 'com-null-command))) + +(define-presentation-method present + (object (type null-command) stream (view textual-view) &key) + (declare (ignore object stream view))) + +(defparameter +null-command+ '(com-null-command)) + (defclass presentation-command-translator (presentation-translator) () (:documentation "Wraps the tester function with a test that @@ -1308,16 +1325,20 @@ ((or (typep stream 'interactor-pane) (typep stream 'input-editing-stream)) (handler-case - (let ((command (accept `(command :command-table ,command-table) - :stream stream - :prompt nil))) - (if (partial-command-p command) - (progn - (beep) - (format *query-io* "~&Argument ~D not supplied.~&" - (position *unsupplied-argument-marker* command)) - nil) - command)) + (multiple-value-bind (command ptype) + (accept `(command :command-table ,command-table) + :stream stream + :prompt nil + :default +null-command+ + :default-type 'null-command) + (cond ((eq ptype 'null-command) + nil) + ((partial-command-p command) + (beep) + (format *query-io* "~&Argument ~D not supplied.~&" + (position *unsupplied-argument-marker* command)) + nil) + (t command))) ((or simple-parse-error input-not-of-required-type) (c) (beep) (fresh-line *query-io*) Index: mcclim/input-editing.lisp diff -u mcclim/input-editing.lisp:1.46 mcclim/input-editing.lisp:1.47 --- mcclim/input-editing.lisp:1.46 Sun Feb 27 01:06:27 2005 +++ mcclim/input-editing.lisp Wed Jun 22 11:49:15 2005 @@ -869,7 +869,8 @@ ;;; not. ;;; XXX Actually, it would be a violation of the `accept' protocol to consume ;;; the gesture, but who knows what random accept methods are doing. -(defun empty-input-p (stream begin-scan-pointer completion-gestures) +(defun empty-input-p + (stream begin-scan-pointer activation-gestures delimiter-gestures) (let ((scan-pointer (stream-scan-pointer stream)) (fill-pointer (fill-pointer (stream-input-buffer stream)))) ;; activated? @@ -881,7 +882,8 @@ (let ((gesture (aref (stream-input-buffer stream) begin-scan-pointer))) (and (characterp gesture) - (gesture-match gesture completion-gestures)))) + (or (gesture-match gesture activation-gestures) + (gesture-match gesture delimiter-gestures))))) (t nil)))) ;;; The control flow in here might be a bit confusing. The handler catches @@ -900,13 +902,15 @@ (unless (input-editing-stream-p stream) (return-from invoke-handle-empty-input (funcall input-continuation))) (let ((begin-scan-pointer (stream-scan-pointer stream)) - (completion-gestures *completion-gestures*)) + (activation-gestures *activation-gestures*) + (delimiter-gestures *delimiter-gestures*)) (block empty-input (handler-bind (((or simple-parse-error empty-input-condition) #'(lambda (c) (when (empty-input-p stream begin-scan-pointer - completion-gestures) + activation-gestures + delimiter-gestures) (if (typep c 'empty-input-condition) (signal c) (signal 'empty-input-condition :stream stream)) @@ -914,4 +918,5 @@ (return-from empty-input nil))))) (return-from invoke-handle-empty-input (funcall input-continuation)))) (funcall handler-continuation))) + Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.152 mcclim/panes.lisp:1.153 --- mcclim/panes.lisp:1.152 Mon Mar 14 23:03:05 2005 +++ mcclim/panes.lisp Wed Jun 22 11:49:15 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.152 2005/03/14 22:03:05 tmoore Exp $ +;;; $Id: panes.lisp,v 1.153 2005/06/22 09:49:15 tmoore Exp $ (in-package :clim-internals) @@ -2518,7 +2518,9 @@ (defmethod close ((stream window-stream) &key abort) (declare (ignore abort)) - (disable-frame (pane-frame stream)) + (let ((frame (pane-frame stream))) + (when frame + (disown-frame (frame-manager frame) frame))) (call-next-method)) (define-application-frame a-window-stream (standard-encapsulating-stream Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.43 mcclim/presentation-defs.lisp:1.44 --- mcclim/presentation-defs.lisp:1.43 Fri Feb 25 15:15:17 2005 +++ mcclim/presentation-defs.lisp Wed Jun 22 11:49:15 2005 @@ -927,17 +927,44 @@ (declare (ignore type view other-args)) nil) +;;; XXX This needs work! It needs to do everything that accept does for +;;; expanding ptypes and setting up recursive call processing (defun accept-from-string (type string &rest args &key view - default - default-type + (default nil defaultp) + (default-type nil default-type-p) + activation-gestures additional-activation-gestures + delimiter-gestures additional-delimiter-gestures (start 0) (end (length string))) - (declare (ignore view default default-type)) - (with-input-from-string (stream string :start start :end end) - (with-keywords-removed (args (:start :end)) - (apply #'stream-accept stream type :view +textual-view+ args)))) + (declare (ignore view activation-gestures + additional-activation-gestures + delimiter-gestures additional-delimiter-gestures)) + (with-activation-gestures ((if additional-activations-p + additional-activation-gestures + activation-gestures) + :override activationsp) + (with-delimiter-gestures ((if additional-delimiters-p + additional-delimiter-gestures + delimiter-gestures) + :override delimitersp))) + (when (or (zerop (- end start)) + (let ((maybe-end)))) + (if defaultp + (return-from accept-from-string (values default + (if default-type-p + default-type + type) + 0)) + (simple-parse-error "Empty string"))) + (let ((index 0)) + (multiple-value-bind (val ptype) + (with-input-from-string (stream string :start start :end end + :index index) + (with-keywords-removed (args (:start :end)) + (apply #'stream-accept stream type :view +textual-view+ args))) + (values val ptype index)))) (define-presentation-generic-function %presentation-refined-position-test presentation-refined-position-test

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-fonts.lisp mcclim/Experimental/freetype/mcclim-freetype.asd
by bmastenbrook＠common-lisp.net 18 Jun '05

18 Jun '05

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv24145 Modified Files: freetype-fonts.lisp mcclim-freetype.asd Log Message: Cache another routine that gets called alot; remove dependency on this xrender implementation Date: Sat Jun 18 03:56:44 2005 Author: bmastenbrook Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.6 mcclim/Experimental/freetype/freetype-fonts.lisp:1.7 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.6 Wed Jun 15 03:34:06 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Sat Jun 18 03:56:43 2005 @@ -290,20 +290,25 @@ (fmakunbound 'clim-clx::text-style-to-x-font) +(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* ((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)))) + (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))))) Index: mcclim/Experimental/freetype/mcclim-freetype.asd diff -u mcclim/Experimental/freetype/mcclim-freetype.asd:1.1 mcclim/Experimental/freetype/mcclim-freetype.asd:1.2 --- mcclim/Experimental/freetype/mcclim-freetype.asd:1.1 Sun Jun 5 22:50:29 2005 +++ mcclim/Experimental/freetype/mcclim-freetype.asd Sat Jun 18 03:56:43 2005 @@ -12,7 +12,7 @@ (list (component-pathname c))) (defsystem :mcclim-freetype - :depends-on (:xrender :clim :clx) + :depends-on (:clim :clx) :serial t :components ((:file "freetype-package")

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/windowing/port.lisp
by crhodes＠common-lisp.net 16 Jun '05

16 Jun '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory common-lisp.net:/tmp/cvs-serv5715/Backends/beagle/windowing Modified Files: port.lisp Log Message: Rearrange pointer class hierarchy a little, according to mail message "pointer protocol class / standard-pointer" mcclim-devel 2005-06-15. Date: Thu Jun 16 11:27:51 2005 Author: crhodes Index: mcclim/Backends/beagle/windowing/port.lisp diff -u mcclim/Backends/beagle/windowing/port.lisp:1.4 mcclim/Backends/beagle/windowing/port.lisp:1.5 --- mcclim/Backends/beagle/windowing/port.lisp:1.4 Tue May 17 22:26:38 2005 +++ mcclim/Backends/beagle/windowing/port.lisp Thu Jun 16 11:27:51 2005 @@ -38,14 +38,9 @@ ;;; at least a little about pointers, and it appears to all be handled in ;;; the back end at the moment. -(defclass beagle-pointer (pointer) +(defclass beagle-pointer (standard-pointer) ((cursor :accessor pointer-cursor :initform :upper-left))) - -(defclass standard-pointer (beagle-pointer) - ()) - - (defclass beagle-cursor () ((image :accessor cursor-image :initform nil) (hotspot :accessor cursor-hotspot :initform nil))) @@ -117,7 +112,7 @@ (slot-value port 'frame-managers)) (push (make-instance *default-frame-manager* :port port) (slot-value port 'frame-managers))) (setf (slot-value port 'pointer) - (make-instance 'standard-pointer :port port)) + (make-instance 'beagle-pointer :port port)) (setf *beagle-port* port) (initialize-beagle port))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/input/events.lisp
by crhodes＠common-lisp.net 16 Jun '05

16 Jun '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input In directory common-lisp.net:/tmp/cvs-serv5715/Backends/beagle/input Modified Files: events.lisp Log Message: Rearrange pointer class hierarchy a little, according to mail message "pointer protocol class / standard-pointer" mcclim-devel 2005-06-15. Date: Thu Jun 16 11:27:50 2005 Author: crhodes Index: mcclim/Backends/beagle/input/events.lisp diff -u mcclim/Backends/beagle/input/events.lisp:1.8 mcclim/Backends/beagle/input/events.lisp:1.9 --- mcclim/Backends/beagle/input/events.lisp:1.8 Sun Jun 5 21:52:55 2005 +++ mcclim/Backends/beagle/input/events.lisp Thu Jun 16 11:27:50 2005 @@ -28,7 +28,7 @@ #|| -$Id: events.lisp,v 1.8 2005/06/05 19:52:55 drose Exp $ +$Id: events.lisp,v 1.9 2005/06/16 09:27:50 crhodes Exp $ Events in Cocoa --------------- @@ -666,9 +666,8 @@ ;;; This has been added to McCLIM and the CLX back end; I'm not sure what it's supposed ;;; to be for. Never mind, add it anyway. defgeneric is in stream-input.lisp - ;;; SHOULD BE -> (defmethod synthesize-pointer-motion-event ((pointer beagle-pointer)) -(defmethod synthesize-pointer-motion-event (pointer) +(defmethod synthesize-pointer-motion-event ((pointer beagle-pointer)) ;; *-current-event-modifier-state-* is set whenever an event or notification is received ;; containing this information. ;; *-current-pointer-button-state-* is set whenever there is a mouse down or drag, and

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by crhodes＠common-lisp.net 16 Jun '05

16 Jun '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv5715/Backends/CLX Modified Files: port.lisp Log Message: Rearrange pointer class hierarchy a little, according to mail message "pointer protocol class / standard-pointer" mcclim-devel 2005-06-15. Date: Thu Jun 16 11:27:49 2005 Author: crhodes Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.111 mcclim/Backends/CLX/port.lisp:1.112 --- mcclim/Backends/CLX/port.lisp:1.111 Tue Apr 5 22:09:29 2005 +++ mcclim/Backends/CLX/port.lisp Thu Jun 16 11:27:49 2005 @@ -42,12 +42,9 @@ ;;; CLX-PORT class -(defclass clx-pointer (pointer) +(defclass clx-pointer (standard-pointer) ((cursor :accessor pointer-cursor :initform :upper-left))) -(defclass standard-pointer (clx-pointer) - ()) - #| Perhaps this belongs elsewhere @@ -207,7 +204,7 @@ (declare (ignore args)) (push (make-instance 'clx-frame-manager :port port) (slot-value port 'frame-managers)) (setf (slot-value port 'pointer) - (make-instance 'standard-pointer :port port)) + (make-instance 'clx-pointer :port port)) (initialize-clx port)) (defmethod print-object ((object clx-port) stream)

1 0

[mcclim-cvs] CVS update: mcclim/stream-input.lisp
by crhodes＠common-lisp.net 16 Jun '05

16 Jun '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv5715 Modified Files: stream-input.lisp Log Message: Rearrange pointer class hierarchy a little, according to mail message "pointer protocol class / standard-pointer" mcclim-devel 2005-06-15. Date: Thu Jun 16 11:27:49 2005 Author: crhodes Index: mcclim/stream-input.lisp diff -u mcclim/stream-input.lisp:1.42 mcclim/stream-input.lisp:1.43 --- mcclim/stream-input.lisp:1.42 Tue Feb 22 15:00:11 2005 +++ mcclim/stream-input.lisp Thu Jun 16 11:27:49 2005 @@ -637,6 +637,13 @@ (define-protocol-class pointer () ((port :reader port :initarg :port))) +;;; FIXME: I think the standard-pointer should absorb some of the +;;; common methods that are currently entirely provided by the +;;; backends. + +(defclass standard-pointer (pointer) + ()) + (defgeneric pointer-sheet (pointer)) (defmethod pointer-sheet ((pointer pointer))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/package.lisp mcclim/Apps/Inspector/INSTALL mcclim/Apps/Inspector/clouseau.asd
by crhodes＠common-lisp.net 15 Jun '05

15 Jun '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv13195 Modified Files: INSTALL clouseau.asd Added Files: package.lisp Log Message: Make clouseau.asd loadable without McCLIM. Date: Wed Jun 15 11:04:43 2005 Author: crhodes Index: mcclim/Apps/Inspector/INSTALL diff -u mcclim/Apps/Inspector/INSTALL:1.4 mcclim/Apps/Inspector/INSTALL:1.5 --- mcclim/Apps/Inspector/INSTALL:1.4 Tue Feb 8 23:23:12 2005 +++ mcclim/Apps/Inspector/INSTALL Wed Jun 15 11:04:43 2005 @@ -1,8 +1,7 @@ Quick start =========== -1. Start your Lisp system and make sure you have ASDF and McCLIM in - your core file. +1. Start your Lisp system and make sure you have ASDF loaded. 2. (asdf:operate 'asdf:load-op :clouseau) Index: mcclim/Apps/Inspector/clouseau.asd diff -u mcclim/Apps/Inspector/clouseau.asd:1.5 mcclim/Apps/Inspector/clouseau.asd:1.6 --- mcclim/Apps/Inspector/clouseau.asd:1.5 Wed Mar 9 23:25:54 2005 +++ mcclim/Apps/Inspector/clouseau.asd Wed Jun 15 11:04:43 2005 @@ -20,17 +20,10 @@ ;;; CLIM inspector application -(defpackage :clouseau - (:use :clim-lisp :clim) - (:export #:inspector - #:inspect-object - #:inspect-object-briefly - #:define-inspector-command - #:inspector-table - #:inspector-table-row)) - (asdf:defsystem clouseau + :depends-on (:mcclim) :serial t :components - ((:file "disassembly") - (:file "inspector"))) \ No newline at end of file + ((:file "package") + (:file "disassembly") + (:file "inspector")))

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-fonts.lisp
by bmastenbrook＠common-lisp.net 15 Jun '05

15 Jun '05

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv17684 Modified Files: freetype-fonts.lisp Log Message: Add a little caching to make-vague-font and make-concrete-font; this seems to fix the fd leake in make-concrete-font which eventually results in an unchecked error return code from Freetype and a NULL pointer deref the next time we call into Freetype. Date: Wed Jun 15 03:34:06 2005 Author: bmastenbrook Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.5 mcclim/Experimental/freetype/freetype-fonts.lisp:1.6 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.5 Tue Jun 14 02:07:56 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Wed Jun 15 03:34:06 2005 @@ -35,30 +35,43 @@ ((lib :initarg :lib) (filename :initarg :filename))) +(defparameter *vague-font-hash* (make-hash-table :test #'equal)) + (defun make-vague-font (filename) - (make-instance 'vague-font - :lib (let ((libf (make-alien freetype:library))) - (declare (type (alien (* freetype:library)) libf)) - (freetype:init-free-type libf) - (deref libf)) - :filename filename)) + (let ((val (gethash filename *vague-font-hash*))) + (or val + (setf (gethash filename *vague-font-hash*) + (make-instance 'vague-font + :lib (let ((libf (make-alien freetype:library))) + (declare (type (alien (* freetype:library)) libf)) + (freetype:init-free-type libf) + (deref libf)) + :filename filename))))) (defparameter *dpi* 72) +(defparameter *concrete-font-hash* (make-hash-table :test #'equal)) + (defun make-concrete-font (vague-font size &key (dpi *dpi*)) (with-slots (lib filename) vague-font - (let ((facef (make-alien freetype:face))) - (declare (type (alien (* freetype:face)) facef)) - (freetype:new-face lib filename 0 facef) - (let ((face (deref facef))) - (declare (type (alien freetype:face) face)) - (freetype:set-char-size face 0 (round (* size 64)) (round dpi) (round dpi)) - face)))) + (let* ((key (cons lib filename)) + (val (gethash key *concrete-font-hash*))) + (unless val + (let ((facef (make-alien freetype:face))) + (declare (type (alien (* freetype:face)) facef)) + (if (zerop (freetype:new-face lib filename 0 facef)) + (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)))) (declaim (inline make-concrete-font)) (defun glyph-pixarray (face char) - (declare (optimize (speed 3) (safety 3) (debug 1)) + (declare (optimize (speed 3) (debug 1)) (inline freetype:load-glyph freetype:render-glyph) (type (alien freetype:face) face)) (freetype:load-glyph face (freetype:get-char-index face (char-code char)) 0)

1 0

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

14 Jun '05

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv22084 Modified Files: freetype-fonts.lisp Log Message: Add keywords to the fonts -> filenames table Date: Tue Jun 14 02:07:56 2005 Author: bmastenbrook Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.4 mcclim/Experimental/freetype/freetype-fonts.lisp:1.5 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.4 Fri Jun 10 15:58:31 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Tue Jun 14 02:07:56 2005 @@ -259,18 +259,18 @@ (defparameter *families/faces* '(((:fix :roman) . "VeraMono.ttf") ((:fix :italic) . "VeraMoIt.ttf") - ((:fix (:bold italic)) . "VeraMoBI.ttf") - ((:fix (:italic bold)) . "VeraMoBI.ttf") + ((:fix (:bold :italic)) . "VeraMoBI.ttf") + ((:fix (:italic :bold)) . "VeraMoBI.ttf") ((:fix :bold) . "VeraMoBd.ttf") ((:serif :roman) . "VeraSe.ttf") ((:serif :italic) . "VeraSe.ttf") - ((:serif (:bold italic)) . "VeraSeBd.ttf") - ((:serif (:italic bold)) . "VeraSeBd.ttf") + ((:serif (:bold :italic)) . "VeraSeBd.ttf") + ((:serif (:italic :bold)) . "VeraSeBd.ttf") ((:serif :bold) . "VeraSeBd.ttf") ((:sans-serif :roman) . "Vera.ttf") ((:sans-serif :italic) . "VeraIt.ttf") - ((:sans-serif (:bold italic)) . "VeraBI.ttf") - ((:sans-serif (:italic bold)) . "VeraBI.ttf") + ((:sans-serif (:bold :italic)) . "VeraBI.ttf") + ((:sans-serif (:italic :bold)) . "VeraBI.ttf") ((:sans-serif :bold) . "VeraBd.ttf"))) (defvar *freetype-font-path*) @@ -284,7 +284,7 @@ (cond (size (setf size (getf *sizes* size size)) (let* ((font-path-relative (cdr (assoc (list family face) *families/faces* - :test #'equal))) + :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)

1 0