[developers] [spr30362] bug using climxm
Berthold Crysmann
crysmann at dfki.de
Tue Oct 10 15:56:58 CEST 2006
Dear Andreas,
using your patch produces the follwing error message while trying to
compile our application:
Error: attempt to call `CLIM-UTILS::_MALLOC' which is an undefined
function.
[condition type: UNDEFINED-FUNCTION]
Restart actions (select using :continue):
0: Try calling CLIM-UTILS::_MALLOC again.
1: Return a value instead of calling CLIM-UTILS::_MALLOC.
2: Try calling a function other than CLIM-UTILS::_MALLOC.
3: Setf the symbol-function of CLIM-UTILS::_MALLOC and call it again.
4: Abort entirely from this (lisp) process.
[changing package from "COMMON-LISP-USER" to "LKB"]
[Current process: start-lkb-frame]
Andreas Fuchs wrote:
> Hello Berthold,
>
> Berthold Crysmann wrote:
> >> thanks for your mail.
> >>
> >> Actually, my standard locale is en_GB.UTF-8. I have tried that now
> >> --- with partial success.
> >>
> > 0. Opening the input widget for the first time, I get the following
> > error message:
> >
> > Warning: Missing charsets: ISO10646-1, GB2312.1980-0, KSC5601.1987-0,
> > creating fontset for
> >
> >
> -alias-fixed-medium-r-normal--10-100-75-75-c-50-jisx0201.1976-0,-alias-fixed-medium-r-normal--10-100-75-75-c-100-jisx0208.1983-0,-adobe-helvetica-medium-r-normal--8-80-75-75-p-46-iso8859-1,
>
>
> I have good news: The attached patch (to use, replace patch.lisp with
> it and compile & load it before running your application) removes that
> error message, along with these changes:
>
> * Allows display/editing of Korean (and other international) characters
> in climxm.
> If a font is available for the required registry/encoding, it will be
> loaded and available for text fields.
>
> * Gets the correct string value from text fields containing
> international characters.
>
> * Allows the locale to be set via (setf excl:*locale* ...) or via
> -locale on the command line. This makes the previous LET workaround
> unnecessary.
>
> It is still required that you use an allegro- and libc-compatible
> locale specification. I'll work on the compatibility check next. In
> any case, I recommend using a UTF-8 locale.
>
> Good luck,
> Andreas.
> ------------------------------------------------------------------------
>
> (eval-when (:compile-toplevel :load-toplevel :execute)
> (require :climxm))
>
> (in-package :silica)
>
>
> #-(or aclpc acl86win32)
> (defun mapping-table-initform ()
> (excl:ics-target-case
> (:+ics (let ((v (make-array 4 :adjustable t)))
> (dotimes (i 4)
> (setf (aref v i)
> (make-hash-table :test #'equal)))
> v))
> (:-ics (make-hash-table :test #'equal))))
>
> #-(or aclpc acl86win32)
> (defun mapping-cache-initform ()
> (excl:ics-target-case
> (:+ics (let ((v (make-array 4 :adjustable t)))
> (dotimes (i 4)
> (setf (aref v i)
> (cons nil nil)))
> v))
> (:-ics (cons nil nil))))
>
> (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.
> (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))))))
>
> (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))
>
> (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))
>
> (defmethod (setf text-style-mapping) (mapping (port basic-port) style
> &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 ~
> 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))
> (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))
> (print fonts *debug-io*))
> mapping)))
> (setf (gethash style mapping-table) mapping)))))
>
>
>
> (in-package :tk)
>
> (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")))))
>
> (defun initialize-toolkit (&rest args)
> (let ((context (create-application-context)))
> (when *fallback-resources*
> (xt_app_set_fallback_resources
> context
> (let ((n (length *fallback-resources*)))
> (with-*-array (v (1+ n))
> (dotimes (i n)
> (setf (*-array v i)
> (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)))
> (let* ((display (apply #'make-instance 'display
> :context context
> args))
> (app (apply #'app-create-shell
> :display display
> :widget-class 'application-shell
> args)))
> (values context display app))))
>
>
> (setf *font-list-tags*
> (make-array 4 :adjustable t :fill-pointer t
> :initial-contents
> (list
> (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
> (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))))
>
> (defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value)
> (let ((result nil))
> (flet ((extract-element (codeset start end)
> (let* ((substring (subseq value start end))
> (element (xm_string_create_l_to_r
> (ecase codeset
> ((0 2) (lisp-string-to-string8 substring))
> ((1 3) (lisp-string-to-string16 substring)))
> (aref *font-list-tags* codeset))))
> (tk::add-widget-cleanup-function parent
> #'destroy-generated-xm-string
> element)
> (let ((temp (if result
> (xm_string_concat result element)
> (xm_string_copy element))))
> (tk::add-widget-cleanup-function parent
> #'destroy-generated-xm-string
> temp)
> (setq result temp)))))
> (declare (dynamic-extent #'extract))
> (partition-compound-string value #'extract-element)
> (or result
> *empty-compound-string*
> (setq *empty-compound-string*
> (xm_string_create_l_to_r (clim-utils:string-to-foreign "")
> (clim-utils:string-to-foreign
> xm-font-list-default-tag)))))))
>
> (x11::def-exported-constant lc-ctype 0)
> (x11::def-exported-constant lc-all 6)
>
> (in-package :xt)
>
> (def-foreign-call (x-supports-locale "XSupportsLocale")
> ()
> :returning (:int fixnum)
> :arg-checking nil)
>
> (def-foreign-call (x-set-locale-modifiers "XSetLocaleModifiers")
> ((x :foreign-address))
> :call-direct t
> :returning :foreign-address
> :arg-checking nil)
>
> (in-package :xm-silica)
>
> (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 = (+ (* 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))))))
>
>
> (defmethod initialize-xlib-port ((port xt-port) display)
> (let* ((screen (x11:xdefaultscreen display))
> ;;-- This is a property of the graft
> (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))))))
> (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))))))
> )))
> (setup-stipples port display))
>
> (defmethod text-style-mapping :around
> ((port xt-port) text-style
> &optional (character-set *standard-character-set*) window)
> (declare (ignore window))
> (if character-set
> (let ((mapping (call-next-method)))
> (if (stringp mapping)
> (setf (text-style-mapping port text-style character-set)
> (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)))
> (when mapping
> (push (cons c mapping) mappings))))
> (reverse mappings))))
>
> (defmethod restart-port ((port xt-port))
> (let ((process (port-process port)))
> (when process
> (clim-sys:destroy-process process))
> (setq process
> (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*)
> , at excl:*cl-default-special-bindings*))
> #'port-event-loop port))
> (setf (getf (mp:process-property-list process) :no-interrupts) t)
> (setf (port-process port) process)))
>
> (in-package :clim-utils)
>
> (eval-when (compile)
> (ff:def-foreign-call (_malloc "malloc")
> ((data :int))
> :call-direct t
> :arg-checking nil
> :returning :foreign-address)
> (ff:def-foreign-call (_free "free")
> ((data (* :char) simple-string))
> :call-direct t
> :strings-convert nil
> :arg-checking nil
> :returning :void))
>
> (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))
> (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)
More information about the developers
mailing list