cgit.sxemacs.org Git - packages/blob - mule-packages/mule-ucs/lisp/mucs.el

   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:\e$B8~7nBf\e(B)")
  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)