"Fossies" - the Fresh Open Source Software Archive

Member "mule-packages/lisp/mule-ucs/mucs.el" (1 Oct 2009, 17270 Bytes) of archive /linux/misc/xemacs-mule-sumo-2010-07-27.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 ;;; -*- coding: iso-2022-7bit; byte-compile-dynamic: t -*-
    2 ;;; mucs.el --- Mule-UCS setup file.
    3 
    4 ;; Copyright (C) 1997-2001 Miyashita Hisashi
    5 
    6 ;; Keywords: mule, multilingual, 
    7 ;;           character set, coding-system, ISO10646, Unicode
    8 
    9 ;; This file is part of Mule-UCS
   10 
   11 ;; Mule-UCS is free software; you can redistribute it and/or modify
   12 ;; it under the terms of the GNU General Public License as published by
   13 ;; the Free Software Foundation; either version 2, or (at your option)
   14 ;; any later version.
   15 
   16 ;; Mule-UCS is distributed in the hope that it will be useful,
   17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
   18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   19 ;; GNU General Public License for more details.
   20 
   21 ;; You should have received a copy of the GNU General Public License
   22 ;; along with this program; see the file COPYING.  If not, write to the
   23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
   24 ;; Boston, MA 02111-1307, USA.
   25 
   26 ;; Comment:
   27 
   28 ;;;; 
   29 ;; 0.80->JISHOJI Temple
   30 ;; 0.90->Mt.DAIMONJI
   31 ;; 1.00->SHINNYODO Temple
   32 ;; 1.10->SHIGAKOEMICHI Ave.
   33 ;; 1.20->Mt.HIEI
   34 ;; 1.30->KITAYAMA
   35 ;; 1.40->ROKUONJI Temple
   36 ;; 1.50->NINNAJI Temple
   37 ;; 1.60->HORIKAWA Liver
   38 ;; 1.70->NISHIJIN
   39 ;; 1.80->IMADEGAWA
   40 ;; 1.90->DAIRI
   41 ;; 2.00->Kyoto Univ.
   42 (defconst mucs-version "0.84 (KOUGETSUDAI:向月台)")
   43 
   44 ;; For error handling.
   45 
   46 (require 'mucs-error)
   47 
   48 ;; Type manager.
   49 (require 'mucs-type)
   50 
   51 ;;
   52 ;; package require.
   53 ;;
   54 
   55 (defvar mucs-data-path "reldata/")
   56 
   57 (defun mucs-require-data (package)
   58   (or (featurep package)
   59       ;; I cannot find out more appropriate way to
   60       ;; construct realtive file name.
   61       (load (file-relative-name
   62          (expand-file-name (symbol-name package)
   63                    mucs-data-path)
   64          default-directory)
   65         t)
   66       (require package)))
   67 
   68 (defun mucs-require-supplement (package &optional base)
   69   "require supplement module."
   70   (or (featurep package)
   71       (if (or load-in-progress
   72           base)
   73       (load (expand-file-name 
   74          (symbol-name package)
   75          (file-name-directory
   76           (if (and (boundp 'load-file-name)
   77                (stringp load-file-name))
   78               load-file-name
   79             (if base
   80             (locate-library
   81              (symbol-name base))
   82               (error "Cannot resolve the location of %s!"
   83                  package))))))
   84     (require package))))
   85 
   86 ;;; fundamental data.
   87 
   88 (defvar emacs-value-bits 28)
   89 (defvar mucs-code-range-bits 27)
   90 (defvar mucs-code-range-specials 100)
   91 (defvar mucs-invalid-code -1
   92   "invalid code.  If this value is set, skip operation.")
   93 
   94 (defun mucs-max-code ()
   95   (1- (lsh 1 mucs-code-range-bits)))
   96 
   97 (defun mucs-special-code (code)
   98   (if (or (< code 0)
   99       (>= code mucs-code-range-specials))
  100       (error "Invalid code:%d" code))
  101   (- (lsh 1 mucs-code-range-bits) 1 code))
  102 
  103 (defun mucs-arithmetic-adjust ()
  104   (* 3 (lsh 1 (- mucs-code-range-bits 2))))
  105 
  106 (defun mucs-arithmetic-range-lower ()
  107   (lsh 1 (1- mucs-code-range-bits)))
  108 
  109 (defun mucs-arithmetic-range-upper ()
  110   (- (lsh 1 mucs-code-range-bits)
  111      mucs-code-range-specials 1))
  112 
  113 (defun mucs-max-number ()
  114   (1- (lsh 1 (1- mucs-code-range-bits))))
  115 
  116 (defun mucs-number-mask ()
  117   (lognot 0))
  118 
  119 ;;;
  120 ;;; version detection
  121 ;;;
  122 
  123 (defvar mule-parsed-version
  124   (and (boundp 'mule-version)
  125        (string-match "^\\([0-9]+\\)\\.\\([0-9]+\\)" mule-version)
  126        (cons (string-to-number (match-string 1 mule-version))
  127          (string-to-number (match-string 2 mule-version)))))
  128 
  129 (defun mule-version-satisfied-p (major minor)
  130   (and mule-parsed-version
  131        (or (> (car mule-parsed-version) major)
  132        (and (= (car mule-parsed-version) major)
  133         (>= (cdr mule-parsed-version) minor)))))
  134 
  135 (defun xemacs-mule-p ()
  136   (and (featurep 'xemacs)
  137        (featurep 'mule)))
  138 
  139 (defmacro funcall-if-possible (func &rest args)
  140   `(if (functionp ,func)
  141        (funcall ,func ,@args)
  142      nil))
  143 
  144 ;;; Package management.
  145 
  146 (defvar mucs-current-package nil)
  147 
  148 (defvar mucs-current-type nil
  149   "Mule-UCS code generator's internal variable.
  150 This variable specifies the type of data that the current context stores.")
  151 
  152 (defvar mucs-package-definition-end-hook nil
  153   "At the end of package definition, call this hook.
  154 In order to embed data or lisp code, use this hook.")
  155 
  156 (defmacro mucs-embed-package-signature ()
  157   (let ((packages 
  158      (cons mucs-current-package
  159            (get mucs-current-package 'mucs-imported-packages)))
  160     (sig '(progn))
  161     cont result tempfunc)
  162     (setq tempfunc
  163       (lambda (package)
  164         (setq cont (get package
  165                 'mucs-registered-alist))
  166         (setq result
  167           (if cont
  168               `((put (quote ,package)
  169                  'mucs-registered-alist
  170                  (quote ,cont)))
  171             nil))
  172         (setq cont (get package
  173                 'mucs-imported-packages))
  174         (if cont
  175         (setq result
  176               (append
  177                `((put (quote ,package)
  178                   'mucs-imported-packages
  179                   (quote ,cont)))
  180                result)))
  181         result))
  182     (while packages
  183       (setq sig (append sig (funcall tempfunc (car packages)))
  184         packages (cdr packages)))
  185     sig))
  186 
  187 (defmacro mucs-embed-program-with-hooks (hooksym)
  188   (let ((hookval (symbol-value hooksym))
  189     result)
  190     (if (functionp hookval)
  191     (setq hookval (list hookval))
  192       (if (not (listp hookval))
  193       (error "Invalid hook:%S" hooksym)))
  194     (while hookval
  195       (setq result (append
  196             (funcall (car hookval))
  197             result)
  198         hookval (cdr hookval)))
  199     (cons 'progn
  200       result)))
  201 
  202 (defmacro mucs-define-package (package &rest form)
  203   "Enclose a unit of package with this.
  204 By this specification, Mule-UCS may judge
  205 whether generate a new program to prepare.
  206 You should make PACKAGE the same as your package name
  207 that you set at `provide' function."
  208   (if (not (symbolp package))
  209       (signal 'wrong-type-argument
  210           (list 'symbolp package)))
  211   (setq mucs-current-package package)
  212   (put mucs-current-package 'mucs-registered-alist nil)
  213   (append
  214    `(let ((mucs-current-package (quote ,package))))
  215    form
  216    '((mucs-embed-program-with-hooks
  217       mucs-package-definition-end-hook)
  218      (mucs-embed-package-signature))))
  219 
  220 (defmacro mucs-import-package (package)
  221   "Import package."
  222   (let ((mucs-ignore-version-incompatibilities t))
  223     (require package)
  224     (let ((import-list
  225        (get mucs-current-package 'mucs-imported-packages)))
  226       (if (memq package import-list)
  227       nil
  228     (put mucs-current-package 'mucs-imported-packages
  229          (cons package import-list)))
  230       `(let ((mucs-ignore-version-incompatibilities t))
  231     (require (quote ,package))))))
  232 
  233 (defsubst mucs-get-current-registered-alist ()
  234   (get mucs-current-package
  235        'mucs-registered-alist))
  236 
  237 (defsubst mucs-set-current-registered-alist (alist)
  238   (put mucs-current-package
  239        'mucs-registered-alist
  240        alist))
  241 
  242 (defsubst mucs-get-registered-kind-alist (kind)
  243   (let ((packages 
  244      (cons mucs-current-package
  245            (get mucs-current-package 'mucs-imported-packages)))
  246     result)
  247     (while packages
  248       (setq result
  249         (append
  250          (cdr (assq kind
  251             (get (car packages)
  252                  'mucs-registered-alist)))
  253          result)
  254         packages (cdr packages)))
  255     result))
  256 
  257 (defsubst mucs-get-registered-slot (kind object)
  258   "If OBJECT have been already registered, return registered slot."
  259   (assq object
  260     (mucs-get-registered-kind-alist kind)))
  261 
  262 (defalias 'mucs-registered-p 'mucs-get-registered-slot)
  263 
  264 (defsubst mucs-embedded-p (kind object)
  265   (nth 1 (mucs-get-registered-slot kind object)))
  266 
  267 (defun mucs-registered-object-list (kind)
  268   (let ((objlist
  269      (mucs-get-registered-kind-alist kind))
  270     elem result)
  271     (while (setq elem (car objlist))
  272       (setq result (cons (car elem) result)
  273         objlist (cdr objlist)))
  274     result))
  275 
  276 (defun mucs-unembedded-object-list (kind)
  277   (let ((objlist
  278      (mucs-get-registered-kind-alist kind))
  279     elem result)
  280     (while (setq elem (car objlist))
  281       (if (not (nth 1 elem))
  282       (setq result (cons (car elem) result)))
  283       (setq objlist (cdr objlist)))
  284     result))
  285 
  286 (defun mucs-notify-embedment (kind object)
  287   (let ((slot (mucs-get-registered-slot kind object)))
  288     (if (null slot)
  289     (error "%S has not been registered yet.(KIND:%S)"
  290            object kind))
  291     (setcar (cdr slot) t)))
  292 
  293 (defun mucs-register-object (kind object &optional embed)
  294   "Register OBJECT to curent package's record.
  295 If OBJECT have been already registered, return non-nil;
  296 otherwise return nil."
  297   (if mucs-current-package
  298       (or (mucs-registered-p kind object)
  299       (let* ((alist
  300           (mucs-get-current-registered-alist))
  301          (slot
  302           (assq kind alist))
  303          (objslot (list object embed)))
  304         (if slot
  305         (setcdr slot
  306             (cons objslot (cdr slot)))
  307           (mucs-set-current-registered-alist
  308            (cons (list kind objslot)
  309              alist)))
  310         nil))))
  311 
  312 (defun mucs-unregister-object (kind object)
  313   (let* ((alist
  314       (mucs-get-current-registered-alist))
  315      (slot1
  316       (assq kind alist))
  317      slot2)
  318     (and slot1
  319      (setq slot2 (assq object slot1))
  320      (setcdr slot1
  321          (delq slot2 (cdr slot1))))))
  322 
  323 ;;; Fundamental configuration ends here.
  324 
  325 ;;;
  326 ;;; Mule-UCS conversion engine setup!
  327 ;;;  (currently, only CCL)
  328 
  329 (cond ((fboundp 'ccl-execute)
  330        (require 'mucs-ccl))
  331 ;      ((fboundp 'cdl-execute)
  332 ;       (require 'mucs-cdl))
  333       (t
  334        (error "This Emacs does not have Mule-UCS conversion engine!")))
  335 
  336 
  337 ;;
  338 ;; "conversion" manager
  339 ;;
  340 ;; PROPERTY SYMBOL LIST
  341 ;;    mucs-conv-type:
  342 ;;    mucs-conversion-program:
  343 ;;    mucs-conversion-properties:
  344 ;;    mucs-conversion-program-marker:
  345 
  346 (defvar mucs-current-conversion nil)
  347 
  348 (defsubst mucs-conversion-p (symbol)
  349   (or (get symbol 'mucs-conv-type)
  350       nil))
  351 
  352 (defsubst mucs-conversion-get (symbol key)
  353   (if (not (mucs-conversion-p symbol))
  354       (error "%S is not mucs-conversion." symbol))
  355   (plist-get (get symbol 'mucs-conversion-properties)
  356          key))
  357 
  358 (defsubst mucs-conversion-put (symbol key val)
  359   (if (not (mucs-conversion-p symbol))
  360       (error "%S is not mucs-conversion." symbol))
  361   (put symbol
  362        'mucs-conversion-properties
  363        (plist-put (get symbol 'mucs-conversion-properties)
  364           key val)))
  365 
  366 (defmacro mucs-define-conversion (symbol convtype definition)
  367   "Define conversion.
  368 SYMBOL is a symbol to identify the defined conversion.
  369 CONVTYPE specifies how this conversion is used; You can specify
  370 stream(symbol), font(symbol), or (FROM-TYPE . TO-TYPE),
  371 where FROM-TYPE and TO-TYPE are defined MULE-UCS-TYPE.
  372   If CONVTYPE is stream, this conversion is used for stream, i.e.
  373 this can be used by coding-system.
  374   If CONVTYPE is font, this conversion is used for font encoding.
  375   If CONVTYPE is (FROM-TYPE . TO-TYPE), this conversion is used for
  376 converting data of FROM-TYPE into data of TO-TYPE.
  377   DEFINITION specifies the definition of the conversion.
  378 
  379   conversions defined by this function are embedded to .elc file.
  380 Therefore, you can use these without any Mule-UCS modules.
  381 
  382   All arguments are NOT evaluated!"
  383   (if (not (or (eq convtype 'stream)
  384            (eq convtype 'font)
  385            (consp convtype)
  386            (mucs-type-p (car convtype))
  387            (mucs-type-p (cdr convtype))))
  388       (error "Invalid CONVTYPE:%S" convtype))
  389   (put symbol 'mucs-conv-type convtype)
  390   `(progn
  391      (put (quote ,symbol) 'mucs-conv-type (quote ,convtype))
  392      ,@(mucs-setup-conversion symbol definition)
  393      (put (quote ,symbol) 'mucs-conversion-program
  394       ,(mucs-conversion-get
  395         symbol 'mucs-conversion-program-prep))
  396      nil))
  397 
  398 (defun mucs-conversion-set-program-marker (marker-sym program)
  399   (list '\, `(cdar (put (quote ,mucs-current-conversion)
  400             'mucs-conversion-program-marker
  401             (cons (cons (quote ,marker-sym)
  402                     ,(list '\` program))
  403                   (get (quote ,mucs-current-conversion)
  404                    'mucs-conversion-program-marker))))))
  405 
  406 (defsubst mucs-retrieve-marked-conversion-program (conv mark)
  407   (cdr (assq mark (get conv 'mucs-conversion-program-marker))))
  408 
  409 (defsubst mucs-substitute-conversion-program (conv mark newprog)
  410   (let ((spot (mucs-retrieve-marked-conversion-program conv mark)))
  411     (setcar spot (car newprog))
  412     (setcdr spot (cdr newprog))))
  413 
  414 (defun mucs-modify-conversion (conv mark newprog)
  415   (mucs-substitute-conversion-program conv mark newprog)
  416   (mucs-refresh-conversion
  417    conv (get conv 'mucs-conversion-program)))
  418   
  419 (defun mucs-conversion-definition-mag (definition)
  420   (eval (car definition)))
  421 
  422 (defun mucs-conversion-definition-main-prog (definition)
  423   (nth 1 definition))
  424 
  425 (defun mucs-conversion-definition-eof-prog (definition)
  426   (nth 2 definition))
  427 
  428 (defsubst mucs-conversion-get-conv-type (symbol)
  429   (get symbol 'mucs-conv-type))
  430 
  431 (defsubst mucs-conversion-set-program-and-compiled-code
  432   (symbol program code)
  433   (mucs-conversion-put symbol 'mucs-conversion-program-prep program)
  434   (if code
  435       (mucs-conversion-put
  436        symbol
  437        'mucs-compiled-code code)))
  438 
  439 ;;;
  440 ;;; Coding system API
  441 ;;;
  442 
  443 (defmacro mucs-define-coding-system
  444   (symbol mnemonic doc-string
  445       decode-conversion encode-conversion
  446       &optional alist eol-type)
  447   (cond ((xemacs-mule-p)
  448      (setq eol-type
  449            (cond ((eq eol-type 'unix)
  450               'lf)
  451              ((eq eol-type 'dos)
  452               'crlf)
  453              ((eq eol-type 'mac)
  454               'cr)
  455              (t
  456               t)))
  457      `(or (find-coding-system ,symbol)
  458           (mucs-make-coding-system
  459            ,symbol 'ccl ,doc-string
  460            (list 'decode ,decode-conversion
  461              'encode ,encode-conversion
  462              'mnemonic (if (stringp ,mnemonic)
  463                    ,mnemonic
  464                  (char-to-string ,mnemonic))
  465              'eol-type ,eol-type))))
  466     ((mule-version-satisfied-p 4 1)
  467      `(mucs-make-coding-system
  468        ,symbol 4 ,mnemonic ,doc-string
  469        (cons ,decode-conversion
  470          ,encode-conversion)
  471        ,alist ,eol-type))
  472     ((featurep 'mule)
  473      `(mucs-make-coding-system
  474        ,symbol 4 ,mnemonic ,doc-string
  475        (cons ,decode-conversion
  476          ,encode-conversion)
  477        ,alist))
  478     (t
  479      (error "This Emacs has no Mule feature."))))
  480 
  481 ;;;
  482 ;;; Encoding/Decoding API.
  483 ;;;
  484 
  485 ;;; Symbol's property
  486 ;; mucs-encoding-backend
  487 ;; mucs-encoding-default-backend
  488 ;; mucs-decoding-backend
  489 ;; mucs-decoding-default-backend
  490 
  491 ;; Currently, supported restriction classes are:
  492 ;;   charset
  493 ;; only.
  494 
  495 (defsubst mucs-get-representation-encoding-backend
  496   (representation restriction)
  497   (if restriction
  498       (or (and (listp restriction)
  499            (cdr
  500         (assq (car restriction)
  501               (get representation 'mucs-encoding-backend))))
  502       (error "Invalid restriction:%S" restriction))
  503     (get representation 'mucs-encoding-default-backend)))
  504 
  505 (defsubst mucs-get-representation-decoding-backend
  506   (representation restriction)
  507   (if restriction
  508       (or (and (listp restriction)
  509            (cdr
  510         (assq (car restriction)
  511               (get representation 'mucs-decoding-backend))))
  512       (error "Invalid restriction:%S" restriction))
  513     (get representation 'mucs-decoding-default-backend)))
  514 
  515 (defun mucs-register-representation-encoding-backend
  516   (representation restriction-category backend)
  517   (let (alist slot)
  518     (cond ((eq restriction-category 'nil)
  519        (put representation 'mucs-encoding-default-backend
  520         (list backend)))
  521       ((symbolp restriction-category)
  522        (setq alist (get representation 'mucs-encoding-backend)
  523          slot (assq restriction-category representation))
  524        (if slot
  525            (put representation 'mucs-encoding-backend
  526             (cons (cons restriction-category backend)
  527               alist))
  528          (setcdr slot backend)))
  529       (t
  530        (error "Invalid restriction category:%S." restriction-category)))))
  531 
  532 (defun mucs-register-representation-decoding-backend
  533   (representation restriction-category backend)
  534   (let (alist slot)
  535     (cond ((eq restriction-category 'nil)
  536        (put representation 'mucs-decoding-default-backend
  537         (list backend)))
  538       ((symbolp restriction-category)
  539        (setq alist (get representation 'mucs-decoding-backend)
  540          slot (assq restriction-category representation))
  541        (if slot
  542            (put representation 'mucs-decoding-backend
  543             (cons (cons restriction-category backend)
  544               alist))
  545          (setcdr slot backend)))
  546       (t
  547        (error "Invalid restriction category:%S." restriction-category)))))
  548 
  549 (defun encode-char (char representation &optional restriction)
  550   "Return character representation(code-point, explanation, category, attribute
  551 and so on.) in REPRESENTATION that corresponds to CHAR.
  552 Return nil if CHAR cannot be represented.
  553 Available representation list can be obtained by mucs-representation-list.
  554 
  555 Optional argument RESTRICTION specifies a way to map CHAR to
  556 representation.  Its interpretation depends on the given
  557 REPRESENTATION.  If not specified, the default restriction of
  558 REPRESENTATION is used."
  559   (let ((fs (mucs-get-representation-encoding-backend
  560          representation restriction))
  561     ret)
  562     (while
  563     (and fs
  564          (not (setq ret
  565             (funcall
  566              (car fs)
  567              char representation restriction))))
  568       (setq fs (cdr fs)))
  569     ret))
  570 
  571 (defun decode-char (representation object &optional restriction)
  572   "Return a character represented by OBJECT in view of REPRESENTATION.
  573 Return nil if OBJECT cannot be mapped to only one character.
  574 Available representation list can be obtained by mucs-representation-list.
  575 Optional argument RESTRICTION specifies a way to map OBJECT to
  576 a character.  Its interpretation depends on the given
  577 REPRESENTATION.  If not specified, the default restriction of REPRESENTATION
  578 is used."
  579   (let ((fs (mucs-get-representation-decoding-backend
  580          representation restriction))
  581     ret)
  582     (while
  583     (and fs
  584          (not (setq ret
  585             (funcall
  586              (car fs)
  587              representation object restriction))))
  588       (setq fs (cdr fs)))
  589     ret))
  590 
  591 (provide 'mucs)