mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[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

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

01 Jul '05

Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv25582 Added Files: stopwatch.lisp Log Message: Example of running a simulation that sends asynchronous events to the main CLIM application thread. Date: Fri Jul 1 14:58:20 2005 Author: tmoore

1 0

[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

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