diff --git a/ChangeLog.n b/ChangeLog.n index 6777933f1b0c727411b730fdbf1675ff2cb2b9ee..92a1025289a48f5e73a69948fe3db00fe44dc97f 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -1,3 +1,26 @@ +******************************************************************************* +join from trunk_afuchs2 to trunk + changes from: + 2007-03-28 Andreas Fuchs <afuchs@franz.com> + +******************************************************************************* +2007-03-28 Andreas Fuchs <afuchs@franz.com> + + * silica/classes.lisp: Back out experimental code. + * silica/text-style.lisp: Back out experimental code. + * tk/font.lisp: Back out experimental code. + * tk/resources.lisp: Back out experimental code. + * tk/widget.lisp: Back out experimental code. + * tk/xlib.lisp: Back out experimental code. + * tk/xm-defs.lisp: Back out experimental code. + * tk/xm-font-list.lisp: Back out experimental code. + * tk/xm-widgets.lisp: Back out experimental code. + * tk/xt-defs.lisp: Back out experimental code. + * tk/xt-funs.lisp: Back out experimental code. + * tk-silica/xt-silica.lisp: Back out experimental code. + * utils/lisp-utilities.lisp: Back out experimental code. + * xlib/xlib-defs.lisp: Back out experimental code. + 2007-03-15 <layer@HOBART> * aclpc/acl-class.lisp: remove warning due to bogus decl @@ -6121,4 +6144,4 @@ IGNORE JDI SPECIFIC CHANGES TO Makefile Lots of other stuff ******************************************************************************* -$Revision: 2.29 $ +$Revision: 2.30 $ diff --git a/silica/classes.lisp b/silica/classes.lisp index 8c6f9bde9cdd17ecfc4e3e626b1dbfab2f4d9a85..d7330b1f5b5f898b088bf1b5dfadfb27559ff9a6 100644 --- a/silica/classes.lisp +++ b/silica/classes.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: classes.lisp,v 2.7 2006/10/10 18:05:08 layer Exp $ +;; $Id: classes.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $ (in-package :silica) @@ -84,9 +84,9 @@ #-(or aclpc acl86win32) (defun mapping-table-initform () (excl:ics-target-case - (:+ics (let ((v (make-array 4 :adjustable t))) + (:+ics (let ((v (make-array 4))) (dotimes (i 4) - (setf (aref v i) + (setf (svref v i) (make-hash-table :test #'equal))) v)) (:-ics (make-hash-table :test #'equal)))) @@ -94,9 +94,9 @@ #-(or aclpc acl86win32) (defun mapping-cache-initform () (excl:ics-target-case - (:+ics (let ((v (make-array 4 :adjustable t))) + (:+ics (let ((v (make-array 4))) (dotimes (i 4) - (setf (aref v i) + (setf (svref v i) (cons nil nil))) v)) (:-ics (cons nil nil)))) diff --git a/silica/text-style.lisp b/silica/text-style.lisp index d63382da83275a9f7fbdbe14cbec30c7d18d436d..64e6c1b80c985b98c88439e8e7b87ad39ca11ead 100644 --- a/silica/text-style.lisp +++ b/silica/text-style.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: text-style.lisp,v 2.8 2006/10/11 16:16:30 layer Exp $ +;; $Id: text-style.lisp,v 2.9 2007/04/02 18:07:42 layer Exp $ (in-package :silica) @@ -151,27 +151,27 @@ ;;; if we want. (defun make-text-style (family face size &aux changed-p original-face) (unless (numberp face) - (setf original-face face - face (face->face-code face))) ;"Intern" the face code. + (setf original-face face + face (face->face-code face))) ;"Intern" the face code. (loop - (let* ((family-stuff (assoc family *text-style-intern-table*)) - (face-stuff (and family-stuff (assoc face (cdr family-stuff)))) - (size-stuff (and face-stuff (assoc size (cdr face-stuff))))) - (when size-stuff (return-from make-text-style (cdr size-stuff))) - (multiple-value-setq (family face size changed-p original-face) - (validate-text-style-components family face size original-face)) - (unless changed-p - (macrolet ((ensure-stuff (stuff thing from-stuff) - `(unless ,stuff - (setf ,stuff (cons ,thing nil)) - (with-lock-held (*text-style-lock* "Text style lock") - (setf ,from-stuff (nconc ,from-stuff (cons ,stuff nil))))))) - (ensure-stuff family-stuff family *text-style-intern-table*) - (ensure-stuff face-stuff face family-stuff) - (ensure-stuff size-stuff size face-stuff)) - (let* ((new-style (make-text-style-1 family face size nil))) - (setf (cdr size-stuff) new-style) - (return-from make-text-style new-style)))))) + (let* ((family-stuff (assoc family *text-style-intern-table*)) + (face-stuff (and family-stuff (assoc face (cdr family-stuff)))) + (size-stuff (and face-stuff (assoc size (cdr face-stuff))))) + (when size-stuff (return-from make-text-style (cdr size-stuff))) + (multiple-value-setq (family face size changed-p original-face) + (validate-text-style-components family face size original-face)) + (unless changed-p + (macrolet ((ensure-stuff (stuff thing from-stuff) + `(unless ,stuff + (setf ,stuff (cons ,thing nil)) + (with-lock-held (*text-style-lock* "Text style lock") + (setf ,from-stuff (nconc ,from-stuff (cons ,stuff nil))))))) + (ensure-stuff family-stuff family *text-style-intern-table*) + (ensure-stuff face-stuff face family-stuff) + (ensure-stuff size-stuff size face-stuff)) + (let* ((new-style (make-text-style-1 family face size nil))) + (setf (cdr size-stuff) new-style) + (return-from make-text-style new-style)))))) (defmethod text-style-index ((text-style standard-text-style)) (let ((index (slot-value text-style 'index))) @@ -628,66 +628,56 @@ (defmethod port-mapping-table ((port basic-port) character-set) (with-slots (mapping-table) port - #+allegro - (excl:ics-target-case - (:-ics character-set mapping-table) - (:+ics (let ((old-length (length mapping-table))) - (when (>= character-set (length mapping-table)) - (setf mapping-table (adjust-array mapping-table (1+ character-set))) - (dotimes (i (- (length mapping-table) old-length)) - (setf (aref mapping-table (+ i old-length)) (make-hash-table :test #'equal))))) - (aref mapping-table character-set))) - #-allegro - mapping-table)) + #+allegro + (excl:ics-target-case + (:-ics character-set mapping-table) + (:+ics (svref mapping-table character-set))) + #-allegro + mapping-table)) (defmethod port-mapping-cache ((port basic-port) character-set) (with-slots (mapping-cache) port - #+allegro - (excl:ics-target-case - (:-ics character-set mapping-cache) - (:+ics (let ((old-length (length mapping-cache))) - (when (>= character-set (length mapping-cache)) - (setf mapping-cache (adjust-array mapping-cache (1+ character-set))) - (dotimes (i (- (length mapping-cache) old-length)) - (setf (aref mapping-cache (+ i old-length)) (cons nil nil))))) - (aref mapping-cache character-set))) - #-allegro - mapping-cache)) + #+allegro + (excl:ics-target-case + (:-ics character-set mapping-cache) + (:+ics (svref mapping-cache character-set))) + #-allegro + mapping-cache)) (defmethod (setf text-style-mapping) (mapping (port basic-port) style - &optional (character-set *standard-character-set*) - window) + &optional (character-set *standard-character-set*) + window) (declare (ignore window)) (setq style (standardize-text-style port (parse-text-style style) character-set)) (when (listp mapping) (assert (eq (first mapping) :style) () - "Text style mappings must be atomic font names ~ + "Text style mappings must be atomic font names ~ or (:STYLE . (family face size))") (setf mapping (parse-text-style (cdr mapping)))) (with-slots (allow-loose-text-style-size-mapping) port - (let ((mapping-table (port-mapping-table port character-set)) - (mapping-cache (port-mapping-cache port character-set))) - (without-scheduling - (setf (car mapping-cache) nil - (cdr mapping-cache) nil)) - (if allow-loose-text-style-size-mapping ; ### <----!!! - (multiple-value-bind (family face size) (text-style-components style) - (declare (ignore size)) - ;; NB: loose size mapping requires an EQUAL hash table! - (with-stack-list (key family face) - (let* ((fonts (gethash key mapping-table)) - (old (assoc style fonts))) - (cond (old - (setf (second old) mapping)) - (t - (push (list style mapping) fonts) - (setq fonts (sort fonts #'(lambda (e1 e2) - (< (text-style-size (first e1)) - (text-style-size (first e2)))))) - (setf (gethash (copy-list key) mapping-table) - fonts))) - mapping))) - (setf (gethash style mapping-table) mapping))))) + (let ((mapping-table (port-mapping-table port character-set)) + (mapping-cache (port-mapping-cache port character-set))) + (without-scheduling + (setf (car mapping-cache) nil + (cdr mapping-cache) nil)) + (if allow-loose-text-style-size-mapping + (multiple-value-bind (family face size) (text-style-components style) + (declare (ignore size)) + ;; NB: loose size mapping requires an EQUAL hash table! + (with-stack-list (key family face) + (let* ((fonts (gethash key mapping-table)) + (old (assoc style fonts))) + (cond (old + (setf (second old) mapping)) + (t + (push (list style mapping) fonts) + (setq fonts (sort fonts #'(lambda (e1 e2) + (< (text-style-size (first e1)) + (text-style-size (first e2)))))) + (setf (gethash (copy-list key) mapping-table) + fonts))) + mapping))) + (setf (gethash style mapping-table) mapping))))) (defmethod (setf text-style-mapping) (mapping (port basic-port) (style device-font) &optional (character-set *standard-character-set*) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index a9142d53e46a501dfaa551f1bf4c97a8d9dabf56..08aa87b139a339e8d5ae38b1c16c445ad5c1e4e8 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xt-silica.lisp,v 2.7 2006/10/10 18:05:08 layer Exp $ +;; $Id: xt-silica.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $ (in-package :xm-silica) @@ -37,7 +37,6 @@ (rotated-string-cache :initform nil :accessor port-rotated-string-cache) (depth :accessor port-depth) (visual-class :accessor port-visual-class) - (visual :accessor port-visual) (cursor-font :initform nil) (cursor-cache :initform nil) (font-cache :initform (make-hash-table :test #'equal)) @@ -62,20 +61,16 @@ ;; access to port-copy-gc should be within a without-scheduling -(defun make-pixmap (display depth) - (make-instance 'tk::pixmap - :drawable - (tk::display-root-window display) - :depth depth :width 1 :height 1)) - (defmethod port-copy-gc ((port xt-port)) ;;-- Assume 1-1 port-graft mapping? - (with-slots (copy-gc display depth) port + (with-slots (copy-gc display) port (or copy-gc (setf copy-gc (make-instance 'tk::gcontext - :drawable (make-pixmap display depth) - :graphics-exposures :on))))) + :display display + :graphics-exposures :on + :foreign-address (x11:screen-default-gc + (x11:xdefaultscreenofdisplay display))))))) ;;--- I don't know of a better way of getting a depth 1 drawable ;;other than by making a dummy depth 1 pixmap @@ -83,7 +78,10 @@ ;;-- Assume 1-1 port-graft mapping? (with-slots (copy-gc-depth-1 display) port (or copy-gc-depth-1 - (let ((pixmap (make-pixmap display 1))) + (let ((pixmap (make-instance 'tk::pixmap + :drawable + (tk::display-root-window display) + :depth 1 :width 1 :height 1))) (prog1 (setf copy-gc-depth-1 (make-instance 'tk::gcontext :drawable pixmap)) @@ -98,9 +96,7 @@ (mp:process-run-function (list :name (format nil "CLIM Event Dispatcher for ~A" (port-server-path port)) - :priority 1000 - :initial-bindings `((excl:*locale* . ',excl:*locale*) - ,@excl:*cl-default-special-bindings*)) + :priority 1000) #'port-event-loop port)) (setf (getf (mp:process-property-list process) :no-interrupts) t) (setf (port-process port) process))) @@ -114,95 +110,36 @@ (defmethod initialize-instance :after ((port xt-port) &key server-path) (setq tk::*x-io-error-hook* #'xt-fatal-error-handler) (destructuring-bind - (&key (display nil display-p) - (application-name nil application-name-p) - (application-class nil application-class-p) - (color-depth nil) - (visual-class nil)) + (&key (display nil display-p) + (application-name nil application-name-p) + (application-class nil application-class-p)) (cdr server-path) (let ((args nil)) (when display-p (setf (getf args :host) display)) (when application-name-p (setf (getf args :application-name) application-name)) (when application-class-p (setf (getf args :application-class) application-class)) (multiple-value-bind (context display application-shell) - (apply #'tk::initialize-toolkit args) - (setf (slot-value port 'application-shell) application-shell - (slot-value port 'context) context - (slot-value port 'display) display) - (initialize-port-visual-info port display application-shell color-depth visual-class) - (let* ((screen (x11:xdefaultscreenofdisplay display)) - (bs-p (not (zerop (x11::screen-backing-store screen)))) - (su-p (not (zerop (x11::screen-save-unders screen)))) - (vendor (excl:native-to-string (x11::display-vendor display)))) - (if (and bs-p su-p - (notany #'(lambda (x) (search x vendor)) *unreliable-server-vendors*)) - (setf (slot-value port 'safe-backing-store) t))) - (initialize-xlib-port port display))))) - - -(defparameter *visual-classes* - '((0 :static-gray) - (1 :gray-scale) - (2 :static-color) - (3 :pseudo-color) - (4 :true-color) - (5 :direct-color))) - -(defun initialize-port-visual-info (port display application-shell color-depth visual-class) - "Initializes the port's color-depth, visual-class and palette." - - ;; Make sure that we have a visual-class that makes sense. - (let ((default-visual-class (tk::screen-root-visual-class (tk::default-screen display)))) - (if visual-class - (unless (member visual-class *visual-classes* :key #'second) - (cerror "Use the default visual-class instead." - "The port's visual-class must be one of the following:~% ~{~S~^, ~}" - (mapcar #'second *visual-classes*)) - (setq visual-class default-visual-class)) - ;; Use default if no visual-class was specified. - (setq visual-class default-visual-class)) - - ;; Use default color-depth if none was specified. - (let ((default-depth (x11:xdefaultdepth display - (tk::display-screen-number display)))) - (unless color-depth - (setq color-depth default-depth)) - - ;; Try to find a visual of the specified color-depth and visual class. - ;; If we find one, use it. Otherwise, fall back to default settings. - (let* ((visual (find-visual display color-depth visual-class)) - (colormap (if visual - (tk::create-colormap display :visual visual) - (tk::default-colormap display)))) - (if (null visual) - (warn "Can't find ~A visual of color depth ~D. Using default visual instead." - visual-class color-depth)) - (when visual-class - (format *debug-io* "~&setting non-default visual ~A~%" visual) - (tk::set-values application-shell - :visual visual - :depth color-depth - :colormap colormap)) - (setf (port-depth port) (if visual color-depth default-depth) - (port-visual port) (when visual visual) - (port-visual-class port) (if visual visual-class default-visual-class)) - (setf (slot-value port 'silica::default-palette) - (make-palette port :colormap colormap)))))) - -(defun find-visual (display depth class) - (let ((screen (tk::display-screen-number display)) - (class-nr (first (find class *visual-classes* :key #'second))) - (visual-info (tk::note-malloced-object - (clim-utils::allocate-cstruct 'x11::visual-info :initialize t)))) - (let ((return-code (x11:xmatchvisualinfo display screen depth class-nr visual-info))) - (if (zerop return-code) - nil - (x11::visual-info-visual visual-info))))) - + (apply #'tk::initialize-toolkit args) + (setf (slot-value port 'application-shell) application-shell + (slot-value port 'context) context + (slot-value port 'display) display + (port-depth port) (x11:xdefaultdepth display (tk::display-screen-number display)) + (port-visual-class port) (tk::screen-root-visual-class (tk::default-screen display)) + (slot-value port 'silica::default-palette) + (make-palette port :colormap + (tk::default-colormap (port-display port)))) + (let* ((screen (x11:xdefaultscreenofdisplay display)) + (bs-p (not (zerop (x11::screen-backing-store screen)))) + (su-p (not (zerop (x11::screen-save-unders screen)))) + (vendor (excl:native-to-string (x11::display-vendor display)))) + (if (and bs-p su-p + ;; An amazing crock. XXX + (notany #'(lambda (x) (search x vendor)) *unreliable-server-vendors*)) + (setf (slot-value port 'safe-backing-store) t))) + (initialize-xlib-port port display))))) (defun xt-fatal-error-handler (d) (excl:without-interrupts - (break) (let* ((display (tk::find-object-from-address d)) (context (tk::display-context display))) (block done @@ -221,43 +158,6 @@ '(:static-color :true-color :pseudo-color :direct-color)) t)) -;;; SPR30362: - -(defvar *default-fallback-font* "fixed") - -(defun list-fonts-by-registry (display) - (let* ((fonts (tk::list-font-names display "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")) - (encoding-hash (make-hash-table :test #'equal))) - (dolist (font fonts) - (let ((font* (disassemble-x-font-name font))) - (push font (gethash (last font* 2) encoding-hash)))) - encoding-hash)) - -(defun find-font-with-properties (fonts weight slant) - (or (find (list weight slant) fonts - :test #'equal - :key (lambda (font) - (let ((font* (disassemble-x-font-name font))) - (list (nth 3 font*) (nth 4 font*))))) - (first fonts))) - -(defun font-name-of-aliased-font (display fontname) - (excl:with-native-string (nfn fontname) - (let ((font (x11:xloadqueryfont display nfn))) - (unless (zerop font) - (unwind-protect - (loop for i from 0 below (x11:xfontstruct-n-properties font) - for fontprop = (+ ;; this is horrible: - (* i 2 #-64bit 4 #+64bit 8) - (x11:xfontstruct-properties font)) - when (eql x11:xa-font (x11:xfontprop-name fontprop)) - do (return (values (excl:native-to-string - (x11:xgetatomname display - (x11:xfontprop-card32 fontprop)))))) - (x11:xfreefont display font)))))) - -;;; END SPR30362 - (defparameter *xt-font-families* `( ;; ascii @@ -313,77 +213,29 @@ (screen-pixels-per-inch (* 25.4 (/ (x11::xdisplayheight display screen) (x11:xdisplayheightmm display screen))))) - (labels ((font->text-style (font family) - (flet ((parse-token (token) - (if token - (parse-integer token) - (return-from font->text-style nil)))) - (let* ((tokens (disassemble-x-font-name font)) - (italic (member (nth 4 tokens) '("i" "o") :test #'equalp)) - (bold (equalp (nth 3 tokens) "bold")) - (face (if italic - (if bold '(:bold :italic) :italic) - (if bold :bold :roman))) - (pixel-size (parse-token (nth 7 tokens))) - (point-size (parse-token (nth 8 tokens))) - (y-resolution (parse-token (nth 10 tokens))) - (average-width (parse-token (nth 12 tokens))) - (corrected-point-size (* (float point-size) - (/ y-resolution - screen-pixels-per-inch)))) - (unless (and (not *use-scalable-fonts*) - (or (eql pixel-size 0) - (eql point-size 0) - (eql average-width 0))) - (make-text-style family face (/ corrected-point-size 10)))))) - (load-1-charset (character-set fallback families) - (let* ((matchesp nil) ;do any non-fallback fonts match? - (fallback-matches-p ;any fallback matches? - (not (null (tk::list-font-names display fallback)))) - (fallback-loadable-p ;fallback actually loadable? - (and fallback-matches-p - (excl:with-native-string (nfn fallback) - (let ((x (x11:xloadqueryfont display nfn))) - (if (not (zerop x)) - (progn - (x11:xfreefont display x) - t) - nil)))))) - (dolist (per-family families) - (destructuring-bind (family &rest patterns) per-family - (dolist (font-pattern patterns) - (dolist (xfont (tk::list-font-names display font-pattern)) - ;; this hack overcomes a bug with hp's scalable fonts - (unless (find #\* xfont) - (setf matchesp t) ;there was at least one match - (let ((text-style (font->text-style xfont family))) - ;; prefer first font satisfying this text style, so - ;; don't override if we've already defined one. - (when text-style - (unless (text-style-mapping-exists-p - port text-style character-set t) - (setf (text-style-mapping port text-style - character-set) - xfont))))))))) - ;; Set up the fallback if it looks like there is one, and - ;; complain if things look bad. Things look bad if there were - ;; matches but the fallback is not loadable. If there were - ;; no matches then don't complain even if there appears to be - ;; something wrong with the fallback, just silently don't load it - ;; (and thus define no mappings for the character set). - (cond - (fallback-loadable-p ;all is well - (setf (text-style-mapping port *undefined-text-style* - character-set) - fallback)) - ((and matchesp fallback-matches-p) - (warn "Fallback font ~A, for character set ~A, matches with XListFonts, -but is not loadable by XLoadQueryFont. Something may be wrong with the X font -setup." - fallback character-set)) - (matchesp - (warn "Fallback font ~A not loadable for character set ~A." - fallback character-set)))))) + (flet ((font->text-style (font family) + (flet ((parse-token (token) + (if token + (parse-integer token) + (return-from font->text-style nil)))) + (let* ((tokens (disassemble-x-font-name font)) + (italic (member (nth 4 tokens) '("i" "o") :test #'equalp)) + (bold (equalp (nth 3 tokens) "bold")) + (face (if italic + (if bold '(:bold :italic) :italic) + (if bold :bold :roman))) + (pixel-size (parse-token (nth 7 tokens))) + (point-size (parse-token (nth 8 tokens))) + (y-resolution (parse-token (nth 10 tokens))) + (average-width (parse-token (nth 12 tokens))) + (corrected-point-size (* (float point-size) + (/ y-resolution + screen-pixels-per-inch)))) + (unless (and (not *use-scalable-fonts*) + (or (eql pixel-size 0) + (eql point-size 0) + (eql average-width 0))) + (make-text-style family face (/ corrected-point-size 10))))))) ;; Setup font mappings. This is made hairy by trying to deal ;; elegantly with possibly missing mappings and messed-up X font ;; setups. It seems to be the case that XListFonts can return @@ -396,39 +248,55 @@ setup." ;; with it, but otherwise don't check. This should mean that if ;; this doesn't warn then things will basically run, as the ;; fallback exists for each character set, at least. - (let ((charset-number 0) - (done-registries ())) - (dolist (per-charset *xt-font-families*) - (destructuring-bind (character-set fallback &rest families) per-charset - (load-1-charset character-set fallback families) - (setf charset-number (max charset-number character-set)) - (dolist (family families) - (pushnew (last (disassemble-x-font-name (second family)) 2) done-registries - :test #'equal)))) - (format *debug-io* "done registries: ~A, last charset: ~A~%" done-registries charset-number) - ;; Now setup font mappings of fonts that the user has - ;; installed, but we don't know anything about (especially no - ;; convenient font aliases). - ;; Since we don't have any font alias names to rely on, we use - ;; the "fixed" alias to find out at least a sensible default - ;; weight and slant. - (let* ((default-fallback (disassemble-x-font-name (font-name-of-aliased-font display *default-fallback-font*))) - (weight (nth 3 default-fallback)) - (slant (nth 4 default-fallback))) - (loop for character-set from (1+ charset-number) - for encoding being the hash-keys of (list-fonts-by-registry display) using (hash-value fonts) - for fallback-font = (find-font-with-properties fonts weight slant) - for default-font-match-string = (format nil "-*-*-*-*-*-*-*-*-*-*-*-*-~A-~A" (first encoding) (second encoding)) - do (format *debug-io* "~®istering installed font ~A for enc:~A~%" character-set encoding) - do (unless (member encoding done-registries :test #'equal) - (vector-push-extend (excl:string-to-native - (format nil "~A-~A" (first encoding) (second encoding))) - tk::*font-list-tags*) - (load-1-charset character-set fallback-font - `((:fix ,default-font-match-string) - (:sans-serif ,default-font-match-string) - (:serif ,default-font-match-string)))))) - ))) + (dolist (per-charset *xt-font-families*) + (destructuring-bind (character-set fallback &rest families) per-charset + (let* ((matchesp nil) ;do any non-fallback fonts match? + (fallback-matches-p ;any fallback matches? + (not (null (tk::list-font-names display fallback)))) + (fallback-loadable-p ;fallback actually loadable? + (and fallback-matches-p + (excl:with-native-string (nfn fallback) + (let ((x (x11:xloadqueryfont display nfn))) + (if (not (zerop x)) + (progn + (x11:xfreefont display x) + t) + nil)))))) + (dolist (per-family families) + (destructuring-bind (family &rest patterns) per-family + (dolist (font-pattern patterns) + (dolist (xfont (tk::list-font-names display font-pattern)) + ;; this hack overcomes a bug with hp's scalable fonts + (unless (find #\* xfont) + (setf matchesp t) ;there was at least one match + (let ((text-style (font->text-style xfont family))) + ;; prefer first font satisfying this text style, so + ;; don't override if we've already defined one. + (when text-style + (unless (text-style-mapping-exists-p + port text-style character-set t) + (setf (text-style-mapping port text-style + character-set) + xfont))))))))) + ;; Set up the fallback if it looks like there is one, and + ;; complain if things look bad. Things look bad if there were + ;; matches but the fallback is not loadable. If there were + ;; no matches then don't complain even if there appears to be + ;; something wrong with the fallback, just silently don't load it + ;; (and thus define no mappings for the character set). + (cond + (fallback-loadable-p ;all is well + (setf (text-style-mapping port *undefined-text-style* + character-set) + fallback)) + ((and matchesp fallback-matches-p) + (warn "Fallback font ~A, for character set ~A, matches with XListFonts, +but is not loadable by XLoadQueryFont. Something may be wrong with the X font +setup." + fallback character-set)) + (matchesp + (warn "Fallback font ~A not loadable for character set ~A." + fallback character-set)))))))) (setup-stipples port display)) (defparameter *xt-logical-size-alist* @@ -1175,6 +1043,8 @@ setup." (excl:ics-target-case (:+ics +(defconstant +codesets+ 4) + (defmethod text-style-mapping :around ((port xt-port) text-style &optional (character-set *standard-character-set*) window) @@ -1186,16 +1056,18 @@ setup." (find-named-font port mapping character-set)) mapping)) (let ((mappings nil)) - (dotimes (c (length (slot-value port 'silica::mapping-table))) ; XXX: ugly. prettify. - (let ((mapping (text-style-mapping port text-style c))) + (dotimes (c +codesets+) + (let ((mapping (text-style-mapping port text-style c))) (when mapping - (push (cons c mapping) mappings)))) + (push (cons c mapping) mappings)))) (reverse mappings)))) (defmethod font-set-from-font-list ((port xt-port) font-list) - (let ((name (format nil "~{~A~^,~}" - (mapcar (lambda (font) (tk::font-name (cdr font))) - font-list)))) + (let ((name "")) + (dolist (item font-list) + (setq name + (concatenate 'string + (tk::font-name (cdr item)) "," name))) (with-slots (font-cache) port (setq font-list (or (gethash name font-cache) diff --git a/tk/font.lisp b/tk/font.lisp index 03d4b049396776603a0ef15cafff37ab830b542e..90a7e6ddde18654a355762bda435ba120b6fee8a 100644 --- a/tk/font.lisp +++ b/tk/font.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: font.lisp,v 2.7 2006/10/10 18:05:08 layer Exp $ +;; $Id: font.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $ (in-package :tk) @@ -184,15 +184,6 @@ (unless (zerop def-string) (excl:native-to-string def-string)))))) -(define-condition charsets-missing-from-fontset (warning) - ((charsets :initarg :charsets :accessor charsets-missing-from-fontset-charsets) - (created-for :initarg :created-for :accessor charsets-missing-from-fontset-created)) - (:report (lambda (stream c) - (format stream - "Missing charsets:~{ ~A,~} creating fontset for ~A" - (charsets-missing-from-fontset-charsets c) - (charsets-missing-from-fontset-created c))))) - (defmethod initialize-instance :after ((fs font-set) &key foreign-address display base-names) (unless foreign-address @@ -200,9 +191,8 @@ (create-font-set display base-names) (when missing (let ((*error-output* excl:*initial-terminal-io*)) - (warn 'charsets-missing-from-fontset - :charsets missing - :created-for base-names))) + (warn "Missing charsets:~{ ~A,~} creating fontset for ~A" + missing base-names))) (when (zerop x) (error "Cannot create fontset for ~S" base-names)) (setf (foreign-pointer-address fs) x) (register-address fs)))) diff --git a/tk/resources.lisp b/tk/resources.lisp index 961043b5106adffa7ca2be267efa3a7fe32e4742..c4d93bb94fcaeeaf14b204da72722a33c9781879 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: resources.lisp,v 2.7 2006/10/10 18:05:08 layer Exp $ +;; $Id: resources.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $ (in-package :tk) @@ -825,14 +825,3 @@ (make-instance 'font :display (widget-display parent) :foreign-address value)) - - -;;; Visual info - -(defmethod convert-resource-out (parent (type (eql 'visual)) value) - (declare (ignore parent)) - value) - -(defmethod convert-resource-out (parent (type (eql 'depth)) value) - (declare (ignore parent)) - value) \ No newline at end of file diff --git a/tk/widget.lisp b/tk/widget.lisp index 1abfca0c8ae610d32b4482e13fcf32a5f66b5f9a..059cc427d5c24e3290d789486361c8f03208f7df 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: widget.lisp,v 2.7 2006/10/10 18:05:08 layer Exp $ +;; $Id: widget.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $ (in-package :tk) @@ -360,36 +360,6 @@ (:+ics '("clim*xnlLanguage: japanese")))) "A list of resource specification strings") -(defparameter *external-formats-to-locale-charset-alist* - `((,(excl:find-external-format "UTF-8") . "UTF-8") - (,(excl:find-external-format "LATIN1") . "ISO-8859-1"))) - -(ff:defun-foreign-callable xt-current-locale-for-acl ((display (* :void)) (xnl (* :char)) (client-data (* :void))) - (declare (:convention :c) - (ignore display client-data xnl)) - - (labels ((ef-name (ef) - (if (excl:composed-external-format-p ef) - (or (ef-name (excl:ef-composer-ef ef)) - (ef-name (excl:ef-composee-ef ef))) - (cdr (assoc ef *external-formats-to-locale-charset-alist*)))) - (try-locale (locale) - (format *debug-io* "Trying locale ~A~%" locale) - (setlocale lc-all locale) - (let ((supported (x-supports-locale))) - (unless (zerop supported) - (x-set-locale-modifiers "") - (format *debug-io* "X supports locale!~%") - locale)))) - (let ((locale (excl:locale-name excl:*locale*)) - (encoding (ef-name (excl:locale-external-format excl:*locale*)))) - (or (if encoding - (try-locale (format nil "~A.~A" locale encoding)) - (warn "Couldn't determine unix encoding of locale ~A's external format. Falling back to default encoding for locale." excl:*locale*)) - (try-locale (format nil "~A" locale)) - ;; didn't find any locale. - (try-locale "C"))))) - ;; note that this is different from xt-initialize which calls ;; XtToolkitInitialize. This is closer to XtAppInitialize @@ -402,11 +372,11 @@ (with-*-array (v (1+ n)) (dotimes (i n) (setf (*-array v i) - (clim-utils:string-to-foreign (nth i *fallback-resources*)))) + (clim-utils:string-to-foreign (nth i *fallback-resources*)))) (setf (*-array v n) 0) v)))) - (excl:ics-target-case - (:+ics (xt_set_language_proc 0 (register-foreign-callable 'xt-current-locale-for-acl :reuse t) 0))) + #+ignore (excl:ics-target-case + (:+ics (xt_set_language_proc context 0 0))) (let* ((display (apply #'make-instance 'display :context context args)) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index ce201fae1f3c47a9168b2336c6947e30357d506f..1e04b3cf408137a10c8bd03978a8bf6235dc35cd 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xlib.lisp,v 2.8 2007/01/25 21:19:29 layer Exp $ +;; $Id: xlib.lisp,v 2.9 2007/04/02 18:07:42 layer Exp $ (in-package :tk) @@ -214,18 +214,6 @@ (error "Unknown resource type: ~A" type))) type)))))) -(defun put-resource (db specifier xrm-type type value) - (let ((xrmvalue (make-xrmvalue))) - (setf (x11:xrmvalue-size xrmvalue) (ff:sizeof-fobject type) - (x11:xrmvalue-addr xrmvalue) value) - (format *trace-output* "putting resource in db ~S spec:~S xrmval:~S xrmtype:~S type:~S value:~S~%" db specifier xrmvalue xrm-type type value) - (x11:xrmputresource db - (lisp-string-to-string8 specifier) - (lisp-string-to-string8 xrm-type) - xrmvalue) - (format *trace-output* "done.~%"))) - - (defun convert-string (widget string to-type) (let ((from (make-xrmvalue)) (to-in-out (make-xrmvalue))) @@ -343,19 +331,17 @@ (define-window-accessor colormap ()) -(defun create-colormap (display &key - (screen (display-screen-number display)) - (visual (x11:xdefaultvisual display screen))) +(defun create-colormap (display &optional (screen (display-screen-number display))) (intern-object-xid - (x11:xcreatecolormap display - (x11:xrootwindow display screen) - visual - x11:allocnone) + (x11:xcreatecolormap + display + (x11:xrootwindow display screen) + (x11:xdefaultvisual display screen) + x11:allocnone) 'colormap display :display display)) - (defun default-colormap (display &optional (screen (display-screen-number display))) (intern-object-xid (x11:xdefaultcolormap display screen) diff --git a/tk/xm-defs.lisp b/tk/xm-defs.lisp index 7768f3d9f5fe4b807e4b47be7500275f62b288a7..2ff515bdc791c21d155535a6d1ffc6e2a6869736 100644 --- a/tk/xm-defs.lisp +++ b/tk/xm-defs.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xm-defs.lisp,v 2.8 2006/10/10 18:05:08 layer Exp $ +;; $Id: xm-defs.lisp,v 2.9 2007/04/02 18:07:42 layer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -82,8 +82,3 @@ (def-c-type (xm-selected-position-array :no-defuns :no-constructor) 1 :int) (def-c-type (xm-string-table :no-defuns :no-constructor) 1 * :char) - -;;; string constants from Xm.h -(x11::def-exported-constant XmRColormap "Colormap") -(x11::def-exported-constant XmRVisual "Visual") -(x11::def-exported-constant XmRInt "Int") diff --git a/tk/xm-font-list.lisp b/tk/xm-font-list.lisp index 7f33117858c96ee8b9c37735591876eea37d7c3e..231c6daff351c941671426e094997b2125ff6daa 100644 --- a/tk/xm-font-list.lisp +++ b/tk/xm-font-list.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xm-font-list.lisp,v 2.7 2006/10/10 18:05:08 layer Exp $ +;; $Id: xm-font-list.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $ (in-package :tk) @@ -60,50 +60,49 @@ (excl:ics-target-case (:+ics (defvar *font-list-tags* - (make-array 4 :adjustable t :fill-pointer t - :initial-contents - (list - ;; bug13059/spr27144 - we want these strings to - ;; survive a dumplisp - (excl:string-to-native "ascii") - (excl:string-to-native "kanji") - (excl:string-to-native "katakana") - (excl:string-to-native "gaiji")) + (vector - )))) + ;; bug13059/spr27144 - we want these strings to survive a dumplisp + + (excl:string-to-native "ascii") + (excl:string-to-native "kanji") + (excl:string-to-native "katakana") + (excl:string-to-native "gaiji") + + )))) (defun export-font-list (value) (when (atom value) (setq value (list value))) - (flet ((create-font-list-entry (font) - (note-malloced-object - (excl:ics-target-case - (:+ics - (let ((tag "")) - (when (consp font) - (setq tag (aref *font-list-tags* (car font)) - font (cdr font))) - (xm_font_list_entry_create tag - (etypecase font - (font xm-font-is-font) - (font-set xm-font-is-fontset)) - font))) - (:-ics - ;; perhaps this should be xm-font-list-default-tag - (xm_font_list_entry_create "" - xm-font-is-font - font)))))) - (let ((font-list - (xm_font_list_append_entry - 0 ; old entry - (create-font-list-entry (car value))))) - (dolist (font (cdr value)) - (setq font-list - (xm_font_list_append_entry font-list - (create-font-list-entry font)))) - (note-malloced-object font-list - #'free-font-list)))) + (flet ((create-font-list-entry (font) + (note-malloced-object + (excl:ics-target-case + (:+ics + (let ((tag "")) + (when (consp font) + (setq tag (svref *font-list-tags* (car font)) + font (cdr font))) + (xm_font_list_entry_create tag + (etypecase font + (font xm-font-is-font) + (font-set xm-font-is-fontset)) + font))) + (:-ics + ;; perhaps this should be xm-font-list-default-tag + (xm_font_list_entry_create "" + xm-font-is-font + font)))))) + (let ((font-list + (xm_font_list_append_entry + 0 ; old entry + (create-font-list-entry (car value))))) + (dolist (font (cdr value)) + (setq font-list + (xm_font_list_append_entry font-list + (create-font-list-entry font)))) + (note-malloced-object font-list + #'free-font-list)))) #+:dec3100 (defmethod convert-resource-out ((parent t) (type (eql 'xm-font-list)) value) diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp index 049ffa2119661df0791aeb60a1db72a86590f292..3f941e2fae4a49e2a31d73ad720a59e9774973d6 100644 --- a/tk/xm-widgets.lisp +++ b/tk/xm-widgets.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xm-widgets.lisp,v 2.7 2006/10/10 18:05:08 layer Exp $ +;; $Id: xm-widgets.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $ (in-package :tk) @@ -162,7 +162,7 @@ (ecase codeset ((0 2) (lisp-string-to-string8 substring)) ((1 3) (lisp-string-to-string16 substring))) - (aref *font-list-tags* codeset)))) + (svref *font-list-tags* codeset)))) (tk::add-widget-cleanup-function parent #'destroy-generated-xm-string element) diff --git a/tk/xt-defs.lisp b/tk/xt-defs.lisp index 811367f3319c37e1f28009c4ff7a16e38822a866..3799c45460e11641da91f0db65e02cce1edcfa12 100644 --- a/tk/xt-defs.lisp +++ b/tk/xt-defs.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xt-defs.lisp,v 2.7 2006/10/10 18:05:08 layer Exp $ +;; $Id: xt-defs.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -147,5 +147,3 @@ (def-c-type (pointer-array :no-defuns :no-constructor) 1 * char) -(x11::def-exported-constant lc-ctype 0) -(x11::def-exported-constant lc-all 6) \ No newline at end of file diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp index 79f03b438f2a5428fdb6044f104599b891fb0e2d..1d03880dda02afc3c6d7280b86cbc0dc165cb9b4 100644 --- a/tk/xt-funs.lisp +++ b/tk/xt-funs.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xt-funs.lisp,v 2.8 2006/10/11 16:16:30 layer Exp $ +;; $Id: xt-funs.lisp,v 2.9 2007/04/02 18:07:42 layer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -396,18 +396,6 @@ :call-direct t :arg-checking nil) -(def-foreign-call (x-supports-locale "XSupportsLocale") - () - :returning (:int fixnum) - :strings-convert nil - :arg-checking nil) - -(def-foreign-call (x-set-locale-modifiers "XSetLocaleModifiers") - ((x :foreign-address)) - :call-direct t - :returning :foreign-address - :arg-checking nil) - #+debug (progn diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp index 5824d608e799f7f398374215eb5cf8898d59d38a..296ddd73573961c67274e3d1d9253ec0c22f978b 100644 --- a/utils/lisp-utilities.lisp +++ b/utils/lisp-utilities.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: lisp-utilities.lisp,v 2.7 2006/10/10 18:05:08 layer Exp $ +;; $Id: lisp-utilities.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $ (in-package :clim-utils) @@ -1699,35 +1699,23 @@ (setf (sys:memref-int pointer i 0 :unsigned-natural) 0))) pointer)) -;;; We aren't using excl:string-to-native by default because it uses -;;; excl:aclmalloc. -;; This now uses the slightly slower (locale-correct) way of -;; converting to octets first, then copying to foreign space. +;; Adapted from FF:STRING-TO-CHAR*. +;;; We aren't using FF:STRING-TO-CHAR* because it uses excl:aclmalloc. (defun string-to-foreign (string &optional address) "Convert a Lisp string to a C string, by copying." (declare (optimize (speed 3)) - (type string string) - (type integer address)) + (type string string) + (type integer address)) (unless (stringp string) (excl::.type-error string 'string)) - (if address - (excl:string-to-native string :address address) - (let* ((octets (excl:string-to-octets string :null-terminate t)) - (length (length octets))) - (declare (optimize (safety 0)) - (type fixnum length)) - (setf address (_malloc length)) - (dotimes (i length) - (declare (fixnum i)) - (setf (sys:memref-int address 0 i :unsigned-byte) - (aref octets i))) - #+clim-utils::extra-careful(let ((re-char-ed (excl:octets-to-string octets))) - (assert (equal re-char-ed string) - (re-char-ed string) - "string isn't equal to re-chared octets~%~S~%~S!" string re-char-ed)))) - - #+clim-utils::extra-careful(let ((re-lisped (excl:native-to-string address))) - (assert (equal re-lisped string) - (re-lisped string) - "string isn't equal to re-chared foreign mem ~%~S~%~S!" string re-lisped)) - address) + (let* ((length (length string))) + (declare (optimize (safety 0)) + (type fixnum length)) + (unless address + (setq address (_malloc (1+ length)))) + (dotimes (i length) + (declare (fixnum i)) + (setf (sys:memref-int address 0 i :unsigned-byte) + (char-code (char string i)))) + (setf (sys:memref-int address 0 length :unsigned-byte) 0) + address)) diff --git a/xlib/xlib-defs.lisp b/xlib/xlib-defs.lisp index d29d9cc536020f798690e05ce31974de1ac1e0dc..333aeafbb1dd917f6eb3da1fa9cd5c9c83d7dcf0 100644 --- a/xlib/xlib-defs.lisp +++ b/xlib/xlib-defs.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xlib-defs.lisp,v 2.7 2006/10/10 18:05:09 layer Exp $ +;; $Id: xlib-defs.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $ ;;; (c) Copyright 1990 Sun Microsystems, Inc. All Rights Reserved. ;; (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design @@ -707,18 +707,6 @@ (bits-per-rgb :type int) (map-entries :type int)) -(def-exported-foreign-struct visual-info - (visual :type (:pointer visual)) - (visual-id :type visualid) - (screen :type int) - (depth :type unsigned-int) - (class :type int) - (red-mask :type unsigned-long) - (green-mask :type unsigned-long) - (blue-mask :type unsigned-long) - (colormap-size :type int) - (bits-per-rgb :type int)) - (def-exported-foreign-struct depth (depth :type int) (nvisuals :type int)