Mercurial > emacs

comparison lisp/international/fontset.el @ 19049:cad4c032fa26

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(fontset-name-p): New function. (uninstanciated-fontset-alist): New variable. (create-fontset-from-fontset-spec): Delete arg STYLE. Register style-variants of FONTSET in uninstanciated-fontset-alist. (create-fontset-from-x-resource): Call create-fontset-from-fontset-spec correctly.
author Kenichi Handa <handa@m17n.org>
date Thu, 31 Jul 1997 05:53:31 +0000
parents de8249499f33
children f5627d8c422a
comparison
equal deleted inserted replaced
19048:65112b3cc989 19049:cad4c032fa26
278 (if (string-match (cdr (assq 'latin-iso8859-1 x-charset-registries)) 278 (if (string-match (cdr (assq 'latin-iso8859-1 x-charset-registries))
279 (cdr (assq 'ascii fontlist))) 279 (cdr (assq 'ascii fontlist)))
280 (setcdr (assq 'latin-iso8859-1 fontlist) (cdr (assq 'ascii fontlist)))) 280 (setcdr (assq 'latin-iso8859-1 fontlist) (cdr (assq 'ascii fontlist))))
281 fontlist) 281 fontlist)
282 282
283 (defun fontset-name-p (fontset)
284 "Return non-nil if FONTSET is valid as fontset name.
285 A valid fontset name should conform to XLFD (X Logical Font Description)
286 with \"fontset\" in `<CHARSET_REGISTRY> field."
287 (and (string-match xlfd-tight-regexp fontset)
288 (string= (match-string (1+ xlfd-regexp-registry-subnum) fontset)
289 "fontset")))
290
283 ;; Return a list to be appended to `x-fixed-font-alist' when 291 ;; Return a list to be appended to `x-fixed-font-alist' when
284 ;; `mouse-set-font' is called. 292 ;; `mouse-set-font' is called.
285 (defun generate-fontset-menu () 293 (defun generate-fontset-menu ()
286 (let ((fontsets global-fontset-alist) 294 (let ((fontsets global-fontset-alist)
287 fontset-name 295 fontset-name
322 ((string-match "^ro$" slant) 330 ((string-match "^ro$" slant)
323 (setq name (concat name " " "reverse slant")))) 331 (setq name (concat name " " "reverse slant"))))
324 name)) 332 name))
325 fontset))) 333 fontset)))
326 334
335 (defvar uninstanciated-fontset-alist nil
336 "Alist of fontset names vs. information for instanciating them.
337 Each element has the form (FONTSET STYLE BASE-FONTSET), where
338 FONTSET is a name of fontset not yet instanciated.
339 STYLE is a style of FONTSET, one of the followings:
340 bold, demobold, italic, oblique,
341 bold-italic, demibold-italic, bold-oblique, demibold-oblique.
342 BASE-FONTSET is a name of fontset base from which FONSET is instanciated.")
343
327 (defun create-fontset-from-fontset-spec (fontset-spec &optional style noerror) 344 (defun create-fontset-from-fontset-spec (fontset-spec &optional style noerror)
328 "Create a fontset from fontset specification string FONTSET-SPEC. 345 "Create a fontset from fontset specification string FONTSET-SPEC.
329 FONTSET-SPEC is a string of the format: 346 FONTSET-SPEC is a string of the format:
330 FONTSET-NAME,CHARSET-NAME0:FONT-NAME0,CHARSET-NAME1:FONT-NAME1, ... 347 FONTSET-NAME,CHARSET-NAME0:FONT-NAME0,CHARSET-NAME1:FONT-NAME1, ...
331 Any number of SPACE, TAB, and NEWLINE can be put before and after commas. 348 Any number of SPACE, TAB, and NEWLINE can be put before and after commas.
345 (setq charset (intern (match-string 1 fontset-spec))) 362 (setq charset (intern (match-string 1 fontset-spec)))
346 (if (charsetp charset) 363 (if (charsetp charset)
347 (setq fontlist (cons (cons charset (match-string 2 fontset-spec)) 364 (setq fontlist (cons (cons charset (match-string 2 fontset-spec))
348 fontlist)))) 365 fontlist))))
349 366
350 ;; If STYLE is specified, modify fontset name (NAME) and FONTLIST.
351 (let ((func (cdr (assq style '((bold . x-make-font-bold)
352 (italic . x-make-font-italic)
353 (bold-italic . x-make-font-bold-italic)))))
354 (l fontlist)
355 new-name)
356 (if (and func
357 (setq new-name (funcall func name)))
358 (progn
359 (setq name new-name)
360 (while l
361 (if (setq new-name (funcall func (cdr (car l))))
362 (setcdr (car l) new-name))
363 (setq l (cdr l))))))
364
365 ;; If NAME conforms to XLFD, complement FONTLIST for charsets not 367 ;; If NAME conforms to XLFD, complement FONTLIST for charsets not
366 ;; specified in FONTSET-SPEC. 368 ;; specified in FONTSET-SPEC.
367 (let ((xlfd-fields (x-decompose-font-name name))) 369 (let ((xlfd-fields (x-decompose-font-name name)))
368 (if xlfd-fields 370 (if xlfd-fields
369 (setq fontlist 371 (setq fontlist
370 (x-complement-fontset-spec xlfd-fields fontlist)))) 372 (x-complement-fontset-spec xlfd-fields fontlist))))
373
374 ;; If STYLE is specified, modify fontset name (NAME) and FONTLIST.
375 (if nil
376 (let ((func (cdr (assq style '((bold . x-make-font-bold)
377 (italic . x-make-font-italic)
378 (bold-italic . x-make-font-bold-italic)))))
379 (l fontlist)
380 new-name)
381 (if (and func
382 (setq new-name (funcall func name)))
383 (progn
384 (setq name new-name)
385 (while l
386 (if (setq new-name (funcall func (cdr (car l))))
387 (setcdr (car l) new-name))
388 (setq l (cdr l))))))
389 (let ((funcs-alist
390 '((bold x-make-font-bold)
391 (demibold x-make-font-demibold)
392 (italic x-make-font-italic)
393 (oblique x-make-font-oblique)
394 (bold-italic x-make-font-bold x-make-font-italic)
395 (demibold-italic x-make-font-demibold x-make-font-italic)
396 (bold-oblique x-make-font-bold x-make-font-oblique)
397 (demibold-oblique x-make-font-demibold x-make-font-oblique)))
398 new-name style funcs)
399 (while funcs-alist
400 (setq funcs (car funcs-alist))
401 (setq style (car funcs))
402 (setq funcs (cdr funcs))
403 (setq new-name name)
404 (while funcs
405 (setq new-name (funcall (car funcs) new-name))
406 (setq funcs (cdr funcs)))
407 (setq uninstanciated-fontset-alist
408 (cons (list new-name style name) uninstanciated-fontset-alist))
409 (setq funcs-alist (cdr funcs-alist)))))
371 410
372 (if (and noerror (query-fontset name)) 411 (if (and noerror (query-fontset name))
373 ;; Don't try to create an already existing fontset. 412 ;; Don't try to create an already existing fontset.
374 nil 413 nil
375 ;; Create the fontset, and define the alias if appropriate. 414 ;; Create the fontset, and define the alias if appropriate.
380 (let ((alias (match-string 0 name))) 419 (let ((alias (match-string 0 name)))
381 (or (rassoc alias fontset-alias-alist) 420 (or (rassoc alias fontset-alias-alist)
382 (setq fontset-alias-alist 421 (setq fontset-alias-alist
383 (cons (cons name alias) fontset-alias-alist)))))))) 422 (cons (cons name alias) fontset-alias-alist))))))))
384 423
424 (defun instanciate-fontset (fontset)
425 "Create a new fontset FONTSET if it is not yet instanciated.
426 Return FONTSET if it is created successfully, else return nil."
427 (let ((fontset-data (assoc fontset uninstanciated-fontset-alist)))
428 (if (null fontset-data)
429 nil
430 (let ((style (nth 1 fontset-data))
431 (base-fontset (nth 2 fontset-data))
432 (funcs-alist
433 '((bold x-make-font-bold)
434 (demibold x-make-font-demibold)
435 (italic x-make-font-italic)
436 (oblique x-make-font-oblique)
437 (bold-italic x-make-font-bold x-make-font-italic)
438 (demibold-italic x-make-font-demibold x-make-font-italic)
439 (bold-oblique x-make-font-bold x-make-font-oblique)
440 (demibold-oblique x-make-font-demibold x-make-font-oblique)))
441 ascii-font font font2 funcs)
442 (setq uninstanciated-fontset-alist
443 (delete fontset-data uninstanciated-fontset-alist))
444 (setq fontset-data (assoc base-fontset global-fontset-alist))
445 (setq ascii-font (cdr (assq 'ascii (cdr fontset-data))))
446 (setq funcs (cdr (assq style funcs-alist)))
447 (if (= (length funcs) 1)
448 (and (setq font (funcall (car funcs) ascii-font))
449 (setq font (x-resolve-font-name font 'default)))
450 (and (setq font (funcall (car funcs) ascii-font))
451 (not (equal font ascii-font))
452 (setq font2 (funcall (nth 1 funcs) font))
453 (not (equal font2 font))
454 (setq font (x-resolve-font-name font2 'default))))
455 (when font
456 (let ((new-fontset-data (copy-alist fontset-data)))
457 (setq funcs (cdr (assq style funcs-alist)))
458 (while funcs
459 (setcar new-fontset-data
460 (funcall (car funcs) (car new-fontset-data)))
461 (let ((l (cdr new-fontset-data)))
462 (while l
463 (if (setq font (funcall (car funcs) (cdr (car l))))
464 (setcdr (car l) font))
465 (setq l (cdr l))))
466 (setq funcs (cdr funcs)))
467 (new-fontset (car new-fontset-data) (cdr new-fontset-data))
468 (car new-fontset-data)))))))
385 469
386 ;; Create standard fontset from 16 dots fonts which are the most widely 470 ;; Create standard fontset from 16 dots fonts which are the most widely
387 ;; installed fonts. Fonts for Chinese-GB, Korean, and Chinese-CNS are 471 ;; installed fonts. Fonts for Chinese-GB, Korean, and Chinese-CNS are
388 ;; specified here because FAMILY of those fonts are not "fixed" in 472 ;; specified here because FAMILY of those fonts are not "fixed" in
389 ;; many cases. 473 ;; many cases.