Commit 4ed46869 authored by Karl Heuer's avatar Karl Heuer

Initial revision

parent adb572fb
;; gnus-mule.el -- Provide multilingual environment to GNUS
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
;; Keywords: gnus, mule
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;; This package enables GNUS to code convert automatically
;; accoding to a coding system specified for each news group.
;; Please put the following line in your .emacs:
;; (add-hook 'gnus-startup-hook 'gnus-mule-initialize)
;; If you want to specify some coding system for a specific news
;; group, add the fllowing line in your .emacs:
;; (gnus-mule-add-group "xxx.yyy.zzz" 'some-coding-system)
;;
;; Decoding of summary buffer is not yet implemented.
(require 'gnus)
(defvar gnus-newsgroup-coding-systems nil
"Assoc list of news groups vs corresponding coding systems.
Each element is a list of news group name and cons of coding systems
for reading and posting.")
;;;###autoload
(defun gnus-mule-add-group (name coding-system)
"Specify that articles of news group NAME are encoded in CODING-SYSTEM.
All news groups deeper than NAME are also the target.
If CODING-SYSTEM is a cons, the car and cdr part are regarded as
coding-system for reading and writing respectively."
(if (not (consp coding-system))
(setq coding-system (cons coding-system coding-system)))
(setq name (concat "^" (regexp-quote name)))
(let ((group (assoc name gnus-newsgroup-coding-systems)))
(if group
(setcdr group coding-system)
(setq gnus-newsgroup-coding-systems
(cons (cons name coding-system) gnus-newsgroup-coding-systems)))))
(defun gnus-mule-get-coding-system (group)
"Return the coding system for news group GROUP."
(let ((groups gnus-newsgroup-coding-systems)
(len -1)
coding-system)
;; Find an entry which matches GROUP the best (i.e. longest).
(while groups
(if (and (string-match (car (car groups)) group)
(> (match-end 0) len))
(setq len (match-end 0)
coding-system (cdr (car groups))))
(setq groups (cdr groups)))
coding-system))
;; Flag to indicate if article buffer is already decoded or not.")
(defvar gnus-mule-article-decoded nil)
;; Codingsystem for reading articles of the current news group.
(defvar gnus-mule-coding-system nil)
(defvar gnus-mule-subject nil)
(defvar gnus-mule-decoded-subject nil)
(defvar gnus-mule-original-subject nil)
;; Encode (if ENCODING is t) or decode (if ENCODING is nil) the
;; region from START to END by CODING-SYSTEM.
(defun gnus-mule-code-convert1 (start end coding-system encoding)
(if (< start end)
(save-excursion
(if encoding
(encode-coding-region start end coding-system)
(decode-coding-region start end coding-system)))))
;; Encode (if ENCODING is t) or decode (if ENCODING is nil) the
;; current buffer by CODING-SYSTEM. Try not to move positions of
;; (window-start) and (point).
(defun gnus-mule-code-convert (coding-system encoding)
(if coding-system
(let ((win (get-buffer-window (current-buffer))))
(if win
;; We should keep (point) and (window-start).
(save-window-excursion
(select-window win)
(if encoding
;; Simple way to assure point is on valid character boundary.
(beginning-of-line))
(gnus-mule-code-convert1 (point-min) (window-start)
coding-system encoding)
(gnus-mule-code-convert1 (window-start) (point)
coding-system encoding)
(gnus-mule-code-convert1 (point) (point-max)
coding-system encoding)
(if (not (pos-visible-in-window-p))
;; point went out of window, move to the bottom of window.
(move-to-window-line -1)))
;; No window for the buffer, no need to worry about (point)
;; and (windos-start).
(gnus-mule-code-convert1 (point-min) (point-max)
coding-system encoding))
)))
;; Set `gnus-mule-coding-system' to the coding system articles of the
;; current news group is encoded. This function is set in
;; `gnus-select-group-hook'.
(defun gnus-mule-select-coding-system ()
(let ((coding-system (gnus-mule-get-coding-system gnus-newsgroup-name)))
(setq gnus-mule-coding-system
(if (and coding-system (coding-system-p (car coding-system)))
(car coding-system)))))
;; Decode the current article. This function is set in
;; `gnus-article-prepare-hook'.
(defun gnus-mule-decode-article ()
(gnus-mule-code-convert gnus-mule-coding-system nil)
(setq gnus-mule-article-decoded t))
;; Decode the current summary buffer. This function is set in
;; `gnus-summary-prepare-hook'.
(defun gnus-mule-decode-summary ()
;; I have not yet implemented this function because I'm not yet
;; familiar with the new Gnus codes, especialy how to extract only
;; subjects from a summary buffer.
nil)
(defun gnus-mule-toggle-article-format ()
"Toggle decoding/encoding of the current article buffer."
(interactive)
(let ((buf (get-buffer gnus-article-buffer)))
(if (and gnus-mule-coding-system buf)
(save-excursion
(set-buffer buf)
(let ((modif (buffer-modified-p))
buffer-read-only)
(gnus-mule-code-convert gnus-mule-coding-system
gnus-mule-article-decoded)
(setq gnus-mule-article-decoded (not gnus-mule-article-decoded))
(set-buffer-modified-p modif))))))
;;;###autoload
(defun gnus-mule-initialize ()
"Do several settings for GNUS to enable automatic code conversion."
;; Convenient key definitions
(define-key gnus-article-mode-map "z" 'gnus-mule-toggle-article-format)
(define-key gnus-summary-mode-map "z" 'gnus-mule-toggle-article-format)
;; Hook definition
(add-hook 'gnus-select-group-hook 'gnus-mule-select-coding-system)
(add-hook 'gnus-summary-prepare-hook 'gnus-mule-decode-summary)
(add-hook 'gnus-article-prepare-hook 'gnus-mule-decode-article))
(gnus-mule-add-group "" 'coding-system-iso-2022-7) ;; default coding system
(gnus-mule-add-group "alt" 'no-conversion)
(gnus-mule-add-group "comp" 'no-conversion)
(gnus-mule-add-group "gnu" 'no-conversion)
(gnus-mule-add-group "rec" 'no-conversion)
(gnus-mule-add-group "sci" 'no-conversion)
(gnus-mule-add-group "soc" 'no-conversion)
(gnus-mule-add-group "alt.chinese.text" 'coding-system-hz)
(gnus-mule-add-group "alt.hk" 'coding-system-hz)
(gnus-mule-add-group "alt.chinese.text.big5" 'coding-system-big5)
(gnus-mule-add-group "soc.culture.vietnamese" '(nil . coding-system-viqr))
(add-hook 'gnus-startup-hook 'gnus-mule-initialize)
;; gnus-mule.el ends here
;; ccl.el -- CCL (Code Conversion Language) compiler
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
;; Keywords: CCL, mule, multilingual, character set, coding-system
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;; CCL (Code Conversion Language) is a simple programming language to
;; be used for various kind of code conversion. CCL program is
;; compiled to CCL code (vector of integers) and executed by CCL
;; interpreter of Emacs.
;;
;; CCL is used for code conversion at process I/O and file I/O for
;; non-standard coding-system. In addition, it is used for
;; calculating a code point of X's font from a character code.
;; However, since CCL is designed as a powerful programming language,
;; it can be used for more generic calculation. For instance,
;; combination of three or more arithmetic operations can be
;; calculated faster than Emacs Lisp.
;;
;; Here's the syntax of CCL program in BNF notation.
;;
;; CCL_PROGRAM :=
;; (BUFFER_MAGNIFICATION
;; CCL_MAIN_BLOCK
;; [ CCL_EOF_BLOCK ])
;;
;; BUFFER_MAGNIFICATION := integer
;; CCL_MAIN_BLOCK := CCL_BLOCK
;; CCL_EOF_BLOCK := CCL_BLOCK
;;
;; CCL_BLOCK :=
;; STATEMENT | (STATEMENT [STATEMENT ...])
;; STATEMENT :=
;; SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL
;;
;; SET :=
;; (REG = EXPRESSION)
;; | (REG ASSIGNMENT_OPERATOR EXPRESSION)
;; | integer
;;
;; EXPRESSION := ARG | (EXPRESSION OPERATOR ARG)
;;
;; IF := (if EXPRESSION CCL_BLOCK CCL_BLOCK)
;; BRANCH := (branch EXPRESSION CCL_BLOCK [CCL_BLOCK ...])
;; LOOP := (loop STATEMENT [STATEMENT ...])
;; BREAK := (break)
;; REPEAT :=
;; (repeat)
;; | (write-repeat [REG | integer | string])
;; | (write-read-repeat REG [integer | ARRAY])
;; READ :=
;; (read REG ...)
;; | (read-if (REG OPERATOR ARG) CCL_BLOCK CCL_BLOCK)
;; | (read-branch REG CCL_BLOCK [CCL_BLOCK ...])
;; WRITE :=
;; (write REG ...)
;; | (write EXPRESSION)
;; | (write integer) | (write string) | (write REG ARRAY)
;; | string
;; CALL := (call ccl-program-name)
;; END := (end)
;;
;; REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7
;; ARG := REG | integer
;; OPERATOR :=
;; + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | //
;; | < | > | == | <= | >= | != | de-sjis | en-sjis
;; ASSIGNMENT_OPERATOR :=
;; += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>=
;; ARRAY := '[' interger ... ']'
;;; Code:
(defconst ccl-command-table
[if branch loop break repeat write-repeat write-read-repeat
read read-if read-branch write call end]
"*Vector of CCL commands (symbols).")
;; Put a property to each symbol of CCL commands for the compiler.
(let (op (i 0) (len (length ccl-command-table)))
(while (< i len)
(setq op (aref ccl-command-table i))
(put op 'ccl-compile-function (intern (format "ccl-compile-%s" op)))
(setq i (1+ i))))
(defconst ccl-code-table
[set-register
set-short-const
set-const
set-array
jump
jump-cond
write-register-jump
write-register-read-jump
write-const-jump
write-const-read-jump
write-string-jump
write-array-read-jump
read-jump
branch
read-register
write-expr-const
read-branch
write-register
write-expr-register
call
write-const-string
write-array
end
set-assign-expr-const
set-assign-expr-register
set-expr-const
set-expr-register
jump-cond-expr-const
jump-cond-expr-register
read-jump-cond-expr-const
read-jump-cond-expr-register
]
"*Vector of CCL compiled codes (symbols).")
;; Put a property to each symbol of CCL codes for the disassembler.
(let (code (i 0) (len (length ccl-code-table)))
(while (< i len)
(setq code (aref ccl-code-table i))
(put code 'ccl-code i)
(put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))
(setq i (1+ i))))
(defconst ccl-jump-code-list
'(jump jump-cond write-register-jump write-register-read-jump
write-const-jump write-const-read-jump write-string-jump
write-array-read-jump read-jump))
;; Put a property `jump-flag' to each CCL code which execute jump in
;; some way.
(let ((l ccl-jump-code-list))
(while l
(put (car l) 'jump-flag t)
(setq l (cdr l))))
(defconst ccl-register-table
[r0 r1 r2 r3 r4 r5 r6 r7]
"*Vector of CCL registers (symbols).")
;; Put a property to indicate register number to each symbol of CCL.
;; registers.
(let (reg (i 0) (len (length ccl-register-table)))
(while (< i len)
(setq reg (aref ccl-register-table i))
(put reg 'ccl-register-number i)
(setq i (1+ i))))
(defconst ccl-arith-table
[+ - * / % & | ^ << >> <8 >8 // nil nil nil
< > == <= >= != de-sjis en-sjis]
"*Vector of CCL arithmetic/logical operators (symbols).")
;; Put a property to each symbol of CCL operators for the compiler.
(let (arith (i 0) (len (length ccl-arith-table)))
(while (< i len)
(setq arith (aref ccl-arith-table i))
(if arith (put arith 'ccl-arith-code i))
(setq i (1+ i))))
(defconst ccl-assign-arith-table
[+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=]
"*Vector of CCL assignment operators (symbols).")
;; Put a property to each symbol of CCL assignment operators for the compiler.
(let (arith (i 0) (len (length ccl-assign-arith-table)))
(while (< i len)
(setq arith (aref ccl-assign-arith-table i))
(put arith 'ccl-self-arith-code i)
(setq i (1+ i))))
(defvar ccl-program-vector nil
"Working vector of CCL codes produced by CCL compiler.")
(defvar ccl-current-ic 0
"The current index for `ccl-program-vector'.")
;; Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and
;; increment it. If IC is specified, embed DATA at IC.
(defun ccl-embed-data (data &optional ic)
(if ic
(aset ccl-program-vector ic data)
(aset ccl-program-vector ccl-current-ic data)
(setq ccl-current-ic (1+ ccl-current-ic))))
;; Embed string STR of length LEN in `ccl-program-vector' at
;; `ccl-current-ic'.
(defun ccl-embed-string (len str)
(let ((i 0))
(while (< i len)
(ccl-embed-data (logior (ash (aref str i) 16)
(if (< (1+ i) len)
(ash (aref str (1+ i)) 8)
0)
(if (< (+ i 2) len)
(aref str (+ i 2))
0)))
(setq i (+ i 3)))))
;; Embed a relative jump address to `ccl-current-ic' in
;; `ccl-program-vector' at IC without altering the other bit field.
(defun ccl-embed-current-address (ic)
(let ((relative (- ccl-current-ic (1+ ic))))
(aset ccl-program-vector ic
(logior (aref ccl-program-vector ic) (ash relative 8)))))
;; Embed CCL code for the operation OP and arguments REG and DATA in
;; `ccl-program-vector' at `ccl-current-ic' in the following format.
;; |----------------- integer (28-bit) ------------------|
;; |------------ 20-bit ------------|- 3-bit --|- 5-bit -|
;; |------------- DATA -------------|-- REG ---|-- OP ---|
;; If REG2 is specified, embed a code in the following format.
;; |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
;; |-------- DATA -------|-- REG2 --|-- REG ---|-- OP ---|
;; If REG is a CCL register symbol (e.g. r0, r1...), the register
;; number is embedded. If OP is one of unconditional jumps, DATA is
;; changed to an absolute jump address.
(defun ccl-embed-code (op reg data &optional reg2)
(if (and (> data 0) (get op 'jump-flag))
;; DATA is an absolute jump address. Make it relative to the
;; next of jump code.
(setq data (- data (1+ ccl-current-ic))))
(let ((code (logior (get op 'ccl-code)
(ash
(if (symbolp reg) (get reg 'ccl-register-number) reg) 5)
(if reg2
(logior (ash (get reg2 'ccl-register-number) 8)
(ash data 11))
(ash data 8)))))
(aset ccl-program-vector ccl-current-ic code)
(setq ccl-current-ic (1+ ccl-current-ic))))
;; Just advance `ccl-current-ic' by INC.
(defun ccl-increment-ic (inc)
(setq ccl-current-ic (+ ccl-current-ic inc)))
;;;###autoload
(defun ccl-program-p (obj)
"T if OBJECT is a valid CCL compiled code."
(and (vectorp obj)
(let ((i 0) (len (length obj)) (flag t))
(if (> len 1)
(progn
(while (and flag (< i len))
(setq flag (integerp (aref obj i)))
(setq i (1+ i)))
flag)))))
;; If non-nil, index of the start of the current loop.
(defvar ccl-loop-head nil)
;; If non-nil, list of absolute addresses of the breaking points of
;; the current loop.
(defvar ccl-breaks nil)
;;;###autoload
(defun ccl-compile (ccl-program)
"Return a comiled code of CCL-PROGRAM as a vector of integer."
(if (or (null (consp ccl-program))
(null (integerp (car ccl-program)))
(null (listp (car (cdr ccl-program)))))
(error "CCL: Invalid CCL program: %s" ccl-program))
(if (null (vectorp ccl-program-vector))
(setq ccl-program-vector (make-vector 8192 0)))
(setq ccl-loop-head nil ccl-breaks nil)
(setq ccl-current-ic 0)
;; The first element is the buffer magnification.
(ccl-embed-data (car ccl-program))
;; The second element is the address of the start CCL code for
;; processing end of input buffer (we call it eof-processor). We
;; set it later.
(ccl-increment-ic 1)
;; Compile the main body of the CCL program.
(ccl-compile-1 (car (cdr ccl-program)))
;; Embed the address of eof-processor.
(ccl-embed-data ccl-current-ic 1)
;; Then compile eof-processor.
(if (nth 2 ccl-program)
(ccl-compile-1 (nth 2 ccl-program)))
;; At last, embed termination code.
(ccl-embed-code 'end 0 0)
(let ((vec (make-vector ccl-current-ic 0))
(i 0))
(while (< i ccl-current-ic)
(aset vec i (aref ccl-program-vector i))
(setq i (1+ i)))
vec))
;; Signal syntax error.
(defun ccl-syntax-error (cmd)
(error "CCL: Syntax error: %s" cmd))
;; Check if ARG is a valid CCL register.
(defun ccl-check-register (arg cmd)
(if (get arg 'ccl-register-number)
arg
(error "CCL: Invalid register %s in %s." arg cmd)))
;; Check if ARG is a valid CCL command.
(defun ccl-check-compile-function (arg cmd)
(or (get arg 'ccl-compile-function)
(error "CCL: Invalid command: %s" cmd)))
;; In the following code, most ccl-compile-XXXX functions return t if
;; they end with unconditional jump, else return nil.
;; Compile CCL-BLOCK (see the syntax above).
(defun ccl-compile-1 (ccl-block)
(let (unconditional-jump
cmd)
(if (or (integerp ccl-block)
(stringp ccl-block)
(and ccl-block (symbolp (car ccl-block))))
;; This block consists of single statement.
(setq ccl-block (list ccl-block)))
;; Now CCL-BLOCK is a list of statements. Compile them one by
;; one.
(while ccl-block
(setq cmd (car ccl-block))
(setq unconditional-jump
(cond ((integerp cmd)
;; SET statement for the register 0.
(ccl-compile-set (list 'r0 '= cmd)))
((stringp cmd)
;; WRITE statement of string argument.
(ccl-compile-write-string cmd))
((listp cmd)
;; The other statements.
(cond ((eq (nth 1 cmd) '=)
;; SET statement of the form `(REG = EXPRESSION)'.
(ccl-compile-set cmd))
((and (symbolp (nth 1 cmd))
(get (nth 1 cmd) 'ccl-self-arith-code))
;; SET statement with an assignment operation.
(ccl-compile-self-set cmd))
(t
(funcall (ccl-check-compile-function (car cmd) cmd)
cmd))))
(t
(ccl-syntax-error cmd))))
(setq ccl-block (cdr ccl-block)))
unconditional-jump))
(defconst ccl-max-short-const (ash 1 19))
(defconst ccl-min-short-const (ash -1 19))
;; Compile SET statement.
(defun ccl-compile-set (cmd)
(let ((rrr (ccl-check-register (car cmd) cmd))
(right (nth 2 cmd)))
(cond ((listp right)
;; CMD has the form `(RRR = (XXX OP YYY))'.
(ccl-compile-expression rrr right))
((integerp right)
;; CMD has the form `(RRR = integer)'.
(if (and (<= right ccl-max-short-const)
(>= right ccl-min-short-const))
(ccl-embed-code 'set-short-const rrr right)
(ccl-embed-code 'set-const rrr 0)
(ccl-embed-data right)))
(t
;; CMD has the form `(RRR = rrr [ array ])'.
(ccl-check-register right cmd)
(let ((ary (nth 3 cmd)))
(if (vectorp ary)
(let ((i 0) (len (length ary)))
(ccl-embed-code 'set-array rrr len right)
(while (< i len)
(ccl-embed-data (aref ary i))
(setq i (1+ i))))
(ccl-embed-code 'set-register rrr 0 right))))))
nil)
;; Compile SET statement with ASSIGNMENT_OPERATOR.
(defun ccl-compile-self-set (cmd)
(let ((rrr (ccl-check-register (car cmd) cmd))
(right (nth 2 cmd)))
(if (listp right)
;; CMD has the form `(RRR ASSIGN_OP (XXX OP YYY))', compile
;; the right hand part as `(r7 = (XXX OP YYY))' (note: the
;; register 7 can be used for storing temporary value).
(progn
(ccl-compile-expression 'r7 right)
(setq right 'r7)))
;; Now CMD has the form `(RRR ASSIGN_OP ARG)'. Compile it as
;; `(RRR = (RRR OP ARG))'.
(ccl-compile-expression
rrr
(list rrr (intern (substring (symbol-name (nth 1 cmd)) 0 -1)) right)))
nil)