[COMMIT] Make ccl-encode-to-ucs-2 more robust.
17 years, 5 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
lisp/ChangeLog addition:
2007-07-28 Aidan Kehoe <kehoea(a)parhasard.net>
* unicode.el:
Assert that the ccl-encode-to-ucs-2 vector corresponds to the
compiled program at byte-compile time. Display non-BMP characters
as U+FFFD.
XEmacs Trunk source patch:
Diff command: cvs -q diff -Nu
Files affected: lisp/unicode.el
===================================================================
RCS
Index: lisp/unicode.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/unicode.el,v
retrieving revision 1.20
diff -u -u -r1.20 unicode.el
--- lisp/unicode.el 2007/07/22 22:03:31 1.20
+++ lisp/unicode.el 2007/07/28 07:50:52
＠＠ -42,6 +42,8 ＠＠
;; and saved in ISO 2022 coding systems using the UTF-8 escape described in
;; ISO-IR 196.
+(eval-when-compile (when (featurep 'mule) (require 'ccl)))
+
;; accessed in loadup.el, mule-cmds.el; see discussion in unicode.c
(defvar load-unicode-tables-at-dump-time (eq system-type 'windows-nt)
"[INTERNAL] Whether to load the Unicode tables at dump time.
＠＠ -284,33 +286,47 ＠＠
(char-to-unicode char))
(when (featurep 'mule)
- ;; This CCL program is used for displaying the fallback UCS character set,
- ;; and can be repurposed to lao and the IPA, all going well.
- ;;
- ;; define-ccl-program is available after mule-ccl is loaded, much later
- ;; than this file in the build process. The below is the result of
- ;;
- ;; (macroexpand
- ;; '(define-ccl-program ccl-encode-to-ucs-2
- ;; `(1
- ;; ((r1 = (r1 << 7))
- ;; (r1 = (r1 | r2))
- ;; (mule-to-unicode r0 r1)
- ;; (r1 = (r0 >> 8))
- ;; (r2 = (r0 & #xff))))
- ;; "CCL program to transform Mule characters to UCS-2."))
- ;;
- ;; and it should occasionally be confirmed that the correspondence still
- ;; holds.
-
- (let ((prog [1 10 131127 7 98872 65823 147513 8 82009 255 22]))
- (defconst ccl-encode-to-ucs-2
- prog
+ (let ((prog
+ (eval-when-compile
+ (let ((pre-existing
+ ;; This is the compiled CCL program from the assert
+ ;; below. Since this file is dumped and ccl.el isn't (and
+ ;; even when it was, it was dumped much later than this
+ ;; one), we can't compile the program at dump time. We can
+ ;; check at byte compile time that the program is as
+ ;; expected, though.
+ [1 16 131127 7 98872 65823 1307 5 -65536 65313 64833 1028 147513
+ 8 82009 255 22]))
+ (when (featurep 'mule)
+ ;; Check that the pre-existing constant reflects the intended
+ ;; CCL program.
+ (assert
+ (equal pre-existing
+ (ccl-compile
+ `(1
+ (;; mule-to-unicode's first argument is the
+ ;; charset ID, the second its first byte
+ ;; left shifted by 7 bits masked with its
+ ;; second byte.
+ (r1 = (r1 << 7))
+ (r1 = (r1 | r2))
+ (mule-to-unicode r0 r1)
+ (if (r0 & ,(lognot #xFFFF))
+ ;; Redisplay looks in r1 and r2 for the first
+ ;; and second bytes of the X11 font,
+ ;; respectively. For non-BMP characters we
+ ;; display U+FFFD.
+ ((r1 = #xFF)
+ (r2 = #xFD))
+ ((r1 = (r0 >> 8))
+ (r2 = (r0 & #xFF))))))))
+ nil
+ "The pre-compiled CCL program appears broken. "))
+ pre-existing))))
+ (defconst ccl-encode-to-ucs-2 prog
"CCL program to transform Mule characters to UCS-2.")
- (put 'ccl-encode-to-ucs-2
- 'ccl-program-idx
- (register-ccl-program 'ccl-encode-to-ucs-2 prog))
- nil))
+ (put 'ccl-encode-to-ucs-2 'ccl-program-idx
+ (register-ccl-program 'ccl-encode-to-ucs-2 prog))))
;; #### UTF-7 is not yet implemented, and it's tricky to do. There's
;; an implementation in appendix A.1 of the Unicode Standard, Version
--
On the quay of the little Black Sea port, where the rescued pair came once
more into contact with civilization, Dobrinton was bitten by a dog which was
assumed to be mad, though it may only have been indiscriminating. (Saki)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[R21.4] [C] xemacs-21.5-clean: Document Chile and update Denmark download site
17 years, 5 months
Adrian Aichner
Adrian Aichner
RECOMMEND 21.4
COMMIT
In addition to this, CNAME ftp.dk has changed to mirrors.dotsrc.org.
Adrian
xemacs-21.5-clean ChangeLog patch:
Diff command: cvs -q diff -U 0
Files affected: lisp/ChangeLog
Index: lisp/ChangeLog
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/ChangeLog,v
retrieving revision 1.814
diff -u -U0 -r1.814 ChangeLog
--- lisp/ChangeLog 23 Jul 2007 14:19:39 -0000 1.814
+++ lisp/ChangeLog 27 Jul 2007 22:20:12 -0000
＠＠ -0,0 +1,6 ＠＠
+2007-07-28 Adrian Aichner <adrian(a)xemacs.org>
+
+ * package-get.el (package-get-download-sites): Document Chile and
+ update Denmark download site.
+ * package-get.el (package-get-pre-release-download-sites): Ditto.
+
xemacs-21.5-clean source patch:
Diff command: cvs -f -z3 -q diff -u -w -N
Files affected: lisp/package-get.el
===================================================================
RCS
Index: lisp/package-get.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/package-get.el,v
retrieving revision 1.78
diff -u -w -r1.78 package-get.el
--- lisp/package-get.el 22 Jun 2007 23:17:50 -0000 1.78
+++ lisp/package-get.el 27 Jul 2007 22:18:16 -0000
＠＠ -222,8 +222,10 ＠＠
("Canada (ca.xemacs.org)" "ftp.ca.xemacs.org" "pub/Mirror/xemacs/packages")
("Canada (crc.ca)" "ftp.crc.ca" "pub/packages/editors/xemacs/packages")
("Canada (nrc.ca)" "ftp.nrc.ca" "pub/packages/editors/xemacs/packages")
+; ;; no anonymous ftp available:
+; ("Chile (cl.xemacs.org)" "ftp.cl.xemacs.org" "packages")
("Czech Republic (cz.xemacs.org)" "ftp.cz.xemacs.org" "MIRRORS/ftp.xemacs.org/pub/xemacs/packages")
- ("Denmark (dk.xemacs.org)" "ftp.dk.xemacs.org" "pub/emacs/xemacs/packages")
+ ("Denmark (dk.xemacs.org)" "ftp.dk.xemacs.org" "xemacs/packages")
("Finland (fi.xemacs.org)" "ftp.fi.xemacs.org" "pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/packages")
("France (fr.xemacs.org)" "ftp.fr.xemacs.org" "pub/xemacs/packages")
("France (mirror.cict.fr)" "mirror.cict.fr" "xemacs/packages")
＠＠ -297,10 +299,13 ＠＠
"pub/packages/editors/xemacs/beta/experimental/packages")
("Canada Pre-Releases (nrc.ca)" "ftp.nrc.ca"
"pub/packages/editors/xemacs/beta/experimental/packages")
+; ;; no anonymous ftp available:
+; ("Chile Pre-Releases (cl.xemacs.org)" "ftp.cl.xemacs.org"
+; "beta/experimental/packages")
("Czech Republic Pre-Releases (cz.xemacs.org)" "ftp.cz.xemacs.org"
"MIRRORS/ftp.xemacs.org/pub/xemacs/xemacs-21.5/experimental/packages")
("Denmark Pre-Releases (dk.xemacs.org)" "ftp.dk.xemacs.org"
- "pub/emacs/xemacs/beta/experimental/packages")
+ "xemacs/beta/experimental/packages")
("Finland Pre-Releases (fi.xemacs.org)" "ftp.fi.xemacs.org"
"pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/beta/experimental/packages")
("France Pre-Releases (fr.xemacs.org)" "ftp.fr.xemacs.org"
--
Adrian Aichner
mailto:adrian＠xemacs.org
http://www.xemacs.org/
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Make fsf-compat-unicode.el work with recent revisions to 21.5
17 years, 5 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
mule-packages/mule-base/ChangeLog addition:
2007-07-27 Aidan Kehoe <kehoea(a)parhasard.net>
* fsf-compat-unicode.el:
* fsf-compat-unicode.el (fsf-compat-ccl-program): New.
* fsf-compat-unicode.el (fsf-compat-init-mule-unicode-charsets):
Use fsf-compat-ccl-program, which better reflects the CCL
behaviour in force at the time it was compiled. Also move the CCL
program constant to actually shifting eight bits at a time.
XEmacs Packages source patch:
Diff command: cvs -q diff -Nu
Files affected: mule-packages/mule-base/fsf-compat-unicode.el
===================================================================
RCS
Index: mule-packages/mule-base/fsf-compat-unicode.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/mule-packages/mule-base/fsf-compat-unicode.el,v
retrieving revision 1.3
diff -u -u -r1.3 fsf-compat-unicode.el
--- mule-packages/mule-base/fsf-compat-unicode.el 2007/07/23 21:20:22 1.3
+++ mule-packages/mule-base/fsf-compat-unicode.el 2007/07/27 20:25:21
＠＠ -29,50 +29,40 ＠＠
;;; Code:
;;; Only for 21.5 and newer.
-(unless (and (fboundp 'encode-char)
- (eq #x31C (with-fboundp '(encode-char decode-char)
- (encode-char (decode-char 'ucs #x31C) 'ucs))))
- (error "Unicode support needed for this file not available!"))
+(eval-when-compile (require 'ccl))
-(if (eval-when-compile
- (and (> emacs-major-version 20)
- (> emacs-minor-version 4)
- (featurep 'mule)))
+;; Check at runtime that the Unicode support is available, and that its
+;; coverage is good enough.
+(unless (if-fboundp 'encode-char
+ (with-fboundp '(encode-char decode-char)
+ (eq #x31C (encode-char (decode-char 'ucs #x31C) 'ucs))))
+ (error 'text-conversion-error
+ "Unicode support needed is not available in your XEmacs."))
+
+;; For redisplay of these character sets, provide a CCL program to address
+;; iso10646-1 X11 fonts.
+(defvar fsf-compat-ccl-program
+ (eval-when-compile
+ (let ((pre-existing [1 10 131127 7 98872 65823 147513 7 82009 127 22]))
+ (when (and (> emacs-major-version 20) (> emacs-minor-version 4)
+ (featurep 'mule))
+ ;; In the event that we're compiling on 21.5, check that the
+ ;; pre-existing constant reflects the intended CCL
+ ;; program. Otherwise, just go ahead and use it.
+ (assert (equal pre-existing
+ (ccl-compile
+ `(1
+ ((r1 = (r1 << 7))
+ (r1 = (r1 | r2))
+ (mule-to-unicode r0 r1)
+ (r1 = (r0 >> 7))
+ (r2 = (r0 & #x7F))))))
+ nil
+ "The pre-compiled CCL program appears broken. "))
+ pre-existing))
+ "CCL program required by `fsf-compat-init-mule-unicode-charsets'.")
- ;; If we're being compiled by 21.5, use the actual define-ccl-program
- ;; macro, but evaluated at runtime.
- ;;
- ;; Having this as
- ;;
- ;; (eval-when-compile (and (featurep 'mule) (macroexpand
- ;; '(define-ccl-program ...))
- ;;
- ;; in order to have the macro evaluated at compile time, results
- ;; in the statement being empty in the compiled file, which as I
- ;; understand it is a bug.
-
- (eval
- '(define-ccl-program fsf-compat-ccl-encode-to-ucs-2
- `(1
- ((r1 = (r1 << 7))
- (r1 = (r1 | r2))
- (mule-to-unicode r0 r1)
- (r1 = (r0 >> 7))
- (r2 = (r0 & 255))))
- "CCL program to transform Mule characters to UCS-2."))
-
- ;; Pre-expand the macro for 21.4. 21.4 will error on loading this file, but
- ;; it may compile it. define-ccl-program should not be a macro, but that's
- ;; by the way.
- (let ((prog [1 10 131127 8 98872 65823 147513 8 82009 255 22]))
- (defconst fsf-compat-ccl-encode-to-ucs-2 prog
- "CCL program to transform Mule characters to UCS-2.")
- (put (quote fsf-compat-ccl-encode-to-ucs-2)
- (quote ccl-program-idx)
- (register-ccl-program (quote fsf-compat-ccl-encode-to-ucs-2) prog))
- nil))
-
(defun fsf-compat-init-mule-unicode-charsets ()
"Make some Mule character sets that the FSF uses available in XEmacs.
＠＠ -92,17 +82,17 ＠＠
(format
"Unicode subset (U+%04X..U+%04X) for FSF compatibility."
first-ucs last-ucs)
- (list 'dimension 2
- 'registries ["iso10646-1"]
- 'chars 96
- 'columns 1
- 'direction 'l2r
- 'final final
- 'graphic 0
- 'short-name (format "Unicode subset %c" final)
- 'long-name (format "Unicode subset (U+%04X..U+%04X)"
- first-ucs last-ucs)
- 'ccl-program 'fsf-compat-ccl-encode-to-ucs-2))
+ `(dimension 2
+ registries ["iso10646-1"]
+ chars 96
+ columns 1
+ direction l2r
+ final final
+ graphic 0
+ short-name ,(format "Unicode subset %c" final)
+ long-name ,(format "Unicode subset (U+%04X..U+%04X)"
+ first-ucs last-ucs)
+ ccl-program ,fsf-compat-ccl-program))
;; The names of the character sets lie, at least as of GNU Emacs
;; 22.0.50.3. The difference appears to be that they keep assigning
;; code points until the end of the 96x96 space of the character sets.
--
On the quay of the little Black Sea port, where the rescued pair came once
more into contact with civilization, Dobrinton was bitten by a dog which was
assumed to be mad, though it may only have been indiscriminating. (Saki)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Move mule-ccl.el -> ccl.el
17 years, 5 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
lisp/ChangeLog addition:
2007-07-27 Aidan Kehoe <kehoea(a)parhasard.net>
* mule/mule-ccl.el:
* mule/ccl.el:
Renamed mule-ccl.el to ccl.el, for compatibility with GNU now we
no longer dump it.
* mule/mule-coding.el (require):
* mule/chinese.el (progn):
Reflect this renaming in a couple of require calls.
XEmacs Trunk source patch:
Diff command: cvs -q diff -Nu
Files affected: lisp/mule/chinese.el
===================================================================
RCS lisp/mule/mule-coding.el
===================================================================
RCS lisp/mule/ccl.el
===================================================================
RCS lisp/mule/mule-ccl.el
===================================================================
RCS
Index: lisp/mule/mule-ccl.el
===================================================================
RCS file: mule-ccl.el
diff -N mule-ccl.el
--- /tmp/cvsAAABVaGMS Fri Jul 27 20:55:08 2007
+++ /dev/null Fri Jul 27 20:55:07 2007
＠＠ -1,1565 +0,0 ＠＠
-;;; mule-ccl.el --- CCL (Code Conversion Language) compiler -*- coding: iso-2022-7bit; -*-
-
-;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
-;; Licensed to the Free Software Foundation.
-;; Copyright (C) 2002, 2007 Free Software Foundation, Inc.
-
-;; Keywords: CCL, mule, multilingual, character set, coding-system
-
-;; This file is part of XEmacs.
-
-;; XEmacs 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.
-
-;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;; Synched up with: FSF 21.0.90
-
-;;; 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.
-;;
-;; Syntax and semantics of CCL program is described in the
-;; documentation of `define-ccl-program'.
-
-;;; Code:
-
-(defconst ccl-command-table
- [if branch loop break repeat write-repeat write-read-repeat
- read read-if read-branch write call end
- read-multibyte-character write-multibyte-character
- translate-character mule-to-unicode unicode-to-mule
- iterate-multiple-map map-multiple map-single lookup-integer
- lookup-character]
- "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
- ex-cmd
- ]
- "Vector of CCL compiled codes (symbols).")
-
-(defconst ccl-extended-code-table
- [read-multibyte-character
- write-multibyte-character
- translate-character
- translate-character-const-tbl
- mule-to-unicode
- unicode-to-mule
- nil nil nil nil nil nil nil nil nil nil ; 0x06-0x0f
- iterate-multiple-map
- map-multiple
- map-single
- lookup-int-const-tbl
- lookup-char-const-tbl
- ]
- "Vector of CCL extended 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))))
-
-(let (code (i 0) (len (length ccl-extended-code-table)))
- (while (< i len)
- (setq code (aref ccl-extended-code-table i))
- (if code
- (progn
- (put code 'ccl-ex-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)
- ;; XEmacs: Embed characters as characters, since their integer values vary at
- ;; runtime.
- ; (if (characterp data)
- ; (setq data (char-int data)))
- (if ic
- (aset ccl-program-vector ic data)
- (let ((len (length ccl-program-vector)))
- (if (>= ccl-current-ic len)
- (let ((new (make-vector (* len 2) nil)))
- (while (> len 0)
- (setq len (1- len))
- (aset new len (aref ccl-program-vector len)))
- (setq ccl-program-vector new))))
- (aset ccl-program-vector ccl-current-ic data)
- (setq ccl-current-ic (1+ ccl-current-ic))))
-
-;; Embed pair of SYMBOL and PROP where (get SYMBOL PROP) should give
-;; proper index number for SYMBOL. PROP should be
-;; `translation-table-id', `translation-hash-table-id'
-;; `code-conversion-map-id', or `ccl-program-idx'.
-(defun ccl-embed-symbol (symbol prop)
- (ccl-embed-data (cons symbol prop)))
-
-;; 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 relative 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)))))
- (ccl-embed-data code)))
-
-;; extended ccl command format
-;; |- 14-bit -|- 3-bit --|- 3-bit --|- 3-bit --|- 5-bit -|
-;; |- EX-OP --|-- REG3 --|-- REG2 --|-- REG ---|-- OP ---|
-(defun ccl-embed-extended-command (ex-op reg reg2 reg3)
- (let ((data (logior (ash (get ex-op 'ccl-ex-code) 3)
- (if (symbolp reg3)
- (get reg3 'ccl-register-number)
- 0))))
- (ccl-embed-code 'ex-cmd reg data reg2)))
-
-;; Just advance `ccl-current-ic' by INC.
-(defun ccl-increment-ic (inc)
- (setq ccl-current-ic (+ ccl-current-ic inc)))
-
-;; 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 compiled 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 (integer-or-char-p 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 ((integer-or-char-p 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))
-
- ((integer-or-char-p 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)
-
-;; Compile SET statement of the form `(RRR = EXPR)'.
-(defun ccl-compile-expression (rrr expr)
- (let ((left (car expr))
- (op (get (nth 1 expr) 'ccl-arith-code))
- (right (nth 2 expr)))
- (if (listp left)
- (progn
- ;; EXPR has the form `((EXPR2 OP2 ARG) OP RIGHT)'. Compile
- ;; the first term as `(r7 = (EXPR2 OP2 ARG)).'
- (ccl-compile-expression 'r7 left)
- (setq left 'r7)))
-
- ;; Now EXPR has the form (LEFT OP RIGHT).
- (if (and (eq rrr left)
- (< op (length ccl-assign-arith-table)))
- ;; Compile this SET statement as `(RRR OP= RIGHT)'.
- (if (integer-or-char-p right)
- (progn
- (ccl-embed-code 'set-assign-expr-const rrr (ash op 3) 'r0)
- (ccl-embed-data right))
- (ccl-check-register right expr)
- (ccl-embed-code 'set-assign-expr-register rrr (ash op 3) right))
-
- ;; Compile this SET statement as `(RRR = (LEFT OP RIGHT))'.
- (if (integer-or-char-p right)
- (progn
- (ccl-embed-code 'set-expr-const rrr (ash op 3) left)
- (ccl-embed-data right))
- (ccl-check-register right expr)
- (ccl-embed-code 'set-expr-register
- rrr
- (logior (ash op 3) (get right 'ccl-register-number))
- left)))))
-
-;; Compile WRITE statement with string argument.
-(defun ccl-compile-write-string (str)
- (setq str (encode-coding-string str 'binary))
- (let ((len (length str)))
- (ccl-embed-code 'write-const-string 1 len)
- (ccl-embed-string len str))
- nil)
-
-;; Compile IF statement of the form `(if CONDITION TRUE-PART FALSE-PART)'.
-;; If READ-FLAG is non-nil, this statement has the form
-;; `(read-if (REG OPERATOR ARG) TRUE-PART FALSE-PART)'.
-(defun ccl-compile-if (cmd &optional read-flag)
- (if (and (/= (length cmd) 3) (/= (length cmd) 4))
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let ((condition (nth 1 cmd))
- (true-cmds (nth 2 cmd))
- (false-cmds (nth 3 cmd))
- jump-cond-address)
- (if (and (listp condition)
- (listp (car condition)))
- ;; If CONDITION is a nested expression, the inner expression
- ;; should be compiled at first as SET statement, i.e.:
- ;; `(if ((X OP2 Y) OP Z) ...)' is compiled into two statements:
- ;; `(r7 = (X OP2 Y)) (if (r7 OP Z) ...)'.
- (progn
- (ccl-compile-expression 'r7 (car condition))
- (setq condition (cons 'r7 (cdr condition)))
- (setq cmd (cons (car cmd)
- (cons condition (cdr (cdr cmd)))))))
-
- (setq jump-cond-address ccl-current-ic)
- ;; Compile CONDITION.
- (if (symbolp condition)
- ;; CONDITION is a register.
- (progn
- (ccl-check-register condition cmd)
- (ccl-embed-code 'jump-cond condition 0))
- ;; CONDITION is a simple expression of the form (RRR OP ARG).
- (let ((rrr (car condition))
- (op (get (nth 1 condition) 'ccl-arith-code))
- (arg (nth 2 condition)))
- (ccl-check-register rrr cmd)
- (if (integer-or-char-p arg)
- (progn
- (ccl-embed-code (if read-flag 'read-jump-cond-expr-const
- 'jump-cond-expr-const)
- rrr 0)
- (ccl-embed-data op)
- (ccl-embed-data arg))
- (ccl-check-register arg cmd)
- (ccl-embed-code (if read-flag 'read-jump-cond-expr-register
- 'jump-cond-expr-register)
- rrr 0)
- (ccl-embed-data op)
- (ccl-embed-data (get arg 'ccl-register-number)))))
-
- ;; Compile TRUE-PART.
- (let ((unconditional-jump (ccl-compile-1 true-cmds)))
- (if (null false-cmds)
- ;; This is the place to jump to if condition is false.
- (progn
- (ccl-embed-current-address jump-cond-address)
- (setq unconditional-jump nil))
- (let (end-true-part-address)
- (if (not unconditional-jump)
- (progn
- ;; If TRUE-PART does not end with unconditional jump, we
- ;; have to jump to the end of FALSE-PART from here.
- (setq end-true-part-address ccl-current-ic)
- (ccl-embed-code 'jump 0 0)))
- ;; This is the place to jump to if CONDITION is false.
- (ccl-embed-current-address jump-cond-address)
- ;; Compile FALSE-PART.
- (setq unconditional-jump
- (and (ccl-compile-1 false-cmds) unconditional-jump))
- (if end-true-part-address
- ;; This is the place to jump to after the end of TRUE-PART.
- (ccl-embed-current-address end-true-part-address))))
- unconditional-jump)))
-
-;; Compile BRANCH statement.
-(defun ccl-compile-branch (cmd)
- (if (< (length cmd) 3)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (ccl-compile-branch-blocks 'branch
- (ccl-compile-branch-expression (nth 1 cmd) cmd)
- (cdr (cdr cmd))))
-
-;; Compile READ statement of the form `(read-branch EXPR BLOCK0 BLOCK1 ...)'.
-(defun ccl-compile-read-branch (cmd)
- (if (< (length cmd) 3)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (ccl-compile-branch-blocks 'read-branch
- (ccl-compile-branch-expression (nth 1 cmd) cmd)
- (cdr (cdr cmd))))
-
-;; Compile EXPRESSION part of BRANCH statement and return register
-;; which holds a value of the expression.
-(defun ccl-compile-branch-expression (expr cmd)
- (if (listp expr)
- ;; EXPR has the form `(EXPR2 OP ARG)'. Compile it as SET
- ;; statement of the form `(r7 = (EXPR2 OP ARG))'.
- (progn
- (ccl-compile-expression 'r7 expr)
- 'r7)
- (ccl-check-register expr cmd)))
-
-;; Compile BLOCKs of BRANCH statement. CODE is 'branch or 'read-branch.
-;; REG is a register which holds a value of EXPRESSION part. BLOCKs
-;; is a list of CCL-BLOCKs.
-(defun ccl-compile-branch-blocks (code rrr blocks)
- (let ((branches (length blocks))
- branch-idx
- jump-table-head-address
- empty-block-indexes
- block-tail-addresses
- block-unconditional-jump)
- (ccl-embed-code code rrr branches)
- (setq jump-table-head-address ccl-current-ic)
- ;; The size of jump table is the number of blocks plus 1 (for the
- ;; case RRR is out of range).
- (ccl-increment-ic (1+ branches))
- (setq empty-block-indexes (list branches))
- ;; Compile each block.
- (setq branch-idx 0)
- (while blocks
- (if (null (car blocks))
- ;; This block is empty.
- (setq empty-block-indexes (cons branch-idx empty-block-indexes)
- block-unconditional-jump t)
- ;; This block is not empty.
- (ccl-embed-data (- ccl-current-ic jump-table-head-address)
- (+ jump-table-head-address branch-idx))
- (setq block-unconditional-jump (ccl-compile-1 (car blocks)))
- (if (not block-unconditional-jump)
- (progn
- ;; Jump address of the end of branches are embedded later.
- ;; For the moment, just remember where to embed them.
- (setq block-tail-addresses
- (cons ccl-current-ic block-tail-addresses))
- (ccl-embed-code 'jump 0 0))))
- (setq branch-idx (1+ branch-idx))
- (setq blocks (cdr blocks)))
- (if (not block-unconditional-jump)
- ;; We don't need jump code at the end of the last block.
- (setq block-tail-addresses (cdr block-tail-addresses)
- ccl-current-ic (1- ccl-current-ic)))
- ;; Embed jump address at the tailing jump commands of blocks.
- (while block-tail-addresses
- (ccl-embed-current-address (car block-tail-addresses))
- (setq block-tail-addresses (cdr block-tail-addresses)))
- ;; For empty blocks, make entries in the jump table point directly here.
- (while empty-block-indexes
- (ccl-embed-data (- ccl-current-ic jump-table-head-address)
- (+ jump-table-head-address (car empty-block-indexes)))
- (setq empty-block-indexes (cdr empty-block-indexes))))
- ;; Branch command ends by unconditional jump if RRR is out of range.
- nil)
-
-;; Compile LOOP statement.
-(defun ccl-compile-loop (cmd)
- (if (< (length cmd) 2)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let* ((ccl-loop-head ccl-current-ic)
- (ccl-breaks nil)
- unconditional-jump)
- (setq cmd (cdr cmd))
- (if cmd
- (progn
- (setq unconditional-jump t)
- (while cmd
- (setq unconditional-jump
- (and (ccl-compile-1 (car cmd)) unconditional-jump))
- (setq cmd (cdr cmd)))
- (if (not ccl-breaks)
- unconditional-jump
- ;; Embed jump address for break statements encountered in
- ;; this loop.
- (while ccl-breaks
- (ccl-embed-current-address (car ccl-breaks))
- (setq ccl-breaks (cdr ccl-breaks))))
- nil))))
-
-;; Compile BREAK statement.
-(defun ccl-compile-break (cmd)
- (if (/= (length cmd) 1)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (if (null ccl-loop-head)
- (error "CCL: No outer loop: %s" cmd))
- (setq ccl-breaks (cons ccl-current-ic ccl-breaks))
- (ccl-embed-code 'jump 0 0)
- t)
-
-;; Compile REPEAT statement.
-(defun ccl-compile-repeat (cmd)
- (if (/= (length cmd) 1)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (if (null ccl-loop-head)
- (error "CCL: No outer loop: %s" cmd))
- (ccl-embed-code 'jump 0 ccl-loop-head)
- t)
-
-;; Compile WRITE-REPEAT statement.
-(defun ccl-compile-write-repeat (cmd)
- (if (/= (length cmd) 2)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (if (null ccl-loop-head)
- (error "CCL: No outer loop: %s" cmd))
- (let ((arg (nth 1 cmd)))
- (cond ((integer-or-char-p arg)
- (ccl-embed-code 'write-const-jump 0 ccl-loop-head)
- (ccl-embed-data arg))
- ((stringp arg)
- (setq arg (encode-coding-string arg 'binary))
- (let ((len (length arg)))
- (ccl-embed-code 'write-string-jump 0 ccl-loop-head)
- (ccl-embed-data len)
- (ccl-embed-string len arg)))
- (t
- (ccl-check-register arg cmd)
- (ccl-embed-code 'write-register-jump arg ccl-loop-head))))
- t)
-
-;; Compile WRITE-READ-REPEAT statement.
-(defun ccl-compile-write-read-repeat (cmd)
- (if (or (< (length cmd) 2) (> (length cmd) 3))
- (error "CCL: Invalid number of arguments: %s" cmd))
- (if (null ccl-loop-head)
- (error "CCL: No outer loop: %s" cmd))
- (let ((rrr (ccl-check-register (nth 1 cmd) cmd))
- (arg (nth 2 cmd)))
- (cond ((null arg)
- (ccl-embed-code 'write-register-read-jump rrr ccl-loop-head))
- ((integer-or-char-p arg)
- (ccl-embed-code 'write-const-read-jump rrr arg ccl-loop-head))
- ((vectorp arg)
- (let ((len (length arg))
- (i 0))
- (ccl-embed-code 'write-array-read-jump rrr ccl-loop-head)
- (ccl-embed-data len)
- (while (< i len)
- (ccl-embed-data (aref arg i))
- (setq i (1+ i)))))
- (t
- (error "CCL: Invalid argument %s: %s" arg cmd)))
- (ccl-embed-code 'read-jump rrr ccl-loop-head))
- t)
-
-;; Compile READ statement.
-(defun ccl-compile-read (cmd)
- (if (< (length cmd) 2)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let* ((args (cdr cmd))
- (i (1- (length args))))
- (while args
- (let ((rrr (ccl-check-register (car args) cmd)))
- (ccl-embed-code 'read-register rrr i)
- (setq args (cdr args) i (1- i)))))
- nil)
-
-;; Compile READ-IF statement.
-(defun ccl-compile-read-if (cmd)
- (ccl-compile-if cmd 'read))
-
-;; Compile WRITE statement.
-(defun ccl-compile-write (cmd)
- (if (< (length cmd) 2)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let ((rrr (nth 1 cmd)))
- (cond ((integer-or-char-p rrr)
- (ccl-embed-code 'write-const-string 0 rrr))
- ((stringp rrr)
- (ccl-compile-write-string rrr))
- ((and (symbolp rrr) (vectorp (nth 2 cmd)))
- (ccl-check-register rrr cmd)
- ;; CMD has the form `(write REG ARRAY)'.
- (let* ((arg (nth 2 cmd))
- (len (length arg))
- (i 0))
- (ccl-embed-code 'write-array rrr len)
- (while (< i len)
- (if (not (integer-or-char-p (aref arg i)))
- (error "CCL: Invalid argument %s: %s" arg cmd))
- (ccl-embed-data (aref arg i))
- (setq i (1+ i)))))
-
- ((symbolp rrr)
- ;; CMD has the form `(write REG ...)'.
- (let* ((args (cdr cmd))
- (i (1- (length args))))
- (while args
- (setq rrr (ccl-check-register (car args) cmd))
- (ccl-embed-code 'write-register rrr i)
- (setq args (cdr args) i (1- i)))))
-
- ((listp rrr)
- ;; CMD has the form `(write (LEFT OP RIGHT))'.
- (let ((left (car rrr))
- (op (get (nth 1 rrr) 'ccl-arith-code))
- (right (nth 2 rrr)))
- (if (listp left)
- (progn
- ;; RRR has the form `((EXPR OP2 ARG) OP RIGHT)'.
- ;; Compile the first term as `(r7 = (EXPR OP2 ARG))'.
- (ccl-compile-expression 'r7 left)
- (setq left 'r7)))
- ;; Now RRR has the form `(ARG OP RIGHT)'.
- (if (integer-or-char-p right)
- (progn
- (ccl-embed-code 'write-expr-const 0 (ash op 3) left)
- (ccl-embed-data right))
- (ccl-check-register right rrr)
- (ccl-embed-code 'write-expr-register 0
- (logior (ash op 3)
- (get right 'ccl-register-number))))))
-
- (t
- (error "CCL: Invalid argument: %s" cmd))))
- nil)
-
-;; Compile CALL statement.
-(defun ccl-compile-call (cmd)
- (if (/= (length cmd) 2)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (if (not (symbolp (nth 1 cmd)))
- (error "CCL: Subroutine should be a symbol: %s" cmd))
- (ccl-embed-code 'call 1 0)
- (ccl-embed-symbol (nth 1 cmd) 'ccl-program-idx)
- nil)
-
-;; Compile END statement.
-(defun ccl-compile-end (cmd)
- (if (/= (length cmd) 1)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (ccl-embed-code 'end 0 0)
- t)
-
-;; Compile read-multibyte-character
-(defun ccl-compile-read-multibyte-character (cmd)
- (if (/= (length cmd) 3)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let ((RRR (nth 1 cmd))
- (rrr (nth 2 cmd)))
- (ccl-check-register rrr cmd)
- (ccl-check-register RRR cmd)
- (ccl-embed-extended-command 'read-multibyte-character rrr RRR 0))
- nil)
-
-;; Compile write-multibyte-character
-(defun ccl-compile-write-multibyte-character (cmd)
- (if (/= (length cmd) 3)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let ((RRR (nth 1 cmd))
- (rrr (nth 2 cmd)))
- (ccl-check-register rrr cmd)
- (ccl-check-register RRR cmd)
- (ccl-embed-extended-command 'write-multibyte-character rrr RRR 0))
- nil)
-
-;; Compile translate-character
-(defun ccl-compile-translate-character (cmd)
- (if (/= (length cmd) 4)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let ((Rrr (nth 1 cmd))
- (RRR (nth 2 cmd))
- (rrr (nth 3 cmd)))
- (ccl-check-register rrr cmd)
- (ccl-check-register RRR cmd)
- (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
- (ccl-embed-extended-command 'translate-character-const-tbl
- rrr RRR 0)
- (ccl-embed-symbol Rrr 'translation-table-id))
- (t
- (ccl-check-register Rrr cmd)
- (ccl-embed-extended-command 'translate-character rrr RRR Rrr))))
- nil)
-
-;; Compile mule-to-unicode
-(defun ccl-compile-mule-to-unicode (cmd)
- (if (/= (length cmd) 3)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let ((RRR (nth 1 cmd))
- (rrr (nth 2 cmd)))
- (ccl-check-register RRR cmd)
- (ccl-check-register rrr cmd)
- (ccl-embed-extended-command 'mule-to-unicode RRR rrr 0))
- nil)
-
-;; Given a Unicode code point in register rrr, write the charset ID of the
-;; corresponding character in RRR, and the Mule-CCL form of its code in rrr.
-(defun ccl-compile-unicode-to-mule (cmd)
- (if (/= (length cmd) 3)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let ((rrr (nth 1 cmd))
- (RRR (nth 2 cmd)))
- (ccl-check-register rrr cmd)
- (ccl-check-register RRR cmd)
- (ccl-embed-extended-command 'unicode-to-mule rrr RRR 0))
- nil)
-
-;; Compile lookup-integer
-(defun ccl-compile-lookup-integer (cmd)
- (if (/= (length cmd) 4)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let ((Rrr (nth 1 cmd))
- (RRR (nth 2 cmd))
- (rrr (nth 3 cmd)))
- (ccl-check-register RRR cmd)
- (ccl-check-register rrr cmd)
- (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
- (ccl-embed-extended-command 'lookup-int-const-tbl
- rrr RRR 0)
- (ccl-embed-symbol Rrr 'translation-hash-table-id))
- (t
- (error "CCL: non-constant table: %s" cmd)
- ;; not implemented:
- (ccl-check-register Rrr cmd)
- (ccl-embed-extended-command 'lookup-int rrr RRR 0))))
- nil)
-
-;; Compile lookup-character
-(defun ccl-compile-lookup-character (cmd)
- (if (/= (length cmd) 4)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let ((Rrr (nth 1 cmd))
- (RRR (nth 2 cmd))
- (rrr (nth 3 cmd)))
- (ccl-check-register RRR cmd)
- (ccl-check-register rrr cmd)
- (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
- (ccl-embed-extended-command 'lookup-char-const-tbl
- rrr RRR 0)
- (ccl-embed-symbol Rrr 'translation-hash-table-id))
- (t
- (error "CCL: non-constant table: %s" cmd)
- ;; not implemented:
- (ccl-check-register Rrr cmd)
- (ccl-embed-extended-command 'lookup-char rrr RRR 0))))
- nil)
-
-(defun ccl-compile-iterate-multiple-map (cmd)
- (ccl-compile-multiple-map-function 'iterate-multiple-map cmd)
- nil)
-
-(defun ccl-compile-map-multiple (cmd)
- (if (/= (length cmd) 4)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let (func arg)
- (setq func
- (lambda (arg mp)
- (let ((len 0) result add)
- (while arg
- (if (consp (car arg))
- (setq add (funcall func (car arg) t)
- result (append result add)
- add (+ (- (car add)) 1))
- (setq result
- (append result
- (list (car arg)))
- add 1))
- (setq arg (cdr arg)
- len (+ len add)))
- (if mp
- (cons (- len) result)
- result))))
- (setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd))
- (funcall func (nth 3 cmd) nil)))
- (ccl-compile-multiple-map-function 'map-multiple arg))
- nil)
-
-(defun ccl-compile-map-single (cmd)
- (if (/= (length cmd) 4)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let ((RRR (nth 1 cmd))
- (rrr (nth 2 cmd))
- (map (nth 3 cmd)))
- (ccl-check-register rrr cmd)
- (ccl-check-register RRR cmd)
- (ccl-embed-extended-command 'map-single rrr RRR 0)
- (cond ((symbolp map)
- (if (get map 'code-conversion-map)
- (ccl-embed-symbol map 'code-conversion-map-id)
- (error "CCL: Invalid map: %s" map)))
- (t
- (error "CCL: Invalid type of arguments: %s" cmd))))
- nil)
-
-(defun ccl-compile-multiple-map-function (command cmd)
- (if (< (length cmd) 4)
- (error "CCL: Invalid number of arguments: %s" cmd))
- (let ((RRR (nth 1 cmd))
- (rrr (nth 2 cmd))
- (args (nthcdr 3 cmd))
- map)
- (ccl-check-register rrr cmd)
- (ccl-check-register RRR cmd)
- (ccl-embed-extended-command command rrr RRR 0)
- (ccl-embed-data (length args))
- (while args
- (setq map (car args))
- (cond ((symbolp map)
- (if (get map 'code-conversion-map)
- (ccl-embed-symbol map 'code-conversion-map-id)
- (error "CCL: Invalid map: %s" map)))
- ((numberp map)
- (ccl-embed-data map))
- (t
- (error "CCL: Invalid type of arguments: %s" cmd)))
- (setq args (cdr args)))))
-
-
-;;; CCL dump staffs
-
-;; To avoid byte-compiler warning.
-(defvar ccl-code)
-
-;;;###autoload
-(defun ccl-dump (ccl-code)
- "Disassemble compiled CCL-CODE."
- (let ((len (length ccl-code))
- (buffer-mag (aref ccl-code 0)))
- (cond ((= buffer-mag 0)
- (insert "Don't output anything.\n"))
- ((= buffer-mag 1)
- (insert "Out-buffer must be as large as in-buffer.\n"))
- (t
- (insert
- (format "Out-buffer must be %d times bigger than in-buffer.\n"
- buffer-mag))))
- (insert "Main-body:\n")
- (setq ccl-current-ic 2)
- (if (> (aref ccl-code 1) 0)
- (progn
- (while (< ccl-current-ic (aref ccl-code 1))
- (ccl-dump-1))
- (insert "At EOF:\n")))
- (while (< ccl-current-ic len)
- (ccl-dump-1))
- ))
-
-;; Return a CCL code in `ccl-code' at `ccl-current-ic'.
-(defun ccl-get-next-code ()
- (prog1
- (aref ccl-code ccl-current-ic)
- (setq ccl-current-ic (1+ ccl-current-ic))))
-
-(defun ccl-dump-1 ()
- (let* ((code (ccl-get-next-code))
- (cmd (aref ccl-code-table (logand code 31)))
- (rrr (ash (logand code 255) -5))
- (cc (ash code -8)))
- (insert (format "%5d:[%s] " (1- ccl-current-ic) cmd))
- (funcall (get cmd 'ccl-dump-function) rrr cc)))
-
-(defun ccl-dump-set-register (rrr cc)
- (insert (format "r%d = r%d\n" rrr cc)))
-
-(defun ccl-dump-set-short-const (rrr cc)
- (insert (format "r%d = %d\n" rrr cc)))
-
-(defun ccl-dump-set-const (rrr ignore)
- (insert (format "r%d = %d\n" rrr (ccl-get-next-code))))
-
-(defun ccl-dump-set-array (rrr cc)
- (let ((rrr2 (logand cc 7))
- (len (ash cc -3))
- (i 0))
- (insert (format "r%d = array[r%d] of length %d\n\t"
- rrr rrr2 len))
- (while (< i len)
- (insert (format "%d " (ccl-get-next-code)))
- (setq i (1+ i)))
- (insert "\n")))
-
-(defun ccl-dump-jump (ignore cc &optional address)
- (insert (format "jump to %d(" (+ (or address ccl-current-ic) cc)))
- (if (>= cc 0)
- (insert "+"))
- (insert (format "%d)\n" (1+ cc))))
-
-(defun ccl-dump-jump-cond (rrr cc)
- (insert (format "if (r%d == 0), " rrr))
- (ccl-dump-jump nil cc))
-
-(defun ccl-dump-write-register-jump (rrr cc)
- (insert (format "write r%d, " rrr))
- (ccl-dump-jump nil cc))
-
-(defun ccl-dump-write-register-read-jump (rrr cc)
- (insert (format "write r%d, read r%d, " rrr rrr))
- (ccl-dump-jump nil cc)
- (ccl-get-next-code) ; Skip dummy READ-JUMP
- )
-
-(defun ccl-extract-arith-op (cc)
- (aref ccl-arith-table (ash cc -6)))
-
-(defun ccl-dump-write-expr-const (ignore cc)
- (insert (format "write (r%d %s %d)\n"
- (logand cc 7)
- (ccl-extract-arith-op cc)
- (ccl-get-next-code))))
-
-(defun ccl-dump-write-expr-register (ignore cc)
- (insert (format "write (r%d %s r%d)\n"
- (logand cc 7)
- (ccl-extract-arith-op cc)
- (logand (ash cc -3) 7))))
-
-(defun ccl-dump-insert-char (cc)
- (cond ((= cc ?\t) (insert " \"^I\""))
- ((= cc ?\n) (insert " \"^J\""))
- (t (insert (format " \"%c\"" cc)))))
-
-(defun ccl-dump-write-const-jump (ignore cc)
- (let ((address ccl-current-ic))
- (insert "write char")
- (ccl-dump-insert-char (ccl-get-next-code))
- (insert ", ")
- (ccl-dump-jump nil cc address)))
-
-(defun ccl-dump-write-const-read-jump (rrr cc)
- (let ((address ccl-current-ic))
- (insert "write char")
- (ccl-dump-insert-char (ccl-get-next-code))
- (insert (format ", read r%d, " rrr))
- (ccl-dump-jump cc address)
- (ccl-get-next-code) ; Skip dummy READ-JUMP
- ))
-
-(defun ccl-dump-write-string-jump (ignore cc)
- (let ((address ccl-current-ic)
- (len (ccl-get-next-code))
- (i 0))
- (insert "write \"")
- (while (< i len)
- (let ((code (ccl-get-next-code)))
- (insert (ash code -16))
- (if (< (1+ i) len) (insert (logand (ash code -8) 255)))
- (if (< (+ i 2) len) (insert (logand code 255))))
- (setq i (+ i 3)))
- (insert "\", ")
- (ccl-dump-jump nil cc address)))
-
-(defun ccl-dump-write-array-read-jump (rrr cc)
- (let ((address ccl-current-ic)
- (len (ccl-get-next-code))
- (i 0))
- (insert (format "write array[r%d] of length %d,\n\t" rrr len))
- (while (< i len)
- (ccl-dump-insert-char (ccl-get-next-code))
- (setq i (1+ i)))
- (insert (format "\n\tthen read r%d, " rrr))
- (ccl-dump-jump nil cc address)
- (ccl-get-next-code) ; Skip dummy READ-JUMP.
- ))
-
-(defun ccl-dump-read-jump (rrr cc)
- (insert (format "read r%d, " rrr))
- (ccl-dump-jump nil cc))
-
-(defun ccl-dump-branch (rrr len)
- (let ((jump-table-head ccl-current-ic)
- (i 0))
- (insert (format "jump to array[r%d] of length %d\n\t" rrr len))
- (while (<= i len)
- (insert (format "%d " (+ jump-table-head (ccl-get-next-code))))
- (setq i (1+ i)))
- (insert "\n")))
-
-(defun ccl-dump-read-register (rrr cc)
- (insert (format "read r%d (%d remaining)\n" rrr cc)))
-
-(defun ccl-dump-read-branch (rrr len)
- (insert (format "read r%d, " rrr))
- (ccl-dump-branch rrr len))
-
-(defun ccl-dump-write-register (rrr cc)
- (insert (format "write r%d (%d remaining)\n" rrr cc)))
-
-(defun ccl-dump-call (ignore cc)
- (insert (format "call subroutine #%d\n" cc)))
-
-(defun ccl-dump-write-const-string (rrr cc)
- (if (= rrr 0)
- (progn
- (insert "write char")
- (ccl-dump-insert-char cc)
- (newline))
- (let ((len cc)
- (i 0))
- (insert "write \"")
- (while (< i len)
- (let ((code (ccl-get-next-code)))
- (insert (format "%c" (lsh code -16)))
- (if (< (1+ i) len)
- (insert (format "%c" (logand (lsh code -8) 255))))
- (if (< (+ i 2) len)
- (insert (format "%c" (logand code 255))))
- (setq i (+ i 3))))
- (insert "\"\n"))))
-
-(defun ccl-dump-write-array (rrr cc)
- (let ((i 0))
- (insert (format "write array[r%d] of length %d\n\t" rrr cc))
- (while (< i cc)
- (ccl-dump-insert-char (ccl-get-next-code))
- (setq i (1+ i)))
- (insert "\n")))
-
-(defun ccl-dump-end (&rest ignore)
- (insert "end\n"))
-
-(defun ccl-dump-set-assign-expr-const (rrr cc)
- (insert (format "r%d %s= %d\n"
- rrr
- (ccl-extract-arith-op cc)
- (ccl-get-next-code))))
-
-(defun ccl-dump-set-assign-expr-register (rrr cc)
- (insert (format "r%d %s= r%d\n"
- rrr
- (ccl-extract-arith-op cc)
- (logand cc 7))))
-
-(defun ccl-dump-set-expr-const (rrr cc)
- (insert (format "r%d = r%d %s %d\n"
- rrr
- (logand cc 7)
- (ccl-extract-arith-op cc)
- (ccl-get-next-code))))
-
-(defun ccl-dump-set-expr-register (rrr cc)
- (insert (format "r%d = r%d %s r%d\n"
- rrr
- (logand cc 7)
- (ccl-extract-arith-op cc)
- (logand (ash cc -3) 7))))
-
-(defun ccl-dump-jump-cond-expr-const (rrr cc)
- (let ((address ccl-current-ic))
- (insert (format "if !(r%d %s %d), "
- rrr
- (aref ccl-arith-table (ccl-get-next-code))
- (ccl-get-next-code)))
- (ccl-dump-jump nil cc address)))
-
-(defun ccl-dump-jump-cond-expr-register (rrr cc)
- (let ((address ccl-current-ic))
- (insert (format "if !(r%d %s r%d), "
- rrr
- (aref ccl-arith-table (ccl-get-next-code))
- (ccl-get-next-code)))
- (ccl-dump-jump nil cc address)))
-
-(defun ccl-dump-read-jump-cond-expr-const (rrr cc)
- (insert (format "read r%d, " rrr))
- (ccl-dump-jump-cond-expr-const rrr cc))
-
-(defun ccl-dump-read-jump-cond-expr-register (rrr cc)
- (insert (format "read r%d, " rrr))
- (ccl-dump-jump-cond-expr-register rrr cc))
-
-(defun ccl-dump-binary (ccl-code)
- (let ((len (length ccl-code))
- (i 2))
- (while (< i len)
- (let ((code (aref ccl-code i))
- (j 27))
- (while (>= j 0)
- (insert (if (= (logand code (ash 1 j)) 0) ?0 ?1))
- (setq j (1- j)))
- (setq code (logand code 31))
- (if (< code (length ccl-code-table))
- (insert (format ":%s" (aref ccl-code-table code))))
- (insert "\n"))
- (setq i (1+ i)))))
-
-(defun ccl-dump-ex-cmd (rrr cc)
- (let* ((RRR (logand cc #x7))
- (Rrr (logand (ash cc -3) #x7))
- (ex-op (aref ccl-extended-code-table (logand (ash cc -6) #x3fff))))
- (insert (format "<%s> " ex-op))
- (funcall (get ex-op 'ccl-dump-function) rrr RRR Rrr)))
-
-(defun ccl-dump-read-multibyte-character (rrr RRR Rrr)
- (insert (format "read-multibyte-character r%d r%d\n" RRR rrr)))
-
-(defun ccl-dump-write-multibyte-character (rrr RRR Rrr)
- (insert (format "write-multibyte-character r%d r%d\n" RRR rrr)))
-
-(defun ccl-dump-translate-character (rrr RRR Rrr)
- (insert (format "translation table(r%d) r%d r%d\n" Rrr RRR rrr)))
-
-(defun ccl-dump-translate-character-const-tbl (rrr RRR Rrr)
- (let ((tbl (ccl-get-next-code)))
- (insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr))))
-
-(defun ccl-dump-lookup-int-const-tbl (rrr RRR Rrr)
- (let ((tbl (ccl-get-next-code)))
- (insert (format "hash table(%S) r%d r%d\n" tbl RRR rrr))))
-
-(defun ccl-dump-lookup-char-const-tbl (rrr RRR Rrr)
- (let ((tbl (ccl-get-next-code)))
- (insert (format "hash table(%S) r%d r%d\n" tbl RRR rrr))))
-
-(defun ccl-dump-mule-to-unicode (rrr RRR Rrr)
- (insert (format "change chars in r%d and r%d to unicode\n" RRR rrr)))
-
-(defun ccl-dump-unicode-to-mule (rrr RRR Rrr)
- (insert (format "converter UCS code %d to a Mule char\n" rrr)))
-
-(defun ccl-dump-iterate-multiple-map (rrr RRR Rrr)
- (let ((notbl (ccl-get-next-code))
- (i 0) id)
- (insert (format "iterate-multiple-map r%d r%d\n" RRR rrr))
- (insert (format "\tnumber of maps is %d .\n\t [" notbl))
- (while (< i notbl)
- (setq id (ccl-get-next-code))
- (insert (format "%S" id))
- (setq i (1+ i)))
- (insert "]\n")))
-
-(defun ccl-dump-map-multiple (rrr RRR Rrr)
- (let ((notbl (ccl-get-next-code))
- (i 0) id)
- (insert (format "map-multiple r%d r%d\n" RRR rrr))
- (insert (format "\tnumber of maps and separators is %d\n\t [" notbl))
- (while (< i notbl)
- (setq id (ccl-get-next-code))
- (if (= id -1)
- (insert "]\n\t [")
- (insert (format "%S " id)))
- (setq i (1+ i)))
- (insert "]\n")))
-
-(defun ccl-dump-map-single (rrr RRR Rrr)
- (let ((id (ccl-get-next-code)))
- (insert (format "map-single r%d r%d map(%S)\n" RRR rrr id))))
-
-
-;; CCL emulation staffs
-
-;; Not yet implemented.
-
-;; Auto-loaded functions.
-
-;;;###autoload
-(defmacro declare-ccl-program (name &optional vector)
- "Declare NAME as a name of CCL program.
-
-This macro exists for backward compatibility. In the old version of
-Emacs, to compile a CCL program which calls another CCL program not
-yet defined, it must be declared as a CCL program in advance. But,
-now CCL program names are resolved not at compile time but before
-execution.
-
-Optional arg VECTOR is a compiled CCL code of the CCL program."
- `(put ',name 'ccl-program-idx (register-ccl-program ',name ,vector)))
-
-;;;###autoload
-(defmacro define-ccl-program (name ccl-program &optional doc)
- "Set NAME to be the compiled CCL code of CCL-PROGRAM.
-
-CCL-PROGRAM has this form:
- (BUFFER_MAGNIFICATION
- CCL_MAIN_CODE
- [ CCL_EOF_CODE ])
-
-BUFFER_MAGNIFICATION is an integer value specifying the approximate
-output buffer magnification size compared with the bytes of input data
-text. If the value is zero, the CCL program can't execute `read' and
-`write' commands.
-
-CCL_MAIN_CODE and CCL_EOF_CODE are CCL program codes. CCL_MAIN_CODE is
-executed first. If there are no more input data when a `read' command is
-executed in CCL_MAIN_CODE, CCL_EOF_CODE is executed. If CCL_MAIN_CODE is
-terminated, CCL_EOF_CODE is not executed.
-
-Here's the syntax of CCL program code in BNF notation. The lines starting
-with two semicolons (and optional leading spaces) describe the semantics.
-
-CCL_MAIN_CODE:= CCL_BLOCK
-
-CCL_EOF_CODE:= CCL_BLOCK
-
-CCL_BLOCK:= STATEMENT | (STATEMENT [STATEMENT ...])
-
-STATEMENT:=
- SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL
- | TRANSLATE | MAP | LOOKUP | END
-
-SET:= (REG = EXPRESSION)
- | (REG ASSIGNMENT_OPERATOR EXPRESSION)
- ;; The following form is the same as (r0 = INT-OR-CHAR).
- | INT-OR-CHAR
-
-EXPRESSION:= ARG | (EXPRESSION OPERATOR ARG)
-
-;; Evaluate EXPRESSION. If the result is nonzero, execute
-;; CCL_BLOCK_0. Otherwise, execute CCL_BLOCK_1.
-IF:= (if EXPRESSION CCL_BLOCK_0 [CCL_BLOCK_1])
-
-;; Evaluate EXPRESSION. Provided that the result is N, execute
-;; CCL_BLOCK_N.
-BRANCH:= (branch EXPRESSION CCL_BLOCK_0 [CCL_BLOCK_1 ...])
-
-;; Execute STATEMENTs until (break) or (end) is executed.
-LOOP:= (loop STATEMENT [STATEMENT ...])
-
-;; Terminate the innermost loop.
-BREAK:= (break)
-
-REPEAT:=
- ;; Jump to the head of the innermost loop.
- (repeat)
- ;; Same as: ((write [REG | INT-OR-CHAR | string])
- ;; (repeat))
- | (write-repeat [REG | INT-OR-CHAR | string])
- ;; Same as: ((write REG [ARRAY])
- ;; (read REG)
- ;; (repeat))
- | (write-read-repeat REG [ARRAY])
- ;; Same as: ((write INT-OR-CHAR)
- ;; (read REG)
- ;; (repeat))
- | (write-read-repeat REG INT-OR-CHAR)
-
-READ:= ;; Set REG_0 to a byte read from the input text, set REG_1
- ;; to the next byte read, and so on. Note that \"byte\" here means
- ;; \"some octet from XEmacs' internal representation\", which may
- ;; not be that useful to you when non-ASCII characters are involved.
- ;;
- ;; Yes, this is exactly the opposite of what (write ...) does.
- (read REG_0 [REG_1 ...])
- ;; Same as: ((read REG)
- ;; (if (REG OPERATOR ARG) CCL_BLOCK_0 CCL_BLOCK_1))
- | (read-if (REG OPERATOR ARG) CCL_BLOCK_0 [CCL_BLOCK_1])
- ;; Same as: ((read REG)
- ;; (branch REG CCL_BLOCK_0 [CCL_BLOCK_1 ...]))
- | (read-branch REG CCL_BLOCK_0 [CCL_BLOCK_1 ...])
- ;; Read a character from the input text, splitting it into its
- ;; multibyte representation. Set REG_0 to the charset ID of the
- ;; character, and set REG_1 to the code point of the character. If
- ;; the dimension of charset is two, set REG_1 to ((CODE0 << 7) |
- ;; CODE1), where CODE0 is the first code point and CODE1 is the
- ;; second code point.
- | (read-multibyte-character REG_0 REG_1)
-
-WRITE:=
- ;; Write REG_0, REG_1, ... to the output buffer. If REG_N is
- ;; a multibyte character, write the corresponding multibyte
- ;; representation.
- (write REG_0 [REG_1 ...])
- ;; Same as: ((r7 = EXPRESSION)
- ;; (write r7))
- | (write EXPRESSION)
- ;; Write the value of `INT-OR-CHAR' to the output buffer. If it
- ;; is a multibyte character, write the corresponding multibyte
- ;; representation.
- | (write INT-OR-CHAR)
- ;; Write the byte sequence of `string' as is to the output
- ;; buffer. It is encoded by binary coding system, thus,
- ;; by this operation, you cannot write multibyte string
- ;; as it is.
- | (write string)
- ;; Same as: (write string)
- | string
- ;; Provided that the value of REG is N, write Nth element of
- ;; ARRAY to the output buffer. If it is a multibyte
- ;; character, write the corresponding multibyte
- ;; representation.
- | (write REG ARRAY)
- ;; Write a multibyte representation of a character whose
- ;; charset ID is REG_0 and code point is REG_1. If the
- ;; dimension of the charset is two, REG_1 should be ((CODE0 <<
- ;; 7) | CODE1), where CODE0 is the first code point and CODE1
- ;; is the second code point of the character.
- | (write-multibyte-character REG_0 REG_1)
-
-;; Call CCL program whose name is ccl-program-name.
-CALL:= (call ccl-program-name)
-
-TRANSLATE:= ;; Not implemented under XEmacs, except mule-to-unicode and
- ;; unicode-to-mule.
- (translate-character REG(table) REG(charset) REG(codepoint))
- | (translate-character SYMBOL REG(charset) REG(codepoint))
- | (mule-to-unicode REG(charset) REG(codepoint))
- | (unicode-to-mule REG(unicode,code) REG(CHARSET))
-
-LOOKUP:=
- (lookup-character SYMBOL REG(charset) REG(codepoint))
- | (lookup-integer SYMBOL REG(integer))
- ;; SYMBOL refers to a table defined by `define-hash-translation-table'.
-
-MAP:=
- (iterate-multiple-map REG REG MAP-IDs)
- | (map-multiple REG REG (MAP-SET))
- | (map-single REG REG MAP-ID)
-MAP-IDs:= MAP-ID ...
-MAP-SET:= MAP-IDs | (MAP-IDs) MAP-SET
-MAP-ID:= INT-OR-CHAR
-
-;; Terminate the CCL program.
-END:= (end)
-
-;; CCL registers. These can contain any integer value. As r7 is used by the
-;; CCL interpreter itself, its value can change unexpectedly.
-REG:= r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7
-
-ARG:= REG | INT-OR-CHAR
-
-OPERATOR:=
- ;; Normal arithmetical operators (same meaning as C code).
- + | - | * | / | %
-
- ;; Bitwise operators (same meaning as C code)
- | & | `|' | ^
-
- ;; Shifting operators (same meaning as C code)
- | << | >>
-
- ;; (REG = ARG_0 <8 ARG_1) means:
- ;; (REG = ((ARG_0 << 8) | ARG_1))
- | <8
-
- ;; (REG = ARG_0 >8 ARG_1) means:
- ;; ((REG = (ARG_0 >> 8))
- ;; (r7 = (ARG_0 & 255)))
- | >8
-
- ;; (REG = ARG_0 // ARG_1) means:
- ;; ((REG = (ARG_0 / ARG_1))
- ;; (r7 = (ARG_0 % ARG_1)))
- | //
-
- ;; Normal comparing operators (same meaning as C code)
- | < | > | == | <= | >= | !=
-
- ;; If ARG_0 and ARG_1 are higher and lower byte of Shift-JIS
- ;; code, and CHAR is the corresponding JISX0208 character,
- ;; (REG = ARG_0 de-sjis ARG_1) means:
- ;; ((REG = CODE0)
- ;; (r7 = CODE1))
- ;; where CODE0 is the first code point of CHAR, CODE1 is the
- ;; second code point of CHAR.
- | de-sjis
-
- ;; If ARG_0 and ARG_1 are the first and second code point of
- ;; JISX0208 character CHAR, and SJIS is the correponding
- ;; Shift-JIS code,
- ;; (REG = ARG_0 en-sjis ARG_1) means:
- ;; ((REG = HIGH)
- ;; (r7 = LOW))
- ;; where HIGH is the higher byte of SJIS, LOW is the lower
- ;; byte of SJIS.
- | en-sjis
-
-ASSIGNMENT_OPERATOR:=
- ;; Same meaning as C code
- += | -= | *= | /= | %= | &= | `|=' | ^= | <<= | >>=
-
- ;; (REG <8= ARG) is the same as:
- ;; ((REG <<= 8)
- ;; (REG |= ARG))
- | <8=
-
- ;; (REG >8= ARG) is the same as:
- ;; ((r7 = (REG & 255))
- ;; (REG >>= 8))
-
- ;; (REG //= ARG) is the same as:
- ;; ((r7 = (REG % ARG))
- ;; (REG /= ARG))
- | //=
-
-ARRAY:= `[' INT-OR-CHAR ... `]'
-
-INT-OR-CHAR:= integer | character
-"
- `(let ((prog ,(ccl-compile (eval ccl-program))))
- (defconst ,name prog ,doc)
- (put ',name 'ccl-program-idx (register-ccl-program ',name prog))
- nil))
-
-;;;###autoload
-(defmacro check-ccl-program (ccl-program &optional name)
- "Check validity of CCL-PROGRAM.
-If CCL-PROGRAM is a symbol denoting a CCL program, return
-CCL-PROGRAM, else return nil.
-If CCL-PROGRAM is a vector and optional arg NAME (symbol) is supplied,
-register CCL-PROGRAM by name NAME, and return NAME."
- `(if (ccl-program-p ,ccl-program)
- (if (vectorp ,ccl-program)
- (progn
- (register-ccl-program ,name ,ccl-program)
- ,name)
- ,ccl-program)))
-
-(provide 'ccl)
-
-;; ccl.el ends here
\ No newline at end of file
Index: lisp/mule/ccl.el
===================================================================
RCS file: ccl.el
diff -N ccl.el
--- /dev/null Fri Jul 27 20:55:07 2007
+++ ccl.el Fri Jul 27 20:55:07 2007
＠＠ -0,0 +1,1565 ＠＠
+;;; ccl.el --- CCL (Code Conversion Language) compiler -*- coding: iso-2022-7bit; -*-
+
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+;; Licensed to the Free Software Foundation.
+;; Copyright (C) 2002, 2007 Free Software Foundation, Inc.
+
+;; Keywords: CCL, mule, multilingual, character set, coding-system
+
+;; This file is part of XEmacs.
+
+;; XEmacs 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.
+
+;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;; Synched up with: FSF 21.0.90
+
+;;; 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.
+;;
+;; Syntax and semantics of CCL program is described in the
+;; documentation of `define-ccl-program'.
+
+;;; Code:
+
+(defconst ccl-command-table
+ [if branch loop break repeat write-repeat write-read-repeat
+ read read-if read-branch write call end
+ read-multibyte-character write-multibyte-character
+ translate-character mule-to-unicode unicode-to-mule
+ iterate-multiple-map map-multiple map-single lookup-integer
+ lookup-character]
+ "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
+ ex-cmd
+ ]
+ "Vector of CCL compiled codes (symbols).")
+
+(defconst ccl-extended-code-table
+ [read-multibyte-character
+ write-multibyte-character
+ translate-character
+ translate-character-const-tbl
+ mule-to-unicode
+ unicode-to-mule
+ nil nil nil nil nil nil nil nil nil nil ; 0x06-0x0f
+ iterate-multiple-map
+ map-multiple
+ map-single
+ lookup-int-const-tbl
+ lookup-char-const-tbl
+ ]
+ "Vector of CCL extended 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))))
+
+(let (code (i 0) (len (length ccl-extended-code-table)))
+ (while (< i len)
+ (setq code (aref ccl-extended-code-table i))
+ (if code
+ (progn
+ (put code 'ccl-ex-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)
+ ;; XEmacs: Embed characters as characters, since their integer values vary at
+ ;; runtime.
+ ; (if (characterp data)
+ ; (setq data (char-int data)))
+ (if ic
+ (aset ccl-program-vector ic data)
+ (let ((len (length ccl-program-vector)))
+ (if (>= ccl-current-ic len)
+ (let ((new (make-vector (* len 2) nil)))
+ (while (> len 0)
+ (setq len (1- len))
+ (aset new len (aref ccl-program-vector len)))
+ (setq ccl-program-vector new))))
+ (aset ccl-program-vector ccl-current-ic data)
+ (setq ccl-current-ic (1+ ccl-current-ic))))
+
+;; Embed pair of SYMBOL and PROP where (get SYMBOL PROP) should give
+;; proper index number for SYMBOL. PROP should be
+;; `translation-table-id', `translation-hash-table-id'
+;; `code-conversion-map-id', or `ccl-program-idx'.
+(defun ccl-embed-symbol (symbol prop)
+ (ccl-embed-data (cons symbol prop)))
+
+;; 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 relative 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)))))
+ (ccl-embed-data code)))
+
+;; extended ccl command format
+;; |- 14-bit -|- 3-bit --|- 3-bit --|- 3-bit --|- 5-bit -|
+;; |- EX-OP --|-- REG3 --|-- REG2 --|-- REG ---|-- OP ---|
+(defun ccl-embed-extended-command (ex-op reg reg2 reg3)
+ (let ((data (logior (ash (get ex-op 'ccl-ex-code) 3)
+ (if (symbolp reg3)
+ (get reg3 'ccl-register-number)
+ 0))))
+ (ccl-embed-code 'ex-cmd reg data reg2)))
+
+;; Just advance `ccl-current-ic' by INC.
+(defun ccl-increment-ic (inc)
+ (setq ccl-current-ic (+ ccl-current-ic inc)))
+
+;; 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 compiled 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 (integer-or-char-p 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 ((integer-or-char-p 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))
+
+ ((integer-or-char-p 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)
+
+;; Compile SET statement of the form `(RRR = EXPR)'.
+(defun ccl-compile-expression (rrr expr)
+ (let ((left (car expr))
+ (op (get (nth 1 expr) 'ccl-arith-code))
+ (right (nth 2 expr)))
+ (if (listp left)
+ (progn
+ ;; EXPR has the form `((EXPR2 OP2 ARG) OP RIGHT)'. Compile
+ ;; the first term as `(r7 = (EXPR2 OP2 ARG)).'
+ (ccl-compile-expression 'r7 left)
+ (setq left 'r7)))
+
+ ;; Now EXPR has the form (LEFT OP RIGHT).
+ (if (and (eq rrr left)
+ (< op (length ccl-assign-arith-table)))
+ ;; Compile this SET statement as `(RRR OP= RIGHT)'.
+ (if (integer-or-char-p right)
+ (progn
+ (ccl-embed-code 'set-assign-expr-const rrr (ash op 3) 'r0)
+ (ccl-embed-data right))
+ (ccl-check-register right expr)
+ (ccl-embed-code 'set-assign-expr-register rrr (ash op 3) right))
+
+ ;; Compile this SET statement as `(RRR = (LEFT OP RIGHT))'.
+ (if (integer-or-char-p right)
+ (progn
+ (ccl-embed-code 'set-expr-const rrr (ash op 3) left)
+ (ccl-embed-data right))
+ (ccl-check-register right expr)
+ (ccl-embed-code 'set-expr-register
+ rrr
+ (logior (ash op 3) (get right 'ccl-register-number))
+ left)))))
+
+;; Compile WRITE statement with string argument.
+(defun ccl-compile-write-string (str)
+ (setq str (encode-coding-string str 'binary))
+ (let ((len (length str)))
+ (ccl-embed-code 'write-const-string 1 len)
+ (ccl-embed-string len str))
+ nil)
+
+;; Compile IF statement of the form `(if CONDITION TRUE-PART FALSE-PART)'.
+;; If READ-FLAG is non-nil, this statement has the form
+;; `(read-if (REG OPERATOR ARG) TRUE-PART FALSE-PART)'.
+(defun ccl-compile-if (cmd &optional read-flag)
+ (if (and (/= (length cmd) 3) (/= (length cmd) 4))
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((condition (nth 1 cmd))
+ (true-cmds (nth 2 cmd))
+ (false-cmds (nth 3 cmd))
+ jump-cond-address)
+ (if (and (listp condition)
+ (listp (car condition)))
+ ;; If CONDITION is a nested expression, the inner expression
+ ;; should be compiled at first as SET statement, i.e.:
+ ;; `(if ((X OP2 Y) OP Z) ...)' is compiled into two statements:
+ ;; `(r7 = (X OP2 Y)) (if (r7 OP Z) ...)'.
+ (progn
+ (ccl-compile-expression 'r7 (car condition))
+ (setq condition (cons 'r7 (cdr condition)))
+ (setq cmd (cons (car cmd)
+ (cons condition (cdr (cdr cmd)))))))
+
+ (setq jump-cond-address ccl-current-ic)
+ ;; Compile CONDITION.
+ (if (symbolp condition)
+ ;; CONDITION is a register.
+ (progn
+ (ccl-check-register condition cmd)
+ (ccl-embed-code 'jump-cond condition 0))
+ ;; CONDITION is a simple expression of the form (RRR OP ARG).
+ (let ((rrr (car condition))
+ (op (get (nth 1 condition) 'ccl-arith-code))
+ (arg (nth 2 condition)))
+ (ccl-check-register rrr cmd)
+ (if (integer-or-char-p arg)
+ (progn
+ (ccl-embed-code (if read-flag 'read-jump-cond-expr-const
+ 'jump-cond-expr-const)
+ rrr 0)
+ (ccl-embed-data op)
+ (ccl-embed-data arg))
+ (ccl-check-register arg cmd)
+ (ccl-embed-code (if read-flag 'read-jump-cond-expr-register
+ 'jump-cond-expr-register)
+ rrr 0)
+ (ccl-embed-data op)
+ (ccl-embed-data (get arg 'ccl-register-number)))))
+
+ ;; Compile TRUE-PART.
+ (let ((unconditional-jump (ccl-compile-1 true-cmds)))
+ (if (null false-cmds)
+ ;; This is the place to jump to if condition is false.
+ (progn
+ (ccl-embed-current-address jump-cond-address)
+ (setq unconditional-jump nil))
+ (let (end-true-part-address)
+ (if (not unconditional-jump)
+ (progn
+ ;; If TRUE-PART does not end with unconditional jump, we
+ ;; have to jump to the end of FALSE-PART from here.
+ (setq end-true-part-address ccl-current-ic)
+ (ccl-embed-code 'jump 0 0)))
+ ;; This is the place to jump to if CONDITION is false.
+ (ccl-embed-current-address jump-cond-address)
+ ;; Compile FALSE-PART.
+ (setq unconditional-jump
+ (and (ccl-compile-1 false-cmds) unconditional-jump))
+ (if end-true-part-address
+ ;; This is the place to jump to after the end of TRUE-PART.
+ (ccl-embed-current-address end-true-part-address))))
+ unconditional-jump)))
+
+;; Compile BRANCH statement.
+(defun ccl-compile-branch (cmd)
+ (if (< (length cmd) 3)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (ccl-compile-branch-blocks 'branch
+ (ccl-compile-branch-expression (nth 1 cmd) cmd)
+ (cdr (cdr cmd))))
+
+;; Compile READ statement of the form `(read-branch EXPR BLOCK0 BLOCK1 ...)'.
+(defun ccl-compile-read-branch (cmd)
+ (if (< (length cmd) 3)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (ccl-compile-branch-blocks 'read-branch
+ (ccl-compile-branch-expression (nth 1 cmd) cmd)
+ (cdr (cdr cmd))))
+
+;; Compile EXPRESSION part of BRANCH statement and return register
+;; which holds a value of the expression.
+(defun ccl-compile-branch-expression (expr cmd)
+ (if (listp expr)
+ ;; EXPR has the form `(EXPR2 OP ARG)'. Compile it as SET
+ ;; statement of the form `(r7 = (EXPR2 OP ARG))'.
+ (progn
+ (ccl-compile-expression 'r7 expr)
+ 'r7)
+ (ccl-check-register expr cmd)))
+
+;; Compile BLOCKs of BRANCH statement. CODE is 'branch or 'read-branch.
+;; REG is a register which holds a value of EXPRESSION part. BLOCKs
+;; is a list of CCL-BLOCKs.
+(defun ccl-compile-branch-blocks (code rrr blocks)
+ (let ((branches (length blocks))
+ branch-idx
+ jump-table-head-address
+ empty-block-indexes
+ block-tail-addresses
+ block-unconditional-jump)
+ (ccl-embed-code code rrr branches)
+ (setq jump-table-head-address ccl-current-ic)
+ ;; The size of jump table is the number of blocks plus 1 (for the
+ ;; case RRR is out of range).
+ (ccl-increment-ic (1+ branches))
+ (setq empty-block-indexes (list branches))
+ ;; Compile each block.
+ (setq branch-idx 0)
+ (while blocks
+ (if (null (car blocks))
+ ;; This block is empty.
+ (setq empty-block-indexes (cons branch-idx empty-block-indexes)
+ block-unconditional-jump t)
+ ;; This block is not empty.
+ (ccl-embed-data (- ccl-current-ic jump-table-head-address)
+ (+ jump-table-head-address branch-idx))
+ (setq block-unconditional-jump (ccl-compile-1 (car blocks)))
+ (if (not block-unconditional-jump)
+ (progn
+ ;; Jump address of the end of branches are embedded later.
+ ;; For the moment, just remember where to embed them.
+ (setq block-tail-addresses
+ (cons ccl-current-ic block-tail-addresses))
+ (ccl-embed-code 'jump 0 0))))
+ (setq branch-idx (1+ branch-idx))
+ (setq blocks (cdr blocks)))
+ (if (not block-unconditional-jump)
+ ;; We don't need jump code at the end of the last block.
+ (setq block-tail-addresses (cdr block-tail-addresses)
+ ccl-current-ic (1- ccl-current-ic)))
+ ;; Embed jump address at the tailing jump commands of blocks.
+ (while block-tail-addresses
+ (ccl-embed-current-address (car block-tail-addresses))
+ (setq block-tail-addresses (cdr block-tail-addresses)))
+ ;; For empty blocks, make entries in the jump table point directly here.
+ (while empty-block-indexes
+ (ccl-embed-data (- ccl-current-ic jump-table-head-address)
+ (+ jump-table-head-address (car empty-block-indexes)))
+ (setq empty-block-indexes (cdr empty-block-indexes))))
+ ;; Branch command ends by unconditional jump if RRR is out of range.
+ nil)
+
+;; Compile LOOP statement.
+(defun ccl-compile-loop (cmd)
+ (if (< (length cmd) 2)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let* ((ccl-loop-head ccl-current-ic)
+ (ccl-breaks nil)
+ unconditional-jump)
+ (setq cmd (cdr cmd))
+ (if cmd
+ (progn
+ (setq unconditional-jump t)
+ (while cmd
+ (setq unconditional-jump
+ (and (ccl-compile-1 (car cmd)) unconditional-jump))
+ (setq cmd (cdr cmd)))
+ (if (not ccl-breaks)
+ unconditional-jump
+ ;; Embed jump address for break statements encountered in
+ ;; this loop.
+ (while ccl-breaks
+ (ccl-embed-current-address (car ccl-breaks))
+ (setq ccl-breaks (cdr ccl-breaks))))
+ nil))))
+
+;; Compile BREAK statement.
+(defun ccl-compile-break (cmd)
+ (if (/= (length cmd) 1)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (if (null ccl-loop-head)
+ (error "CCL: No outer loop: %s" cmd))
+ (setq ccl-breaks (cons ccl-current-ic ccl-breaks))
+ (ccl-embed-code 'jump 0 0)
+ t)
+
+;; Compile REPEAT statement.
+(defun ccl-compile-repeat (cmd)
+ (if (/= (length cmd) 1)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (if (null ccl-loop-head)
+ (error "CCL: No outer loop: %s" cmd))
+ (ccl-embed-code 'jump 0 ccl-loop-head)
+ t)
+
+;; Compile WRITE-REPEAT statement.
+(defun ccl-compile-write-repeat (cmd)
+ (if (/= (length cmd) 2)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (if (null ccl-loop-head)
+ (error "CCL: No outer loop: %s" cmd))
+ (let ((arg (nth 1 cmd)))
+ (cond ((integer-or-char-p arg)
+ (ccl-embed-code 'write-const-jump 0 ccl-loop-head)
+ (ccl-embed-data arg))
+ ((stringp arg)
+ (setq arg (encode-coding-string arg 'binary))
+ (let ((len (length arg)))
+ (ccl-embed-code 'write-string-jump 0 ccl-loop-head)
+ (ccl-embed-data len)
+ (ccl-embed-string len arg)))
+ (t
+ (ccl-check-register arg cmd)
+ (ccl-embed-code 'write-register-jump arg ccl-loop-head))))
+ t)
+
+;; Compile WRITE-READ-REPEAT statement.
+(defun ccl-compile-write-read-repeat (cmd)
+ (if (or (< (length cmd) 2) (> (length cmd) 3))
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (if (null ccl-loop-head)
+ (error "CCL: No outer loop: %s" cmd))
+ (let ((rrr (ccl-check-register (nth 1 cmd) cmd))
+ (arg (nth 2 cmd)))
+ (cond ((null arg)
+ (ccl-embed-code 'write-register-read-jump rrr ccl-loop-head))
+ ((integer-or-char-p arg)
+ (ccl-embed-code 'write-const-read-jump rrr arg ccl-loop-head))
+ ((vectorp arg)
+ (let ((len (length arg))
+ (i 0))
+ (ccl-embed-code 'write-array-read-jump rrr ccl-loop-head)
+ (ccl-embed-data len)
+ (while (< i len)
+ (ccl-embed-data (aref arg i))
+ (setq i (1+ i)))))
+ (t
+ (error "CCL: Invalid argument %s: %s" arg cmd)))
+ (ccl-embed-code 'read-jump rrr ccl-loop-head))
+ t)
+
+;; Compile READ statement.
+(defun ccl-compile-read (cmd)
+ (if (< (length cmd) 2)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let* ((args (cdr cmd))
+ (i (1- (length args))))
+ (while args
+ (let ((rrr (ccl-check-register (car args) cmd)))
+ (ccl-embed-code 'read-register rrr i)
+ (setq args (cdr args) i (1- i)))))
+ nil)
+
+;; Compile READ-IF statement.
+(defun ccl-compile-read-if (cmd)
+ (ccl-compile-if cmd 'read))
+
+;; Compile WRITE statement.
+(defun ccl-compile-write (cmd)
+ (if (< (length cmd) 2)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((rrr (nth 1 cmd)))
+ (cond ((integer-or-char-p rrr)
+ (ccl-embed-code 'write-const-string 0 rrr))
+ ((stringp rrr)
+ (ccl-compile-write-string rrr))
+ ((and (symbolp rrr) (vectorp (nth 2 cmd)))
+ (ccl-check-register rrr cmd)
+ ;; CMD has the form `(write REG ARRAY)'.
+ (let* ((arg (nth 2 cmd))
+ (len (length arg))
+ (i 0))
+ (ccl-embed-code 'write-array rrr len)
+ (while (< i len)
+ (if (not (integer-or-char-p (aref arg i)))
+ (error "CCL: Invalid argument %s: %s" arg cmd))
+ (ccl-embed-data (aref arg i))
+ (setq i (1+ i)))))
+
+ ((symbolp rrr)
+ ;; CMD has the form `(write REG ...)'.
+ (let* ((args (cdr cmd))
+ (i (1- (length args))))
+ (while args
+ (setq rrr (ccl-check-register (car args) cmd))
+ (ccl-embed-code 'write-register rrr i)
+ (setq args (cdr args) i (1- i)))))
+
+ ((listp rrr)
+ ;; CMD has the form `(write (LEFT OP RIGHT))'.
+ (let ((left (car rrr))
+ (op (get (nth 1 rrr) 'ccl-arith-code))
+ (right (nth 2 rrr)))
+ (if (listp left)
+ (progn
+ ;; RRR has the form `((EXPR OP2 ARG) OP RIGHT)'.
+ ;; Compile the first term as `(r7 = (EXPR OP2 ARG))'.
+ (ccl-compile-expression 'r7 left)
+ (setq left 'r7)))
+ ;; Now RRR has the form `(ARG OP RIGHT)'.
+ (if (integer-or-char-p right)
+ (progn
+ (ccl-embed-code 'write-expr-const 0 (ash op 3) left)
+ (ccl-embed-data right))
+ (ccl-check-register right rrr)
+ (ccl-embed-code 'write-expr-register 0
+ (logior (ash op 3)
+ (get right 'ccl-register-number))))))
+
+ (t
+ (error "CCL: Invalid argument: %s" cmd))))
+ nil)
+
+;; Compile CALL statement.
+(defun ccl-compile-call (cmd)
+ (if (/= (length cmd) 2)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (if (not (symbolp (nth 1 cmd)))
+ (error "CCL: Subroutine should be a symbol: %s" cmd))
+ (ccl-embed-code 'call 1 0)
+ (ccl-embed-symbol (nth 1 cmd) 'ccl-program-idx)
+ nil)
+
+;; Compile END statement.
+(defun ccl-compile-end (cmd)
+ (if (/= (length cmd) 1)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (ccl-embed-code 'end 0 0)
+ t)
+
+;; Compile read-multibyte-character
+(defun ccl-compile-read-multibyte-character (cmd)
+ (if (/= (length cmd) 3)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((RRR (nth 1 cmd))
+ (rrr (nth 2 cmd)))
+ (ccl-check-register rrr cmd)
+ (ccl-check-register RRR cmd)
+ (ccl-embed-extended-command 'read-multibyte-character rrr RRR 0))
+ nil)
+
+;; Compile write-multibyte-character
+(defun ccl-compile-write-multibyte-character (cmd)
+ (if (/= (length cmd) 3)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((RRR (nth 1 cmd))
+ (rrr (nth 2 cmd)))
+ (ccl-check-register rrr cmd)
+ (ccl-check-register RRR cmd)
+ (ccl-embed-extended-command 'write-multibyte-character rrr RRR 0))
+ nil)
+
+;; Compile translate-character
+(defun ccl-compile-translate-character (cmd)
+ (if (/= (length cmd) 4)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((Rrr (nth 1 cmd))
+ (RRR (nth 2 cmd))
+ (rrr (nth 3 cmd)))
+ (ccl-check-register rrr cmd)
+ (ccl-check-register RRR cmd)
+ (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
+ (ccl-embed-extended-command 'translate-character-const-tbl
+ rrr RRR 0)
+ (ccl-embed-symbol Rrr 'translation-table-id))
+ (t
+ (ccl-check-register Rrr cmd)
+ (ccl-embed-extended-command 'translate-character rrr RRR Rrr))))
+ nil)
+
+;; Compile mule-to-unicode
+(defun ccl-compile-mule-to-unicode (cmd)
+ (if (/= (length cmd) 3)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((RRR (nth 1 cmd))
+ (rrr (nth 2 cmd)))
+ (ccl-check-register RRR cmd)
+ (ccl-check-register rrr cmd)
+ (ccl-embed-extended-command 'mule-to-unicode RRR rrr 0))
+ nil)
+
+;; Given a Unicode code point in register rrr, write the charset ID of the
+;; corresponding character in RRR, and the Mule-CCL form of its code in rrr.
+(defun ccl-compile-unicode-to-mule (cmd)
+ (if (/= (length cmd) 3)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((rrr (nth 1 cmd))
+ (RRR (nth 2 cmd)))
+ (ccl-check-register rrr cmd)
+ (ccl-check-register RRR cmd)
+ (ccl-embed-extended-command 'unicode-to-mule rrr RRR 0))
+ nil)
+
+;; Compile lookup-integer
+(defun ccl-compile-lookup-integer (cmd)
+ (if (/= (length cmd) 4)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((Rrr (nth 1 cmd))
+ (RRR (nth 2 cmd))
+ (rrr (nth 3 cmd)))
+ (ccl-check-register RRR cmd)
+ (ccl-check-register rrr cmd)
+ (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
+ (ccl-embed-extended-command 'lookup-int-const-tbl
+ rrr RRR 0)
+ (ccl-embed-symbol Rrr 'translation-hash-table-id))
+ (t
+ (error "CCL: non-constant table: %s" cmd)
+ ;; not implemented:
+ (ccl-check-register Rrr cmd)
+ (ccl-embed-extended-command 'lookup-int rrr RRR 0))))
+ nil)
+
+;; Compile lookup-character
+(defun ccl-compile-lookup-character (cmd)
+ (if (/= (length cmd) 4)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((Rrr (nth 1 cmd))
+ (RRR (nth 2 cmd))
+ (rrr (nth 3 cmd)))
+ (ccl-check-register RRR cmd)
+ (ccl-check-register rrr cmd)
+ (cond ((and (symbolp Rrr) (not (get Rrr 'ccl-register-number)))
+ (ccl-embed-extended-command 'lookup-char-const-tbl
+ rrr RRR 0)
+ (ccl-embed-symbol Rrr 'translation-hash-table-id))
+ (t
+ (error "CCL: non-constant table: %s" cmd)
+ ;; not implemented:
+ (ccl-check-register Rrr cmd)
+ (ccl-embed-extended-command 'lookup-char rrr RRR 0))))
+ nil)
+
+(defun ccl-compile-iterate-multiple-map (cmd)
+ (ccl-compile-multiple-map-function 'iterate-multiple-map cmd)
+ nil)
+
+(defun ccl-compile-map-multiple (cmd)
+ (if (/= (length cmd) 4)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let (func arg)
+ (setq func
+ (lambda (arg mp)
+ (let ((len 0) result add)
+ (while arg
+ (if (consp (car arg))
+ (setq add (funcall func (car arg) t)
+ result (append result add)
+ add (+ (- (car add)) 1))
+ (setq result
+ (append result
+ (list (car arg)))
+ add 1))
+ (setq arg (cdr arg)
+ len (+ len add)))
+ (if mp
+ (cons (- len) result)
+ result))))
+ (setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd))
+ (funcall func (nth 3 cmd) nil)))
+ (ccl-compile-multiple-map-function 'map-multiple arg))
+ nil)
+
+(defun ccl-compile-map-single (cmd)
+ (if (/= (length cmd) 4)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((RRR (nth 1 cmd))
+ (rrr (nth 2 cmd))
+ (map (nth 3 cmd)))
+ (ccl-check-register rrr cmd)
+ (ccl-check-register RRR cmd)
+ (ccl-embed-extended-command 'map-single rrr RRR 0)
+ (cond ((symbolp map)
+ (if (get map 'code-conversion-map)
+ (ccl-embed-symbol map 'code-conversion-map-id)
+ (error "CCL: Invalid map: %s" map)))
+ (t
+ (error "CCL: Invalid type of arguments: %s" cmd))))
+ nil)
+
+(defun ccl-compile-multiple-map-function (command cmd)
+ (if (< (length cmd) 4)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((RRR (nth 1 cmd))
+ (rrr (nth 2 cmd))
+ (args (nthcdr 3 cmd))
+ map)
+ (ccl-check-register rrr cmd)
+ (ccl-check-register RRR cmd)
+ (ccl-embed-extended-command command rrr RRR 0)
+ (ccl-embed-data (length args))
+ (while args
+ (setq map (car args))
+ (cond ((symbolp map)
+ (if (get map 'code-conversion-map)
+ (ccl-embed-symbol map 'code-conversion-map-id)
+ (error "CCL: Invalid map: %s" map)))
+ ((numberp map)
+ (ccl-embed-data map))
+ (t
+ (error "CCL: Invalid type of arguments: %s" cmd)))
+ (setq args (cdr args)))))
+
+
+;;; CCL dump staffs
+
+;; To avoid byte-compiler warning.
+(defvar ccl-code)
+
+;;;###autoload
+(defun ccl-dump (ccl-code)
+ "Disassemble compiled CCL-CODE."
+ (let ((len (length ccl-code))
+ (buffer-mag (aref ccl-code 0)))
+ (cond ((= buffer-mag 0)
+ (insert "Don't output anything.\n"))
+ ((= buffer-mag 1)
+ (insert "Out-buffer must be as large as in-buffer.\n"))
+ (t
+ (insert
+ (format "Out-buffer must be %d times bigger than in-buffer.\n"
+ buffer-mag))))
+ (insert "Main-body:\n")
+ (setq ccl-current-ic 2)
+ (if (> (aref ccl-code 1) 0)
+ (progn
+ (while (< ccl-current-ic (aref ccl-code 1))
+ (ccl-dump-1))
+ (insert "At EOF:\n")))
+ (while (< ccl-current-ic len)
+ (ccl-dump-1))
+ ))
+
+;; Return a CCL code in `ccl-code' at `ccl-current-ic'.
+(defun ccl-get-next-code ()
+ (prog1
+ (aref ccl-code ccl-current-ic)
+ (setq ccl-current-ic (1+ ccl-current-ic))))
+
+(defun ccl-dump-1 ()
+ (let* ((code (ccl-get-next-code))
+ (cmd (aref ccl-code-table (logand code 31)))
+ (rrr (ash (logand code 255) -5))
+ (cc (ash code -8)))
+ (insert (format "%5d:[%s] " (1- ccl-current-ic) cmd))
+ (funcall (get cmd 'ccl-dump-function) rrr cc)))
+
+(defun ccl-dump-set-register (rrr cc)
+ (insert (format "r%d = r%d\n" rrr cc)))
+
+(defun ccl-dump-set-short-const (rrr cc)
+ (insert (format "r%d = %d\n" rrr cc)))
+
+(defun ccl-dump-set-const (rrr ignore)
+ (insert (format "r%d = %d\n" rrr (ccl-get-next-code))))
+
+(defun ccl-dump-set-array (rrr cc)
+ (let ((rrr2 (logand cc 7))
+ (len (ash cc -3))
+ (i 0))
+ (insert (format "r%d = array[r%d] of length %d\n\t"
+ rrr rrr2 len))
+ (while (< i len)
+ (insert (format "%d " (ccl-get-next-code)))
+ (setq i (1+ i)))
+ (insert "\n")))
+
+(defun ccl-dump-jump (ignore cc &optional address)
+ (insert (format "jump to %d(" (+ (or address ccl-current-ic) cc)))
+ (if (>= cc 0)
+ (insert "+"))
+ (insert (format "%d)\n" (1+ cc))))
+
+(defun ccl-dump-jump-cond (rrr cc)
+ (insert (format "if (r%d == 0), " rrr))
+ (ccl-dump-jump nil cc))
+
+(defun ccl-dump-write-register-jump (rrr cc)
+ (insert (format "write r%d, " rrr))
+ (ccl-dump-jump nil cc))
+
+(defun ccl-dump-write-register-read-jump (rrr cc)
+ (insert (format "write r%d, read r%d, " rrr rrr))
+ (ccl-dump-jump nil cc)
+ (ccl-get-next-code) ; Skip dummy READ-JUMP
+ )
+
+(defun ccl-extract-arith-op (cc)
+ (aref ccl-arith-table (ash cc -6)))
+
+(defun ccl-dump-write-expr-const (ignore cc)
+ (insert (format "write (r%d %s %d)\n"
+ (logand cc 7)
+ (ccl-extract-arith-op cc)
+ (ccl-get-next-code))))
+
+(defun ccl-dump-write-expr-register (ignore cc)
+ (insert (format "write (r%d %s r%d)\n"
+ (logand cc 7)
+ (ccl-extract-arith-op cc)
+ (logand (ash cc -3) 7))))
+
+(defun ccl-dump-insert-char (cc)
+ (cond ((= cc ?\t) (insert " \"^I\""))
+ ((= cc ?\n) (insert " \"^J\""))
+ (t (insert (format " \"%c\"" cc)))))
+
+(defun ccl-dump-write-const-jump (ignore cc)
+ (let ((address ccl-current-ic))
+ (insert "write char")
+ (ccl-dump-insert-char (ccl-get-next-code))
+ (insert ", ")
+ (ccl-dump-jump nil cc address)))
+
+(defun ccl-dump-write-const-read-jump (rrr cc)
+ (let ((address ccl-current-ic))
+ (insert "write char")
+ (ccl-dump-insert-char (ccl-get-next-code))
+ (insert (format ", read r%d, " rrr))
+ (ccl-dump-jump cc address)
+ (ccl-get-next-code) ; Skip dummy READ-JUMP
+ ))
+
+(defun ccl-dump-write-string-jump (ignore cc)
+ (let ((address ccl-current-ic)
+ (len (ccl-get-next-code))
+ (i 0))
+ (insert "write \"")
+ (while (< i len)
+ (let ((code (ccl-get-next-code)))
+ (insert (ash code -16))
+ (if (< (1+ i) len) (insert (logand (ash code -8) 255)))
+ (if (< (+ i 2) len) (insert (logand code 255))))
+ (setq i (+ i 3)))
+ (insert "\", ")
+ (ccl-dump-jump nil cc address)))
+
+(defun ccl-dump-write-array-read-jump (rrr cc)
+ (let ((address ccl-current-ic)
+ (len (ccl-get-next-code))
+ (i 0))
+ (insert (format "write array[r%d] of length %d,\n\t" rrr len))
+ (while (< i len)
+ (ccl-dump-insert-char (ccl-get-next-code))
+ (setq i (1+ i)))
+ (insert (format "\n\tthen read r%d, " rrr))
+ (ccl-dump-jump nil cc address)
+ (ccl-get-next-code) ; Skip dummy READ-JUMP.
+ ))
+
+(defun ccl-dump-read-jump (rrr cc)
+ (insert (format "read r%d, " rrr))
+ (ccl-dump-jump nil cc))
+
+(defun ccl-dump-branch (rrr len)
+ (let ((jump-table-head ccl-current-ic)
+ (i 0))
+ (insert (format "jump to array[r%d] of length %d\n\t" rrr len))
+ (while (<= i len)
+ (insert (format "%d " (+ jump-table-head (ccl-get-next-code))))
+ (setq i (1+ i)))
+ (insert "\n")))
+
+(defun ccl-dump-read-register (rrr cc)
+ (insert (format "read r%d (%d remaining)\n" rrr cc)))
+
+(defun ccl-dump-read-branch (rrr len)
+ (insert (format "read r%d, " rrr))
+ (ccl-dump-branch rrr len))
+
+(defun ccl-dump-write-register (rrr cc)
+ (insert (format "write r%d (%d remaining)\n" rrr cc)))
+
+(defun ccl-dump-call (ignore cc)
+ (insert (format "call subroutine #%d\n" cc)))
+
+(defun ccl-dump-write-const-string (rrr cc)
+ (if (= rrr 0)
+ (progn
+ (insert "write char")
+ (ccl-dump-insert-char cc)
+ (newline))
+ (let ((len cc)
+ (i 0))
+ (insert "write \"")
+ (while (< i len)
+ (let ((code (ccl-get-next-code)))
+ (insert (format "%c" (lsh code -16)))
+ (if (< (1+ i) len)
+ (insert (format "%c" (logand (lsh code -8) 255))))
+ (if (< (+ i 2) len)
+ (insert (format "%c" (logand code 255))))
+ (setq i (+ i 3))))
+ (insert "\"\n"))))
+
+(defun ccl-dump-write-array (rrr cc)
+ (let ((i 0))
+ (insert (format "write array[r%d] of length %d\n\t" rrr cc))
+ (while (< i cc)
+ (ccl-dump-insert-char (ccl-get-next-code))
+ (setq i (1+ i)))
+ (insert "\n")))
+
+(defun ccl-dump-end (&rest ignore)
+ (insert "end\n"))
+
+(defun ccl-dump-set-assign-expr-const (rrr cc)
+ (insert (format "r%d %s= %d\n"
+ rrr
+ (ccl-extract-arith-op cc)
+ (ccl-get-next-code))))
+
+(defun ccl-dump-set-assign-expr-register (rrr cc)
+ (insert (format "r%d %s= r%d\n"
+ rrr
+ (ccl-extract-arith-op cc)
+ (logand cc 7))))
+
+(defun ccl-dump-set-expr-const (rrr cc)
+ (insert (format "r%d = r%d %s %d\n"
+ rrr
+ (logand cc 7)
+ (ccl-extract-arith-op cc)
+ (ccl-get-next-code))))
+
+(defun ccl-dump-set-expr-register (rrr cc)
+ (insert (format "r%d = r%d %s r%d\n"
+ rrr
+ (logand cc 7)
+ (ccl-extract-arith-op cc)
+ (logand (ash cc -3) 7))))
+
+(defun ccl-dump-jump-cond-expr-const (rrr cc)
+ (let ((address ccl-current-ic))
+ (insert (format "if !(r%d %s %d), "
+ rrr
+ (aref ccl-arith-table (ccl-get-next-code))
+ (ccl-get-next-code)))
+ (ccl-dump-jump nil cc address)))
+
+(defun ccl-dump-jump-cond-expr-register (rrr cc)
+ (let ((address ccl-current-ic))
+ (insert (format "if !(r%d %s r%d), "
+ rrr
+ (aref ccl-arith-table (ccl-get-next-code))
+ (ccl-get-next-code)))
+ (ccl-dump-jump nil cc address)))
+
+(defun ccl-dump-read-jump-cond-expr-const (rrr cc)
+ (insert (format "read r%d, " rrr))
+ (ccl-dump-jump-cond-expr-const rrr cc))
+
+(defun ccl-dump-read-jump-cond-expr-register (rrr cc)
+ (insert (format "read r%d, " rrr))
+ (ccl-dump-jump-cond-expr-register rrr cc))
+
+(defun ccl-dump-binary (ccl-code)
+ (let ((len (length ccl-code))
+ (i 2))
+ (while (< i len)
+ (let ((code (aref ccl-code i))
+ (j 27))
+ (while (>= j 0)
+ (insert (if (= (logand code (ash 1 j)) 0) ?0 ?1))
+ (setq j (1- j)))
+ (setq code (logand code 31))
+ (if (< code (length ccl-code-table))
+ (insert (format ":%s" (aref ccl-code-table code))))
+ (insert "\n"))
+ (setq i (1+ i)))))
+
+(defun ccl-dump-ex-cmd (rrr cc)
+ (let* ((RRR (logand cc #x7))
+ (Rrr (logand (ash cc -3) #x7))
+ (ex-op (aref ccl-extended-code-table (logand (ash cc -6) #x3fff))))
+ (insert (format "<%s> " ex-op))
+ (funcall (get ex-op 'ccl-dump-function) rrr RRR Rrr)))
+
+(defun ccl-dump-read-multibyte-character (rrr RRR Rrr)
+ (insert (format "read-multibyte-character r%d r%d\n" RRR rrr)))
+
+(defun ccl-dump-write-multibyte-character (rrr RRR Rrr)
+ (insert (format "write-multibyte-character r%d r%d\n" RRR rrr)))
+
+(defun ccl-dump-translate-character (rrr RRR Rrr)
+ (insert (format "translation table(r%d) r%d r%d\n" Rrr RRR rrr)))
+
+(defun ccl-dump-translate-character-const-tbl (rrr RRR Rrr)
+ (let ((tbl (ccl-get-next-code)))
+ (insert (format "translation table(%S) r%d r%d\n" tbl RRR rrr))))
+
+(defun ccl-dump-lookup-int-const-tbl (rrr RRR Rrr)
+ (let ((tbl (ccl-get-next-code)))
+ (insert (format "hash table(%S) r%d r%d\n" tbl RRR rrr))))
+
+(defun ccl-dump-lookup-char-const-tbl (rrr RRR Rrr)
+ (let ((tbl (ccl-get-next-code)))
+ (insert (format "hash table(%S) r%d r%d\n" tbl RRR rrr))))
+
+(defun ccl-dump-mule-to-unicode (rrr RRR Rrr)
+ (insert (format "change chars in r%d and r%d to unicode\n" RRR rrr)))
+
+(defun ccl-dump-unicode-to-mule (rrr RRR Rrr)
+ (insert (format "converter UCS code %d to a Mule char\n" rrr)))
+
+(defun ccl-dump-iterate-multiple-map (rrr RRR Rrr)
+ (let ((notbl (ccl-get-next-code))
+ (i 0) id)
+ (insert (format "iterate-multiple-map r%d r%d\n" RRR rrr))
+ (insert (format "\tnumber of maps is %d .\n\t [" notbl))
+ (while (< i notbl)
+ (setq id (ccl-get-next-code))
+ (insert (format "%S" id))
+ (setq i (1+ i)))
+ (insert "]\n")))
+
+(defun ccl-dump-map-multiple (rrr RRR Rrr)
+ (let ((notbl (ccl-get-next-code))
+ (i 0) id)
+ (insert (format "map-multiple r%d r%d\n" RRR rrr))
+ (insert (format "\tnumber of maps and separators is %d\n\t [" notbl))
+ (while (< i notbl)
+ (setq id (ccl-get-next-code))
+ (if (= id -1)
+ (insert "]\n\t [")
+ (insert (format "%S " id)))
+ (setq i (1+ i)))
+ (insert "]\n")))
+
+(defun ccl-dump-map-single (rrr RRR Rrr)
+ (let ((id (ccl-get-next-code)))
+ (insert (format "map-single r%d r%d map(%S)\n" RRR rrr id))))
+
+
+;; CCL emulation staffs
+
+;; Not yet implemented.
+
+;; Auto-loaded functions.
+
+;;;###autoload
+(defmacro declare-ccl-program (name &optional vector)
+ "Declare NAME as a name of CCL program.
+
+This macro exists for backward compatibility. In the old version of
+Emacs, to compile a CCL program which calls another CCL program not
+yet defined, it must be declared as a CCL program in advance. But,
+now CCL program names are resolved not at compile time but before
+execution.
+
+Optional arg VECTOR is a compiled CCL code of the CCL program."
+ `(put ',name 'ccl-program-idx (register-ccl-program ',name ,vector)))
+
+;;;###autoload
+(defmacro define-ccl-program (name ccl-program &optional doc)
+ "Set NAME to be the compiled CCL code of CCL-PROGRAM.
+
+CCL-PROGRAM has this form:
+ (BUFFER_MAGNIFICATION
+ CCL_MAIN_CODE
+ [ CCL_EOF_CODE ])
+
+BUFFER_MAGNIFICATION is an integer value specifying the approximate
+output buffer magnification size compared with the bytes of input data
+text. If the value is zero, the CCL program can't execute `read' and
+`write' commands.
+
+CCL_MAIN_CODE and CCL_EOF_CODE are CCL program codes. CCL_MAIN_CODE is
+executed first. If there are no more input data when a `read' command is
+executed in CCL_MAIN_CODE, CCL_EOF_CODE is executed. If CCL_MAIN_CODE is
+terminated, CCL_EOF_CODE is not executed.
+
+Here's the syntax of CCL program code in BNF notation. The lines starting
+with two semicolons (and optional leading spaces) describe the semantics.
+
+CCL_MAIN_CODE:= CCL_BLOCK
+
+CCL_EOF_CODE:= CCL_BLOCK
+
+CCL_BLOCK:= STATEMENT | (STATEMENT [STATEMENT ...])
+
+STATEMENT:=
+ SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL
+ | TRANSLATE | MAP | LOOKUP | END
+
+SET:= (REG = EXPRESSION)
+ | (REG ASSIGNMENT_OPERATOR EXPRESSION)
+ ;; The following form is the same as (r0 = INT-OR-CHAR).
+ | INT-OR-CHAR
+
+EXPRESSION:= ARG | (EXPRESSION OPERATOR ARG)
+
+;; Evaluate EXPRESSION. If the result is nonzero, execute
+;; CCL_BLOCK_0. Otherwise, execute CCL_BLOCK_1.
+IF:= (if EXPRESSION CCL_BLOCK_0 [CCL_BLOCK_1])
+
+;; Evaluate EXPRESSION. Provided that the result is N, execute
+;; CCL_BLOCK_N.
+BRANCH:= (branch EXPRESSION CCL_BLOCK_0 [CCL_BLOCK_1 ...])
+
+;; Execute STATEMENTs until (break) or (end) is executed.
+LOOP:= (loop STATEMENT [STATEMENT ...])
+
+;; Terminate the innermost loop.
+BREAK:= (break)
+
+REPEAT:=
+ ;; Jump to the head of the innermost loop.
+ (repeat)
+ ;; Same as: ((write [REG | INT-OR-CHAR | string])
+ ;; (repeat))
+ | (write-repeat [REG | INT-OR-CHAR | string])
+ ;; Same as: ((write REG [ARRAY])
+ ;; (read REG)
+ ;; (repeat))
+ | (write-read-repeat REG [ARRAY])
+ ;; Same as: ((write INT-OR-CHAR)
+ ;; (read REG)
+ ;; (repeat))
+ | (write-read-repeat REG INT-OR-CHAR)
+
+READ:= ;; Set REG_0 to a byte read from the input text, set REG_1
+ ;; to the next byte read, and so on. Note that \"byte\" here means
+ ;; \"some octet from XEmacs' internal representation\", which may
+ ;; not be that useful to you when non-ASCII characters are involved.
+ ;;
+ ;; Yes, this is exactly the opposite of what (write ...) does.
+ (read REG_0 [REG_1 ...])
+ ;; Same as: ((read REG)
+ ;; (if (REG OPERATOR ARG) CCL_BLOCK_0 CCL_BLOCK_1))
+ | (read-if (REG OPERATOR ARG) CCL_BLOCK_0 [CCL_BLOCK_1])
+ ;; Same as: ((read REG)
+ ;; (branch REG CCL_BLOCK_0 [CCL_BLOCK_1 ...]))
+ | (read-branch REG CCL_BLOCK_0 [CCL_BLOCK_1 ...])
+ ;; Read a character from the input text, splitting it into its
+ ;; multibyte representation. Set REG_0 to the charset ID of the
+ ;; character, and set REG_1 to the code point of the character. If
+ ;; the dimension of charset is two, set REG_1 to ((CODE0 << 7) |
+ ;; CODE1), where CODE0 is the first code point and CODE1 is the
+ ;; second code point.
+ | (read-multibyte-character REG_0 REG_1)
+
+WRITE:=
+ ;; Write REG_0, REG_1, ... to the output buffer. If REG_N is
+ ;; a multibyte character, write the corresponding multibyte
+ ;; representation.
+ (write REG_0 [REG_1 ...])
+ ;; Same as: ((r7 = EXPRESSION)
+ ;; (write r7))
+ | (write EXPRESSION)
+ ;; Write the value of `INT-OR-CHAR' to the output buffer. If it
+ ;; is a multibyte character, write the corresponding multibyte
+ ;; representation.
+ | (write INT-OR-CHAR)
+ ;; Write the byte sequence of `string' as is to the output
+ ;; buffer. It is encoded by binary coding system, thus,
+ ;; by this operation, you cannot write multibyte string
+ ;; as it is.
+ | (write string)
+ ;; Same as: (write string)
+ | string
+ ;; Provided that the value of REG is N, write Nth element of
+ ;; ARRAY to the output buffer. If it is a multibyte
+ ;; character, write the corresponding multibyte
+ ;; representation.
+ | (write REG ARRAY)
+ ;; Write a multibyte representation of a character whose
+ ;; charset ID is REG_0 and code point is REG_1. If the
+ ;; dimension of the charset is two, REG_1 should be ((CODE0 <<
+ ;; 7) | CODE1), where CODE0 is the first code point and CODE1
+ ;; is the second code point of the character.
+ | (write-multibyte-character REG_0 REG_1)
+
+;; Call CCL program whose name is ccl-program-name.
+CALL:= (call ccl-program-name)
+
+TRANSLATE:= ;; Not implemented under XEmacs, except mule-to-unicode and
+ ;; unicode-to-mule.
+ (translate-character REG(table) REG(charset) REG(codepoint))
+ | (translate-character SYMBOL REG(charset) REG(codepoint))
+ | (mule-to-unicode REG(charset) REG(codepoint))
+ | (unicode-to-mule REG(unicode,code) REG(CHARSET))
+
+LOOKUP:=
+ (lookup-character SYMBOL REG(charset) REG(codepoint))
+ | (lookup-integer SYMBOL REG(integer))
+ ;; SYMBOL refers to a table defined by `define-hash-translation-table'.
+
+MAP:=
+ (iterate-multiple-map REG REG MAP-IDs)
+ | (map-multiple REG REG (MAP-SET))
+ | (map-single REG REG MAP-ID)
+MAP-IDs:= MAP-ID ...
+MAP-SET:= MAP-IDs | (MAP-IDs) MAP-SET
+MAP-ID:= INT-OR-CHAR
+
+;; Terminate the CCL program.
+END:= (end)
+
+;; CCL registers. These can contain any integer value. As r7 is used by the
+;; CCL interpreter itself, its value can change unexpectedly.
+REG:= r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7
+
+ARG:= REG | INT-OR-CHAR
+
+OPERATOR:=
+ ;; Normal arithmetical operators (same meaning as C code).
+ + | - | * | / | %
+
+ ;; Bitwise operators (same meaning as C code)
+ | & | `|' | ^
+
+ ;; Shifting operators (same meaning as C code)
+ | << | >>
+
+ ;; (REG = ARG_0 <8 ARG_1) means:
+ ;; (REG = ((ARG_0 << 8) | ARG_1))
+ | <8
+
+ ;; (REG = ARG_0 >8 ARG_1) means:
+ ;; ((REG = (ARG_0 >> 8))
+ ;; (r7 = (ARG_0 & 255)))
+ | >8
+
+ ;; (REG = ARG_0 // ARG_1) means:
+ ;; ((REG = (ARG_0 / ARG_1))
+ ;; (r7 = (ARG_0 % ARG_1)))
+ | //
+
+ ;; Normal comparing operators (same meaning as C code)
+ | < | > | == | <= | >= | !=
+
+ ;; If ARG_0 and ARG_1 are higher and lower byte of Shift-JIS
+ ;; code, and CHAR is the corresponding JISX0208 character,
+ ;; (REG = ARG_0 de-sjis ARG_1) means:
+ ;; ((REG = CODE0)
+ ;; (r7 = CODE1))
+ ;; where CODE0 is the first code point of CHAR, CODE1 is the
+ ;; second code point of CHAR.
+ | de-sjis
+
+ ;; If ARG_0 and ARG_1 are the first and second code point of
+ ;; JISX0208 character CHAR, and SJIS is the correponding
+ ;; Shift-JIS code,
+ ;; (REG = ARG_0 en-sjis ARG_1) means:
+ ;; ((REG = HIGH)
+ ;; (r7 = LOW))
+ ;; where HIGH is the higher byte of SJIS, LOW is the lower
+ ;; byte of SJIS.
+ | en-sjis
+
+ASSIGNMENT_OPERATOR:=
+ ;; Same meaning as C code
+ += | -= | *= | /= | %= | &= | `|=' | ^= | <<= | >>=
+
+ ;; (REG <8= ARG) is the same as:
+ ;; ((REG <<= 8)
+ ;; (REG |= ARG))
+ | <8=
+
+ ;; (REG >8= ARG) is the same as:
+ ;; ((r7 = (REG & 255))
+ ;; (REG >>= 8))
+
+ ;; (REG //= ARG) is the same as:
+ ;; ((r7 = (REG % ARG))
+ ;; (REG /= ARG))
+ | //=
+
+ARRAY:= `[' INT-OR-CHAR ... `]'
+
+INT-OR-CHAR:= integer | character
+"
+ `(let ((prog ,(ccl-compile (eval ccl-program))))
+ (defconst ,name prog ,doc)
+ (put ',name 'ccl-program-idx (register-ccl-program ',name prog))
+ nil))
+
+;;;###autoload
+(defmacro check-ccl-program (ccl-program &optional name)
+ "Check validity of CCL-PROGRAM.
+If CCL-PROGRAM is a symbol denoting a CCL program, return
+CCL-PROGRAM, else return nil.
+If CCL-PROGRAM is a vector and optional arg NAME (symbol) is supplied,
+register CCL-PROGRAM by name NAME, and return NAME."
+ `(if (ccl-program-p ,ccl-program)
+ (if (vectorp ,ccl-program)
+ (progn
+ (register-ccl-program ,name ,ccl-program)
+ ,name)
+ ,ccl-program)))
+
+(provide 'ccl)
+
+;; ccl.el ends here
\ No newline at end of file
Index: lisp/mule/mule-coding.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/mule-coding.el,v
retrieving revision 1.20
diff -u -u -r1.20 mule-coding.el
--- lisp/mule/mule-coding.el 2007/07/22 22:03:50 1.20
+++ lisp/mule/mule-coding.el 2007/07/27 18:55:08
＠＠ -29,7 +29,7 ＠＠
;;; split off of mule.el and mostly moved to coding.el
;; Needed for make-8-bit-coding-system.
-(eval-when-compile (require 'ccl "mule-ccl"))
+(eval-when-compile (require 'ccl))
;;; Code:
Index: lisp/mule/chinese.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/chinese.el,v
retrieving revision 1.14
diff -u -u -r1.14 chinese.el
--- lisp/mule/chinese.el 2007/07/22 22:03:48 1.14
+++ lisp/mule/chinese.el 2007/07/27 18:55:08
＠＠ -31,7 +31,7 ＠＠
;;; Code:
-(eval-when-compile (progn (require 'ccl "mule-ccl") (require 'china-util)))
+(eval-when-compile (progn (require 'ccl) (require 'china-util)))
;; Syntax of Chinese characters.
(loop for row in '(33 34 41)
--
On the quay of the little Black Sea port, where the rescued pair came once
more into contact with civilization, Dobrinton was bitten by a dog which was
assumed to be mad, though it may only have been indiscriminating. (Saki)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[C] xemacsweb: Update paths under updated ftp.dk.xemacs.org mirror location
17 years, 5 months
Adrian Aichner
Adrian Aichner
COMMIT
Hi dotsrc, you're copied for your information.
Best regards!
Adrian
xemacsweb ChangeLog patch:
Diff command: cvs -q diff -U 0
Files affected: Releases/ChangeLog Download/win32/ChangeLog
Index: Releases/ChangeLog
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Releases/ChangeLog,v
retrieving revision 1.142
diff -u -U0 -r1.142 ChangeLog
--- Releases/ChangeLog 25 Jul 2007 17:16:14 -0000 1.142
+++ Releases/ChangeLog 26 Jul 2007 21:39:26 -0000
＠＠ -0,0 +1,8 ＠＠
+2007-07-26 Adrian Aichner <adrian(a)xemacs.org>
+
+ * core-beta.txt: Update paths under updated ftp.dk.xemacs.org
+ mirror location.
+ * core-stable.txt: Ditto.
+ * packages-official.txt: Ditto.
+ * packages-pre-release.txt: Ditto.
+
Index: Download/win32/ChangeLog
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Download/win32/ChangeLog,v
retrieving revision 1.53
diff -u -U0 -r1.53 ChangeLog
--- Download/win32/ChangeLog 25 Jul 2007 17:17:50 -0000 1.53
+++ Download/win32/ChangeLog 26 Jul 2007 21:39:26 -0000
＠＠ -0,0 +1,7 ＠＠
+2007-07-26 Adrian Aichner <adrian(a)xemacs.org>
+
+ * innosetup-win32.txt: Update paths under updated
+ ftp.dk.xemacs.org mirror location.
+ * installshield-win32.txt: Ditto.
+ * netinstall-win32.txt: Ditto.
+
xemacsweb source patch:
Diff command: cvs -f -z3 -q diff -u -w -N
Files affected: Releases/packages-pre-release.txt
===================================================================
RCS Releases/packages-official.txt
===================================================================
RCS Releases/core-stable.txt
===================================================================
RCS Releases/core-beta.txt
===================================================================
RCS Download/win32/netinstall-win32.txt
===================================================================
RCS Download/win32/installshield-win32.txt
===================================================================
RCS Download/win32/innosetup-win32.txt
===================================================================
RCS
Index: Download/win32/innosetup-win32.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Download/win32/innosetup-win32.txt,v
retrieving revision 1.7
diff -u -w -r1.7 innosetup-win32.txt
--- Download/win32/innosetup-win32.txt 25 Jul 2007 17:17:50 -0000 1.7
+++ Download/win32/innosetup-win32.txt 26 Jul 2007 21:37:42 -0000
＠＠ -1,5 +1,5 ＠＠
<!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
- at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
+ at Thu Jul 26 18:22:17 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
＠＠ -22,7 +22,7 ＠＠
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.20.exe">Canada (nrc.ca)</a></li>
<li><a href="http://ftp.cl.xemacs.org/binaries/win32/InnoSetup/XEmacs%20Setup%20... (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/binaries/... Republic (cz.xemacs.org)</a></li>
- <li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/binaries/win32/InnoSetup/... (dk.xemacs.org)</a></li>
+ <li><a href="http://ftp.dk.xemacs.org/xemacs/binaries/win32/InnoSetup/XEmacs%20S... (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
<li><a href="http://ftp.fr.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs... (fr.xemacs.org)</a></li>
<li><a href="ftp://mirror.cict.fr/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.20.exe">France (mirror.cict.fr)</a></li>
Index: Download/win32/installshield-win32.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Download/win32/installshield-win32.txt,v
retrieving revision 1.6
diff -u -w -r1.6 installshield-win32.txt
--- Download/win32/installshield-win32.txt 25 Jul 2007 17:17:50 -0000 1.6
+++ Download/win32/installshield-win32.txt 26 Jul 2007 21:37:42 -0000
＠＠ -1,5 +1,5 ＠＠
<!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
- at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
+ at Thu Jul 26 18:22:17 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
<a id="InstallShield-Download"
＠＠ -26,7 +26,7 ＠＠
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/binaries/win32/installshield/xemacs-21.5.17.exe">Canada (nrc.ca)</a></li>
<li><a href="http://ftp.cl.xemacs.org/binaries/win32/installshield/xemacs-21.5.1... (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/binaries/... Republic (cz.xemacs.org)</a></li>
- <li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/binaries/win32/installshi... (dk.xemacs.org)</a></li>
+ <li><a href="http://ftp.dk.xemacs.org/xemacs/binaries/win32/installshield/xemacs... (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
<li><a href="http://ftp.fr.xemacs.org/pub/xemacs/binaries/win32/installshield/xe... (fr.xemacs.org)</a></li>
<li><a href="ftp://mirror.cict.fr/xemacs/binaries/win32/installshield/xemacs-21.5.17.exe">France (mirror.cict.fr)</a></li>
Index: Download/win32/netinstall-win32.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Download/win32/netinstall-win32.txt,v
retrieving revision 1.6
diff -u -w -r1.6 netinstall-win32.txt
--- Download/win32/netinstall-win32.txt 25 Jul 2007 17:17:50 -0000 1.6
+++ Download/win32/netinstall-win32.txt 26 Jul 2007 21:37:42 -0000
＠＠ -1,5 +1,5 ＠＠
<!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
- at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
+ at Thu Jul 26 18:22:17 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
＠＠ -25,7 +25,7 ＠＠
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/binaries/win32/netinstall/xemacs-i586-pc-win32-21.4.13.tar.gz">Canada (nrc.ca)</a></li>
<li><a href="http://ftp.cl.xemacs.org/binaries/win32/netinstall/xemacs-i586-pc-w... (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/binaries/... Republic (cz.xemacs.org)</a></li>
- <li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/binaries/win32/netinstall... (dk.xemacs.org)</a></li>
+ <li><a href="http://ftp.dk.xemacs.org/xemacs/binaries/win32/netinstall/xemacs-i5... (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
<li><a href="http://ftp.fr.xemacs.org/pub/xemacs/binaries/win32/netinstall/xemac... (fr.xemacs.org)</a></li>
<li><a href="ftp://mirror.cict.fr/xemacs/binaries/win32/netinstall/xemacs-i586-pc-win32-21.4.13.tar.gz">France (mirror.cict.fr)</a></li>
Index: Releases/core-beta.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Releases/core-beta.txt,v
retrieving revision 1.9
diff -u -w -r1.9 core-beta.txt
--- Releases/core-beta.txt 25 Jul 2007 17:16:14 -0000 1.9
+++ Releases/core-beta.txt 26 Jul 2007 21:37:42 -0000
＠＠ -1,5 +1,5 ＠＠
<!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
- at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
+ at Thu Jul 26 18:22:17 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
＠＠ -22,7 +22,7 ＠＠
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/beta">Canada (nrc.ca)</a></li>
<li><a href="http://ftp.cl.xemacs.org/beta">Chile (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/xemacs-21... Republic (cz.xemacs.org)</a></li>
- <li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/beta">Denmark (dk.xemacs.org)</a></li>
+ <li><a href="http://ftp.dk.xemacs.org/xemacs/beta">Denmark (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
<li><a href="http://ftp.fr.xemacs.org/pub/xemacs/beta">France (fr.xemacs.org)</a></li>
<li><a href="ftp://mirror.cict.fr/xemacs/beta">France (mirror.cict.fr)</a></li>
Index: Releases/core-stable.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Releases/core-stable.txt,v
retrieving revision 1.9
diff -u -w -r1.9 core-stable.txt
--- Releases/core-stable.txt 25 Jul 2007 17:16:14 -0000 1.9
+++ Releases/core-stable.txt 26 Jul 2007 21:37:42 -0000
＠＠ -1,5 +1,5 ＠＠
<!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
- at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
+ at Thu Jul 26 18:22:17 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
＠＠ -22,7 +22,7 ＠＠
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/stable">Canada (nrc.ca)</a></li>
<li><a href="http://ftp.cl.xemacs.org/packages">Chile (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/stable">C... Republic (cz.xemacs.org)</a></li>
- <li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/stable">Denmark (dk.xemacs.org)</a></li>
+ <li><a href="http://ftp.dk.xemacs.org/xemacs/stable">Denmark (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
<li><a href="http://ftp.fr.xemacs.org/pub/xemacs/stable">France (fr.xemacs.org)</a></li>
<li><a href="ftp://mirror.cict.fr/xemacs/stable">France (mirror.cict.fr)</a></li>
Index: Releases/packages-official.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Releases/packages-official.txt,v
retrieving revision 1.9
diff -u -w -r1.9 packages-official.txt
--- Releases/packages-official.txt 25 Jul 2007 17:16:15 -0000 1.9
+++ Releases/packages-official.txt 26 Jul 2007 21:37:42 -0000
＠＠ -1,5 +1,5 ＠＠
<!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
- at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
+ at Thu Jul 26 18:22:17 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
＠＠ -25,7 +25,7 ＠＠
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/packages">Canada (nrc.ca)</a></li>
<li><a href="http://ftp.cl.xemacs.org/packages">Chile (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/packages"... Republic (cz.xemacs.org)</a></li>
- <li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/packages">Denmark (dk.xemacs.org)</a></li>
+ <li><a href="http://ftp.dk.xemacs.org/xemacs/packages">Denmark (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
<li><a href="http://ftp.fr.xemacs.org/pub/xemacs/packages">France (fr.xemacs.org)</a></li>
<li><a href="ftp://mirror.cict.fr/xemacs/packages">France (mirror.cict.fr)</a></li>
Index: Releases/packages-pre-release.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Releases/packages-pre-release.txt,v
retrieving revision 1.9
diff -u -w -r1.9 packages-pre-release.txt
--- Releases/packages-pre-release.txt 25 Jul 2007 17:16:15 -0000 1.9
+++ Releases/packages-pre-release.txt 26 Jul 2007 21:37:42 -0000
＠＠ -1,5 +1,5 ＠＠
<!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
- at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
+ at Thu Jul 26 18:22:17 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
＠＠ -25,7 +25,7 ＠＠
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/beta/experimental/packages">Canada Pre-Releases (nrc.ca)</a></li>
<li><a href="http://ftp.cl.xemacs.org/beta/experimental/packages">Chile Pre-Releases (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/xemacs-21... Republic Pre-Releases (cz.xemacs.org)</a></li>
- <li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/beta/experimental/package... Pre-Releases (dk.xemacs.org)</a></li>
+ <li><a href="http://ftp.dk.xemacs.org/xemacs/beta/experimental/packages">Denmark Pre-Releases (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... Pre-Releases (fi.xemacs.org)</a></li>
<li><a href="http://ftp.fr.xemacs.org/pub/xemacs/beta/experimental/packages">France Pre-Releases (fr.xemacs.org)</a></li>
<li><a href="ftp://mirror.cict.fr/xemacs/beta/experimental/packages">France Pre-Releases (mirror.cict.fr)</a></li>
--
Adrian Aichner
mailto:adrian＠xemacs.org
http://www.xemacs.org/
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Re: Cannot build latest CVS of 21.5.28 (possible cause)
17 years, 5 months
Aidan Kehoe
Aidan Kehoe
Ar an ceathrú lá is fiche de mí Iúil, scríobh robert delius royar:
> I had time to recompile without '--with-union-type' The file mule-ccl.c
> compiles. This implies to me that in the recent revisions there are
> assumptions that LispObject is an int rather than a union.
Yeah, my mistake. Thank you!
APPROVE COMMIT
NOTE: This patch has been committed.
src/ChangeLog addition:
2007-07-26 Aidan Kehoe <kehoea(a)parhasard.net>
* mule-ccl.c (ccl_driver):
op is an integer, not a Lisp_Object; don't use it to temporarily
store a Lisp_Object. This change fixes the union build; thank you
for the report, Robert Delius Royar.
XEmacs Trunk source patch:
Diff command: cvs -q diff -u
Files affected: src/mule-ccl.c
===================================================================
RCS
Index: src/mule-ccl.c
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/src/mule-ccl.c,v
retrieving revision 1.32
diff -u -r1.32 mule-ccl.c
--- src/mule-ccl.c 2007/07/22 22:04:14 1.32
+++ src/mule-ccl.c 2007/07/26 11:13:26
＠＠ -1562,10 +1562,9 ＠＠
if (!HTENTRY_CLEAR_P(e))
{
- op = e->value;
- if (!INTP (op))
+ if (!INTP (e->value))
CCL_INVALID_CMD;
- reg[RRR] = XCHAR_OR_INT (op);
+ reg[RRR] = XCHAR_OR_INT (e->value);
reg[7] = 1; /* r7 true for success */
}
else
--
On the quay of the little Black Sea port, where the rescued pair came once
more into contact with civilization, Dobrinton was bitten by a dog which was
assumed to be mad, though it may only have been indiscriminating. (Saki)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[C] xemacsweb: Add and announce http://www.cl.xemacs.org/.
17 years, 5 months
Adrian Aichner
Adrian Aichner
COMMIT
Thank you, pctools.cl, for mirroring us in Chile!
XEmacs team, please take note that pctools.cl cannot provide anonymous
FTP access.
Only http access is available.
That's why I will add the new entries commented-out to package-get.el.
Best regards!
Adrian
xemacsweb ChangeLog patch:
Diff command: cvs -q diff -U 0
Files affected: Releases/ChangeLog Download/win32/ChangeLog Download/ChangeLog ChangeLog
Index: Releases/ChangeLog
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Releases/ChangeLog,v
retrieving revision 1.141
diff -u -U0 -r1.141 ChangeLog
--- Releases/ChangeLog 22 Jun 2007 23:07:16 -0000 1.141
+++ Releases/ChangeLog 25 Jul 2007 17:12:23 -0000
＠＠ -0,0 +1,7 ＠＠
+2007-07-25 Adrian Aichner <adrian(a)xemacs.org>
+
+ * core-beta.txt: Add and announce http://www.cl.xemacs.org/.
+ * core-stable.txt: Ditto.
+ * packages-official.txt: Ditto.
+ * packages-pre-release.txt: Ditto.
+
Index: Download/win32/ChangeLog
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Download/win32/ChangeLog,v
retrieving revision 1.52
diff -u -U0 -r1.52 ChangeLog
--- Download/win32/ChangeLog 22 Jun 2007 23:07:35 -0000 1.52
+++ Download/win32/ChangeLog 25 Jul 2007 17:12:23 -0000
＠＠ -0,0 +1,6 ＠＠
+2007-07-25 Adrian Aichner <adrian(a)xemacs.org>
+
+ * innosetup-win32.txt: Add and announce http://www.cl.xemacs.org/.
+ * installshield-win32.txt: Ditto.
+ * netinstall-win32.txt: Ditto.
+
Index: Download/ChangeLog
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Download/ChangeLog,v
retrieving revision 1.184
diff -u -U0 -r1.184 ChangeLog
--- Download/ChangeLog 25 Jun 2007 20:56:22 -0000 1.184
+++ Download/ChangeLog 25 Jul 2007 17:12:23 -0000
＠＠ -0,0 +1,4 ＠＠
+2007-07-21 Adrian Aichner <adrian(a)xemacs.org>
+
+ * web-mirrors.content: Add and announce http://www.cl.xemacs.org/.
+
Index: ChangeLog
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/ChangeLog,v
retrieving revision 1.266
diff -u -U0 -r1.266 ChangeLog
--- ChangeLog 25 Jun 2007 20:56:05 -0000 1.266
+++ ChangeLog 25 Jul 2007 17:12:24 -0000
＠＠ -0,0 +1,4 ＠＠
+2007-07-21 Adrian Aichner <adrian(a)xemacs.org>
+
+ * index.content: Add and announce http://www.cl.xemacs.org/.
+
xemacsweb source patch:
Diff command: cvs -f -z3 -q diff -u -w -N
Files affected: Releases/packages-pre-release.txt
===================================================================
RCS Releases/packages-official.txt
===================================================================
RCS Releases/core-stable.txt
===================================================================
RCS Releases/core-beta.txt
===================================================================
RCS Download/win32/netinstall-win32.txt
===================================================================
RCS Download/win32/installshield-win32.txt
===================================================================
RCS Download/win32/innosetup-win32.txt
===================================================================
RCS Download/web-mirrors.content
===================================================================
RCS index.content
===================================================================
RCS
Index: index.content
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/index.content,v
retrieving revision 1.175
diff -u -w -r1.175 index.content
--- index.content 25 Jun 2007 20:56:05 -0000 1.175
+++ index.content 25 Jul 2007 17:04:33 -0000
＠＠ -111,6 +111,16 ＠＠
<dl>
<!-- one of (dd dt) -->
+ <dt><strong>2007-07-18</strong></dt>
+ <dd>
+ <p>
+ <a href="http://www.pctools.cl/">pctools.cl</a> starts
+ mirroring the XEmacs Website for our Chilean users at <a
+ href="http://www.cl.xemacs.org/">http://www.cl.xemacs.org/</a>.
+ ¡gracias!
+ </p>
+ </dd>
+ <!-- one of (dd dt) -->
<dt><strong>2007-06-25</strong></dt>
<dd>
<p>
Index: Download/web-mirrors.content
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Download/web-mirrors.content,v
retrieving revision 1.27
diff -u -w -r1.27 web-mirrors.content
--- Download/web-mirrors.content 25 Jun 2007 20:56:22 -0000 1.27
+++ Download/web-mirrors.content 25 Jul 2007 17:04:33 -0000
＠＠ -44,6 +44,11 ＠＠
<li><a href="http://xemacs.xmundo.net/">http://xemacs.xmundo.net/</a></li>
</ul>
</li>
+ <li><h4>Chile</h4>
+ <ul>
+ <li><a href="http://www.cl.xemacs.org/">http://www.cl.xemacs.org/</a></li>
+ </ul>
+ </li>
</ul>
<p></p>
</li>
Index: Download/win32/innosetup-win32.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Download/win32/innosetup-win32.txt,v
retrieving revision 1.6
diff -u -w -r1.6 innosetup-win32.txt
--- Download/win32/innosetup-win32.txt 22 Jun 2007 23:07:35 -0000 1.6
+++ Download/win32/innosetup-win32.txt 25 Jul 2007 17:04:33 -0000
＠＠ -1,5 +1,5 ＠＠
- <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070612) XEmacs Lucid
- at Sat Jun 23 00:17:27 2007 +0200 (W. Europe Daylight Time)
+ <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
+ at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
＠＠ -10,47 +10,48 ＠＠
<p><a href="#index">Goto</a> Index</p>
<ul>
- <li><a href="http://ftp.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs%20... (Main XEmacs Site)</a></li>
- <li><a href="ftp://xemacs.xmundo.net/pub/mirrors/xemacs/binaries/win32/InnoSetup... (xmundo.net)</a></li>
- <li><a href="http://mirror.aarnet.edu.au/pub/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.19.exe">Australia (aarnet.edu.au)</a></li>
- <li><a href="http://ftp.au.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs... (au.xemacs.org)</a></li>
- <li><a href="http://ftp.at.xemacs.org/editors/xemacs/binaries/win32/InnoSetup/XE... (at.xemacs.org)</a></li>
- <li><a href="http://ftp.be.xemacs.org/ftp/xemacs/binaries/win32/InnoSetup/XEmacs... (be.xemacs.org)</a></li>
- <li><a href="ftp://ftp.br.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs%... (br.xemacs.org)</a></li>
- <li><a href="http://ftp.ca.xemacs.org/pub/Mirror/xemacs/binaries/win32/InnoSetup... (ca.xemacs.org)</a></li>
- <li><a href="ftp://ftp.crc.ca/pub/packages/editors/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.19.exe">Canada (crc.ca)</a></li>
- <li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.19.exe">Canada (nrc.ca)</a></li>
- <li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/binaries/... Republic (cz.xemacs.org)</a></li>
- <li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/binaries/win32/InnoSetup/... (dk.xemacs.org)</a></li>
- <li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
- <li><a href="http://ftp.fr.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs... (fr.xemacs.org)</a></li>
- <li><a href="ftp://mirror.cict.fr/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.19.exe">France (mirror.cict.fr)</a></li>
- <li><a href="ftp://ftp.pasteur.fr/pub/computing/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.19.exe">France (pasteur.fr)</a></li>
- <li><a href="http://ftp.de.xemacs.org/pub/ftp.xemacs.org/tux/xemacs/binaries/win... (de.xemacs.org)</a></li>
- <li><a href="http://ftp.gr.xemacs.org/ftp/binaries/win32/InnoSetup/XEmacs%20Setu... (gr.xemacs.org)</a></li>
- <li><a href="http://xemacsftp.hkmirror.org/binaries/win32/InnoSetup/XEmacs%20Set... Kong (hk.xemacs.org)</a></li>
- <li><a href="http://ftp.is.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs... (is.xemacs.org)</a></li>
- <li><a href="http://ftp.ie.xemacs.org/mirrors/ftp.xemacs.org/pub/xemacs/binaries... (ie.xemacs.org)</a></li>
- <li><a href="http://ftp.heanet.ie/mirrors/ftp.xemacs.org/binaries/win32/InnoSetu... (heanet.ie)</a></li>
- <li><a href="http://ftp.it.xemacs.org/binaries/win32/InnoSetup/XEmacs%20Setup%20... (it.xemacs.org)</a></li>
- <li><a href="http://ring.aist.go.jp/pub/text/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.19.exe">Japan (aist.go.jp)</a></li>
- <li><a href="http://ring.asahi-net.or.jp/pub/text/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.19.exe">Japan (asahi-net.or.jp)</a></li>
- <li><a href="http://ftp.dti.ad.jp/pub/unix/editor/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.19.exe">Japan (dti.ad.jp)</a></li>
- <li><a href="http://sunsite.sut.ac.jp/pub/archives/packages/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.19.exe">Japan (sut.ac.jp)</a></li>
- <li><a href="http://ftp.kr.xemacs.org/pub/tools/emacs/xemacs/binaries/win32/Inno... (kr.xemacs.org)</a></li>
- <li><a href="http://ftp.nl.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs... (nl.xemacs.org)</a></li>
+ <li><a href="http://ftp.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs%20... (Main XEmacs Site)</a></li>
+ <li><a href="ftp://xemacs.xmundo.net/pub/mirrors/xemacs/binaries/win32/InnoSetup... (xmundo.net)</a></li>
+ <li><a href="http://mirror.aarnet.edu.au/pub/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.20.exe">Australia (aarnet.edu.au)</a></li>
+ <li><a href="http://ftp.au.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs... (au.xemacs.org)</a></li>
+ <li><a href="http://ftp.at.xemacs.org/editors/xemacs/binaries/win32/InnoSetup/XE... (at.xemacs.org)</a></li>
+ <li><a href="http://ftp.be.xemacs.org/ftp/xemacs/binaries/win32/InnoSetup/XEmacs... (be.xemacs.org)</a></li>
+ <li><a href="ftp://ftp.br.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs%... (br.xemacs.org)</a></li>
+ <li><a href="http://ftp.ca.xemacs.org/pub/Mirror/xemacs/binaries/win32/InnoSetup... (ca.xemacs.org)</a></li>
+ <li><a href="ftp://ftp.crc.ca/pub/packages/editors/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.20.exe">Canada (crc.ca)</a></li>
+ <li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.20.exe">Canada (nrc.ca)</a></li>
+ <li><a href="http://ftp.cl.xemacs.org/binaries/win32/InnoSetup/XEmacs%20Setup%20... (cl.xemacs.org)</a></li>
+ <li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/binaries/... Republic (cz.xemacs.org)</a></li>
+ <li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/binaries/win32/InnoSetup/... (dk.xemacs.org)</a></li>
+ <li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
+ <li><a href="http://ftp.fr.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs... (fr.xemacs.org)</a></li>
+ <li><a href="ftp://mirror.cict.fr/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.20.exe">France (mirror.cict.fr)</a></li>
+ <li><a href="ftp://ftp.pasteur.fr/pub/computing/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.20.exe">France (pasteur.fr)</a></li>
+ <li><a href="http://ftp.de.xemacs.org/pub/ftp.xemacs.org/tux/xemacs/binaries/win... (de.xemacs.org)</a></li>
+ <li><a href="http://ftp.gr.xemacs.org/ftp/binaries/win32/InnoSetup/XEmacs%20Setu... (gr.xemacs.org)</a></li>
+ <li><a href="http://xemacsftp.hkmirror.org/binaries/win32/InnoSetup/XEmacs%20Set... Kong (hk.xemacs.org)</a></li>
+ <li><a href="http://ftp.is.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs... (is.xemacs.org)</a></li>
+ <li><a href="http://ftp.ie.xemacs.org/mirrors/ftp.xemacs.org/pub/xemacs/binaries... (ie.xemacs.org)</a></li>
+ <li><a href="http://ftp.heanet.ie/mirrors/ftp.xemacs.org/binaries/win32/InnoSetu... (heanet.ie)</a></li>
+ <li><a href="http://ftp.it.xemacs.org/binaries/win32/InnoSetup/XEmacs%20Setup%20... (it.xemacs.org)</a></li>
+ <li><a href="http://ring.aist.go.jp/pub/text/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.20.exe">Japan (aist.go.jp)</a></li>
+ <li><a href="http://ring.asahi-net.or.jp/pub/text/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.20.exe">Japan (asahi-net.or.jp)</a></li>
+ <li><a href="http://ftp.dti.ad.jp/pub/unix/editor/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.20.exe">Japan (dti.ad.jp)</a></li>
+ <li><a href="http://sunsite.sut.ac.jp/pub/archives/packages/xemacs/binaries/win32/InnoSetup/XEmacs%20Setup%2021.4.20.exe">Japan (sut.ac.jp)</a></li>
+ <li><a href="http://ftp.kr.xemacs.org/pub/tools/emacs/xemacs/binaries/win32/Inno... (kr.xemacs.org)</a></li>
+ <li><a href="http://ftp.nl.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs... (nl.xemacs.org)</a></li>
<li><a href="ftp://ftp.nz.xemacs.org/mirror/ftp.xemacs.org/packages">New Zealand (nz.xemacs.org)</a></li>
- <li><a href="http://ftp.no.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs... (no.xemacs.org)</a></li>
- <li><a href="http://ftp.pl.xemacs.org/pub/unix/editors/xemacs/binaries/win32/Inn... (pl.xemacs.org)</a></li>
- <li><a href="http://ftp.pt.xemacs.org/binaries/win32/InnoSetup/XEmacs%20Setup%20... (pt.xemacs.org)</a></li>
- <li><a href="ftp://ftp.ru.xemacs.org/pub/emacs/xemacs/binaries/win32/InnoSetup/X... (ru.xemacs.org)</a></li>
- <li><a href="http://ftp.sa.xemacs.org/binaries/win32/InnoSetup/XEmacs%20Setup%20... Arabia (sa.xemacs.org)</a></li>
- <li><a href="http://ftp.se.xemacs.org/pub/gnu/xemacs/binaries/win32/InnoSetup/XE... (se.xemacs.org)</a></li>
- <li><a href="http://ftp.ch.xemacs.org/ftp/mirror/xemacs/binaries/win32/InnoSetup... (ch.xemacs.org)</a></li>
- <li><a href="http://ftp.tw.xemacs.org/Unix/Editors/XEmacs/binaries/win32/InnoSet... (ftp.tw.xemacs.org)</a></li>
- <li><a href="http://ftp.uk.xemacs.org/sites/ftp.xemacs.org/pub/xemacs/binaries/w... (uk.xemacs.org)</a></li>
- <li><a href="http://mirrors.ibiblio.org/pub/mirrors/xemacs/binaries/win32/InnoSe... (ibiblio.org)</a></li>
- <li><a href="ftp://ftp.stealth.net/pub/mirrors/ftp.xemacs.org/pub/xemacs/binarie... (stealth.net)</a></li>
- <li><a href="http://metalab.unc.edu/pub/packages/editors/xemacs/binaries/win32/I... (unc.edu)</a></li>
- <li><a href="http://ftp.us.xemacs.org/ftp/pub/xemacs/binaries/win32/InnoSetup/XE... (us.xemacs.org)</a></li>
+ <li><a href="http://ftp.no.xemacs.org/pub/xemacs/binaries/win32/InnoSetup/XEmacs... (no.xemacs.org)</a></li>
+ <li><a href="http://ftp.pl.xemacs.org/pub/unix/editors/xemacs/binaries/win32/Inn... (pl.xemacs.org)</a></li>
+ <li><a href="http://ftp.pt.xemacs.org/binaries/win32/InnoSetup/XEmacs%20Setup%20... (pt.xemacs.org)</a></li>
+ <li><a href="ftp://ftp.ru.xemacs.org/pub/emacs/xemacs/binaries/win32/InnoSetup/X... (ru.xemacs.org)</a></li>
+ <li><a href="http://ftp.sa.xemacs.org/binaries/win32/InnoSetup/XEmacs%20Setup%20... Arabia (sa.xemacs.org)</a></li>
+ <li><a href="http://ftp.se.xemacs.org/pub/gnu/xemacs/binaries/win32/InnoSetup/XE... (se.xemacs.org)</a></li>
+ <li><a href="http://ftp.ch.xemacs.org/ftp/mirror/xemacs/binaries/win32/InnoSetup... (ch.xemacs.org)</a></li>
+ <li><a href="http://ftp.tw.xemacs.org/Unix/Editors/XEmacs/binaries/win32/InnoSet... (ftp.tw.xemacs.org)</a></li>
+ <li><a href="http://ftp.uk.xemacs.org/sites/ftp.xemacs.org/pub/xemacs/binaries/w... (uk.xemacs.org)</a></li>
+ <li><a href="http://mirrors.ibiblio.org/pub/mirrors/xemacs/binaries/win32/InnoSe... (ibiblio.org)</a></li>
+ <li><a href="ftp://ftp.stealth.net/pub/mirrors/ftp.xemacs.org/pub/xemacs/binarie... (stealth.net)</a></li>
+ <li><a href="http://metalab.unc.edu/pub/packages/editors/xemacs/binaries/win32/I... (unc.edu)</a></li>
+ <li><a href="http://ftp.us.xemacs.org/ftp/pub/xemacs/binaries/win32/InnoSetup/XE... (us.xemacs.org)</a></li>
</ul>
Index: Download/win32/installshield-win32.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Download/win32/installshield-win32.txt,v
retrieving revision 1.5
diff -u -w -r1.5 installshield-win32.txt
--- Download/win32/installshield-win32.txt 22 Jun 2007 23:07:35 -0000 1.5
+++ Download/win32/installshield-win32.txt 25 Jul 2007 17:04:33 -0000
＠＠ -1,5 +1,5 ＠＠
- <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070612) XEmacs Lucid
- at Sat Jun 23 00:17:27 2007 +0200 (W. Europe Daylight Time)
+ <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
+ at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
<a id="InstallShield-Download"
＠＠ -24,6 +24,7 ＠＠
<li><a href="http://ftp.ca.xemacs.org/pub/Mirror/xemacs/binaries/win32/installsh... (ca.xemacs.org)</a></li>
<li><a href="ftp://ftp.crc.ca/pub/packages/editors/xemacs/binaries/win32/installshield/xemacs-21.5.17.exe">Canada (crc.ca)</a></li>
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/binaries/win32/installshield/xemacs-21.5.17.exe">Canada (nrc.ca)</a></li>
+ <li><a href="http://ftp.cl.xemacs.org/binaries/win32/installshield/xemacs-21.5.1... (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/binaries/... Republic (cz.xemacs.org)</a></li>
<li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/binaries/win32/installshi... (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
Index: Download/win32/netinstall-win32.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Download/win32/netinstall-win32.txt,v
retrieving revision 1.5
diff -u -w -r1.5 netinstall-win32.txt
--- Download/win32/netinstall-win32.txt 22 Jun 2007 23:07:35 -0000 1.5
+++ Download/win32/netinstall-win32.txt 25 Jul 2007 17:04:33 -0000
＠＠ -1,5 +1,5 ＠＠
- <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070612) XEmacs Lucid
- at Sat Jun 23 00:17:27 2007 +0200 (W. Europe Daylight Time)
+ <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
+ at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
＠＠ -23,6 +23,7 ＠＠
<li><a href="http://ftp.ca.xemacs.org/pub/Mirror/xemacs/binaries/win32/netinstal... (ca.xemacs.org)</a></li>
<li><a href="ftp://ftp.crc.ca/pub/packages/editors/xemacs/binaries/win32/netinstall/xemacs-i586-pc-win32-21.4.13.tar.gz">Canada (crc.ca)</a></li>
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/binaries/win32/netinstall/xemacs-i586-pc-win32-21.4.13.tar.gz">Canada (nrc.ca)</a></li>
+ <li><a href="http://ftp.cl.xemacs.org/binaries/win32/netinstall/xemacs-i586-pc-w... (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/binaries/... Republic (cz.xemacs.org)</a></li>
<li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/binaries/win32/netinstall... (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
Index: Releases/core-beta.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Releases/core-beta.txt,v
retrieving revision 1.8
diff -u -w -r1.8 core-beta.txt
--- Releases/core-beta.txt 22 Jun 2007 23:07:16 -0000 1.8
+++ Releases/core-beta.txt 25 Jul 2007 17:04:33 -0000
＠＠ -1,5 +1,5 ＠＠
- <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070612) XEmacs Lucid
- at Sat Jun 23 00:17:27 2007 +0200 (W. Europe Daylight Time)
+ <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
+ at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
＠＠ -20,6 +20,7 ＠＠
<li><a href="http://ftp.ca.xemacs.org/pub/Mirror/xemacs/beta">Canada (ca.xemacs.org)</a></li>
<li><a href="ftp://ftp.crc.ca/pub/packages/editors/xemacs/beta">Canada (crc.ca)</a></li>
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/beta">Canada (nrc.ca)</a></li>
+ <li><a href="http://ftp.cl.xemacs.org/beta">Chile (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/xemacs-21... Republic (cz.xemacs.org)</a></li>
<li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/beta">Denmark (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
Index: Releases/core-stable.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Releases/core-stable.txt,v
retrieving revision 1.8
diff -u -w -r1.8 core-stable.txt
--- Releases/core-stable.txt 22 Jun 2007 23:07:16 -0000 1.8
+++ Releases/core-stable.txt 25 Jul 2007 17:04:33 -0000
＠＠ -1,5 +1,5 ＠＠
- <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070612) XEmacs Lucid
- at Sat Jun 23 00:17:27 2007 +0200 (W. Europe Daylight Time)
+ <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
+ at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
＠＠ -20,6 +20,7 ＠＠
<li><a href="http://ftp.ca.xemacs.org/pub/Mirror/xemacs/stable">Canada (ca.xemacs.org)</a></li>
<li><a href="ftp://ftp.crc.ca/pub/packages/editors/xemacs/stable">Canada (crc.ca)</a></li>
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/stable">Canada (nrc.ca)</a></li>
+ <li><a href="http://ftp.cl.xemacs.org/packages">Chile (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/stable">C... Republic (cz.xemacs.org)</a></li>
<li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/stable">Denmark (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
Index: Releases/packages-official.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Releases/packages-official.txt,v
retrieving revision 1.8
diff -u -w -r1.8 packages-official.txt
--- Releases/packages-official.txt 22 Jun 2007 23:07:16 -0000 1.8
+++ Releases/packages-official.txt 25 Jul 2007 17:04:33 -0000
＠＠ -1,5 +1,5 ＠＠
- <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070612) XEmacs Lucid
- at Sat Jun 23 00:17:27 2007 +0200 (W. Europe Daylight Time)
+ <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
+ at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
＠＠ -23,6 +23,7 ＠＠
<li><a href="http://ftp.ca.xemacs.org/pub/Mirror/xemacs/packages">Canada (ca.xemacs.org)</a></li>
<li><a href="ftp://ftp.crc.ca/pub/packages/editors/xemacs/packages">Canada (crc.ca)</a></li>
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/packages">Canada (nrc.ca)</a></li>
+ <li><a href="http://ftp.cl.xemacs.org/packages">Chile (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/packages"... Republic (cz.xemacs.org)</a></li>
<li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/packages">Denmark (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... (fi.xemacs.org)</a></li>
Index: Releases/packages-pre-release.txt
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacsweb/Releases/packages-pre-release.txt,v
retrieving revision 1.8
diff -u -w -r1.8 packages-pre-release.txt
--- Releases/packages-pre-release.txt 22 Jun 2007 23:07:16 -0000 1.8
+++ Releases/packages-pre-release.txt 25 Jul 2007 17:04:33 -0000
＠＠ -1,5 +1,5 ＠＠
- <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070612) XEmacs Lucid
- at Sat Jun 23 00:17:27 2007 +0200 (W. Europe Daylight Time)
+ <!-- Generated by 21.5 (beta28) "fuki" (+CVS-20070629) XEmacs Lucid
+ at Wed Jul 25 18:52:47 2007 +0200 (W. Europe Daylight Time)
by M-x package-get-2-download-sites
available from XEmacs CVS at xemacs-builds/adrian/website -->
＠＠ -23,6 +23,7 ＠＠
<li><a href="http://ftp.ca.xemacs.org/pub/Mirror/xemacs/beta/experimental/packag... Pre-Releases (ca.xemacs.org)</a></li>
<li><a href="ftp://ftp.crc.ca/pub/packages/editors/xemacs/beta/experimental/packages">Canada Pre-Releases (crc.ca)</a></li>
<li><a href="ftp://ftp.nrc.ca/pub/packages/editors/xemacs/beta/experimental/packages">Canada Pre-Releases (nrc.ca)</a></li>
+ <li><a href="http://ftp.cl.xemacs.org/beta/experimental/packages">Chile Pre-Releases (cl.xemacs.org)</a></li>
<li><a href="ftp://ftp.cz.xemacs.org/MIRRORS/ftp.xemacs.org/pub/xemacs/xemacs-21... Republic Pre-Releases (cz.xemacs.org)</a></li>
<li><a href="http://ftp.dk.xemacs.org/pub/emacs/xemacs/beta/experimental/package... Pre-Releases (dk.xemacs.org)</a></li>
<li><a href="http://ftp.fi.xemacs.org/pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/... Pre-Releases (fi.xemacs.org)</a></li>
--
Adrian Aichner
mailto:adrian＠xemacs.org
http://www.xemacs.org/
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[PATCH] Byte-compile initialize-xemacs-paths, emacs-version, emacs-version>=
17 years, 5 months
Aidan Kehoe
Aidan Kehoe
This makes startup a little crisper for me. The list of interpreted
functions generated with
(let (res)
(mapatoms
#'(lambda (sym) (if (and (fboundp sym)
(consp (symbol-function sym))
(eq 'lambda (car (symbol-function sym))))
(push sym res))))
res)
which misses uncompiled macros and custom.el getters and setters, among
others.
lisp/ChangeLog addition:
2007-07-25 Aidan Kehoe <kehoea(a)parhasard.net>
* dumped-lisp.el (preloaded-file-list):
No longer explicitly load version.el; if the constant
initialisation happens at compile time, not dump time, something
is seriously wrong, and byte-compiling emacs
* paths.el (initialize-xemacs-paths): Removed.
* setup-paths.el:
* setup-paths.el (initialize-xemacs-paths): New.
Moved initialize-xemacs-paths to setup-paths.el, in order that it
be byte-compiled.
* update-elc.el (unbytecompiled-lisp-files):
version.el is to be byte-compiled.
* version.el:
Remove information for what(1) that hasn't worked for years.
XEmacs Trunk source patch:
Diff command: cvs -q diff -u
Files affected: lisp/version.el
===================================================================
RCS lisp/update-elc.el
===================================================================
RCS lisp/setup-paths.el
===================================================================
RCS lisp/paths.el
===================================================================
RCS lisp/dumped-lisp.el
===================================================================
RCS
Index: lisp/dumped-lisp.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/dumped-lisp.el,v
retrieving revision 1.63
diff -u -r1.63 dumped-lisp.el
--- lisp/dumped-lisp.el 2007/07/22 22:03:31 1.63
+++ lisp/dumped-lisp.el 2007/07/25 15:10:35
＠＠ -32,8 +32,7 ＠＠
"subr" ; load the most basic Lisp functions
"post-gc"
"replace" ; match-string used in version.el.
-
- "version.el" ; Ignore compiled-by-mistake version.elc
+ "version"
"cl"
"cl-extra"
Index: lisp/paths.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/paths.el,v
retrieving revision 1.6
diff -u -r1.6 paths.el
--- lisp/paths.el 2001/04/12 18:21:34 1.6
+++ lisp/paths.el 2007/07/25 15:10:35
＠＠ -127,137 +127,6 ＠＠
;; at dump time. So we have to do contortions to make sure we don't
;; override values set in site-init.el.
-(defun initialize-xemacs-paths ()
- "Initialize the XEmacs path variables from the environment.
-Called automatically at dump time and run time. Do not call this.
-Will not override settings in site-init.el or site-run.el."
- (let ((l #'(lambda (var value)
- (let ((origsym (intern (concat "paths-el-original-"
- (symbol-name var)))))
- (if (running-temacs-p)
- (progn
- (set var value)
- (set origsym value))
- (and (eq (symbol-value var) (symbol-value origsym))
- (set var value)))))))
- (funcall
- l 'news-inews-program
- (cond ((file-exists-p "/usr/bin/inews") "/usr/bin/inews")
- ((file-exists-p "/usr/local/inews") "/usr/local/inews")
- ((file-exists-p "/usr/local/bin/inews") "/usr/local/bin/inews")
- ((file-exists-p "/usr/lib/news/inews") "/usr/lib/news/inews")
- (t "inews")))
-
- (funcall
- l 'mh-progs
- (cond ((file-directory-p "/usr/bin/mh") "/usr/bin/mh/") ;Ultrix 4.2
- ((file-directory-p "/usr/new/mh") "/usr/new/mh/") ;Ultrix <4.2
- ((file-directory-p "/usr/local/bin/mh") "/usr/local/bin/mh/")
- ((file-directory-p "/usr/local/mh") "/usr/local/mh/")
- (t "/usr/local/bin/")))
-
- (funcall
- l 'mh-libs
- (cond ((file-directory-p "/usr/lib/mh") "/usr/lib/mh/") ;Ultrix 4.2
- ((file-directory-p "/usr/new/lib/mh")
- "/usr/new/lib/mh/") ;Ultrix <4.2
- ((file-directory-p "/usr/local/lib/mh") "/usr/local/lib/mh/")
- (t "/usr/local/bin/mh/")))
-
- (funcall
- l 'rmail-spool-directory
- (cond ((string-match "^[^-]+-[^-]+-sco3.2v4" system-configuration)
- "/usr/spool/mail/")
- ;; On The Bull DPX/2 /usr/spool/mail is used although
- ;; it is usg-unix-v.
- ((string-match "^m68k-bull-sysv3" system-configuration)
- "/usr/spool/mail/")
- ;; SVR4 and recent BSD are said to use this.
- ;; Rather than trying to know precisely which systems use it,
- ;; let's assume this dir is never used for anything else.
- ((file-exists-p "/var/mail")
- "/var/mail/")
- ((memq system-type '(dgux hpux usg-unix-v unisoft-unix rtu irix))
- "/usr/mail/")
- ((memq system-type '(linux))
- "/var/spool/mail/")
- (t "/usr/spool/mail/")))
-
- (funcall
- l 'sendmail-program
- (cond
- ((file-exists-p "/usr/lib/sendmail") "/usr/lib/sendmail")
- ((file-exists-p "/usr/sbin/sendmail") "/usr/sbin/sendmail")
- ((file-exists-p "/usr/ucblib/sendmail") "/usr/ucblib/sendmail")
- (t "fakemail"))) ;In ../etc, to interface to /bin/mail.
-
- (funcall
- l 'remote-shell-program
- (cond
- ;; Some systems use rsh for the remote shell; others use that
- ;; name for the restricted shell and use remsh for the remote
- ;; shell. Let's try to guess based on what we actually find
- ;; out there. The restricted shell is almost certainly in
- ;; /bin or /usr/bin, so it's probably safe to assume that an
- ;; rsh found elsewhere is the remote shell program. The
- ;; converse is not true: /usr/bin/rsh could be either one, so
- ;; check that last.
- ((file-exists-p "/usr/ucb/remsh") "/usr/ucb/remsh")
- ((file-exists-p "/usr/bsd/remsh") "/usr/bsd/remsh")
- ((file-exists-p "/bin/remsh") "/bin/remsh")
- ((file-exists-p "/usr/bin/remsh") "/usr/bin/remsh")
- ((file-exists-p "/usr/local/bin/remsh") "/usr/local/bin/remsh")
- ((file-exists-p "/usr/ucb/rsh") "/usr/ucb/rsh")
- ((file-exists-p "/usr/bsd/rsh") "/usr/bsd/rsh")
- ((file-exists-p "/usr/local/bin/rsh") "/usr/local/bin/rsh")
- ((file-exists-p "/usr/bin/rcmd") "/usr/bin/rcmd")
- ((file-exists-p "/bin/rcmd") "/bin/rcmd")
- ((file-exists-p "/bin/rsh") "/bin/rsh")
- ((file-exists-p "/usr/bin/rsh") "/usr/bin/rsh")
- (t "rsh")))
-
- (funcall
- l 'manual-program
- ;; Solaris 2 has both of these files; prefer /usr/ucb/man
- ;; because the other has nonstandard argument conventions.
- (if (file-exists-p "/usr/ucb/man")
- "/usr/ucb/man" "/usr/bin/man"))
-
- (funcall
- l 'directory-abbrev-alist
- ;; Try to match various conventions for automounter temporary
- ;; mount points. These temporary mount points may go away, so
- ;; it's important that we only try to read files under the
- ;; "advertised" mount point, rather than the temporary one, or it
- ;; will look like files have been deleted on us. Whoever came up
- ;; with this design is clearly a moron of the first order, but
- ;; now we're stuck with it, no doubt until the end of time.
- ;;
- ;; For best results, automounter junk should go near the front of this
- ;; list, and other user translations should come after it.
- ;;
- ;; Our code handles the following empirically observed conventions:
- ;; /net is an actual directory! (some systems are not broken!)
- ;; /net/HOST -> /tmp_mnt/net/HOST (`standard' old Sun automounter)
- ;; /net/HOST -> /tmp_mnt/HOST (BSDI 4.0)
- ;; /net/HOST -> /a/HOST (Freebsd 2.2.x)
- ;; /net/HOST -> /amd/HOST (seen in amd sample config files)
- ;;
- ;; If your system has a different convention, you may have to change this.
- ;; Don't forget to send in a patch!
- (when (file-directory-p "/net")
- (append
- (when (file-directory-p "/tmp_mnt")
- (if (file-directory-p "/tmp_mnt/net")
- '(("\\`/tmp_mnt/net/" . "/net/"))
- '(("\\`/tmp_mnt/" . "/net/"))))
- (when (file-directory-p "/a")
- '(("\\`/a/" . "/net/")))
- (when (file-directory-p "/amd")
- '(("\\`/amd/" . "/net/")))
- )))
-))
-
(if (running-temacs-p)
(initialize-xemacs-paths))
Index: lisp/setup-paths.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/setup-paths.el,v
retrieving revision 1.23
diff -u -r1.23 setup-paths.el
--- lisp/setup-paths.el 2007/02/05 15:19:18 1.23
+++ lisp/setup-paths.el 2007/07/25 15:10:35
＠＠ -336,4 +336,136 ＠＠
(list data-directory)
(packages-find-package-data-path last-package-hierarchies)))
+;; Called from paths.el; in here so it gets byte-compiled.
+(defun initialize-xemacs-paths ()
+ "Initialize the XEmacs path variables from the environment.
+Called automatically at dump time and run time. Do not call this.
+Will not override settings in site-init.el or site-run.el."
+ (let ((l #'(lambda (var value)
+ (let ((origsym (intern (concat "paths-el-original-"
+ (symbol-name var)))))
+ (if (running-temacs-p)
+ (progn
+ (set var value)
+ (set origsym value))
+ (and (eq (symbol-value var) (symbol-value origsym))
+ (set var value)))))))
+ (funcall
+ l 'news-inews-program
+ (cond ((file-exists-p "/usr/bin/inews") "/usr/bin/inews")
+ ((file-exists-p "/usr/local/inews") "/usr/local/inews")
+ ((file-exists-p "/usr/local/bin/inews") "/usr/local/bin/inews")
+ ((file-exists-p "/usr/lib/news/inews") "/usr/lib/news/inews")
+ (t "inews")))
+
+ (funcall
+ l 'mh-progs
+ (cond ((file-directory-p "/usr/bin/mh") "/usr/bin/mh/") ;Ultrix 4.2
+ ((file-directory-p "/usr/new/mh") "/usr/new/mh/") ;Ultrix <4.2
+ ((file-directory-p "/usr/local/bin/mh") "/usr/local/bin/mh/")
+ ((file-directory-p "/usr/local/mh") "/usr/local/mh/")
+ (t "/usr/local/bin/")))
+
+ (funcall
+ l 'mh-libs
+ (cond ((file-directory-p "/usr/lib/mh") "/usr/lib/mh/") ;Ultrix 4.2
+ ((file-directory-p "/usr/new/lib/mh")
+ "/usr/new/lib/mh/") ;Ultrix <4.2
+ ((file-directory-p "/usr/local/lib/mh") "/usr/local/lib/mh/")
+ (t "/usr/local/bin/mh/")))
+
+ (funcall
+ l 'rmail-spool-directory
+ (cond ((string-match "^[^-]+-[^-]+-sco3.2v4" system-configuration)
+ "/usr/spool/mail/")
+ ;; On The Bull DPX/2 /usr/spool/mail is used although
+ ;; it is usg-unix-v.
+ ((string-match "^m68k-bull-sysv3" system-configuration)
+ "/usr/spool/mail/")
+ ;; SVR4 and recent BSD are said to use this.
+ ;; Rather than trying to know precisely which systems use it,
+ ;; let's assume this dir is never used for anything else.
+ ((file-exists-p "/var/mail")
+ "/var/mail/")
+ ((memq system-type '(dgux hpux usg-unix-v unisoft-unix rtu irix))
+ "/usr/mail/")
+ ((memq system-type '(linux))
+ "/var/spool/mail/")
+ (t "/usr/spool/mail/")))
+
+ (funcall
+ l 'sendmail-program
+ (cond
+ ((file-exists-p "/usr/lib/sendmail") "/usr/lib/sendmail")
+ ((file-exists-p "/usr/sbin/sendmail") "/usr/sbin/sendmail")
+ ((file-exists-p "/usr/ucblib/sendmail") "/usr/ucblib/sendmail")
+ (t "fakemail"))) ;In ../etc, to interface to /bin/mail.
+
+ (funcall
+ l 'remote-shell-program
+ (cond
+ ;; Some systems use rsh for the remote shell; others use that
+ ;; name for the restricted shell and use remsh for the remote
+ ;; shell. Let's try to guess based on what we actually find
+ ;; out there. The restricted shell is almost certainly in
+ ;; /bin or /usr/bin, so it's probably safe to assume that an
+ ;; rsh found elsewhere is the remote shell program. The
+ ;; converse is not true: /usr/bin/rsh could be either one, so
+ ;; check that last.
+ ((file-exists-p "/usr/ucb/remsh") "/usr/ucb/remsh")
+ ((file-exists-p "/usr/bsd/remsh") "/usr/bsd/remsh")
+ ((file-exists-p "/bin/remsh") "/bin/remsh")
+ ((file-exists-p "/usr/bin/remsh") "/usr/bin/remsh")
+ ((file-exists-p "/usr/local/bin/remsh") "/usr/local/bin/remsh")
+ ((file-exists-p "/usr/ucb/rsh") "/usr/ucb/rsh")
+ ((file-exists-p "/usr/bsd/rsh") "/usr/bsd/rsh")
+ ((file-exists-p "/usr/local/bin/rsh") "/usr/local/bin/rsh")
+ ((file-exists-p "/usr/bin/rcmd") "/usr/bin/rcmd")
+ ((file-exists-p "/bin/rcmd") "/bin/rcmd")
+ ((file-exists-p "/bin/rsh") "/bin/rsh")
+ ((file-exists-p "/usr/bin/rsh") "/usr/bin/rsh")
+ (t "rsh")))
+
+ (funcall
+ l 'manual-program
+ ;; Solaris 2 has both of these files; prefer /usr/ucb/man
+ ;; because the other has nonstandard argument conventions.
+ (if (file-exists-p "/usr/ucb/man")
+ "/usr/ucb/man" "/usr/bin/man"))
+
+ (funcall
+ l 'directory-abbrev-alist
+ ;; Try to match various conventions for automounter temporary
+ ;; mount points. These temporary mount points may go away, so
+ ;; it's important that we only try to read files under the
+ ;; "advertised" mount point, rather than the temporary one, or it
+ ;; will look like files have been deleted on us. Whoever came up
+ ;; with this design is clearly a moron of the first order, but
+ ;; now we're stuck with it, no doubt until the end of time.
+ ;;
+ ;; For best results, automounter junk should go near the front of this
+ ;; list, and other user translations should come after it.
+ ;;
+ ;; Our code handles the following empirically observed conventions:
+ ;; /net is an actual directory! (some systems are not broken!)
+ ;; /net/HOST -> /tmp_mnt/net/HOST (`standard' old Sun automounter)
+ ;; /net/HOST -> /tmp_mnt/HOST (BSDI 4.0)
+ ;; /net/HOST -> /a/HOST (Freebsd 2.2.x)
+ ;; /net/HOST -> /amd/HOST (seen in amd sample config files)
+ ;;
+ ;; If your system has a different convention, you may have to change this.
+ ;; Don't forget to send in a patch!
+ (when (file-directory-p "/net")
+ (append
+ (when (file-directory-p "/tmp_mnt")
+ (if (file-directory-p "/tmp_mnt/net")
+ '(("\\`/tmp_mnt/net/" . "/net/"))
+ '(("\\`/tmp_mnt/" . "/net/"))))
+ (when (file-directory-p "/a")
+ '(("\\`/a/" . "/net/")))
+ (when (file-directory-p "/amd")
+ '(("\\`/amd/" . "/net/")))
+ )))
+))
+
;;; setup-paths.el ends here
Index: lisp/update-elc.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/update-elc.el,v
retrieving revision 1.36
diff -u -r1.36 update-elc.el
--- lisp/update-elc.el 2006/07/16 12:23:58 1.36
+++ lisp/update-elc.el 2007/07/25 15:10:35
＠＠ -117,8 +117,7 ＠＠
'("paths.el"
"dumped-lisp.el"
"dumped-pkg-lisp.el"
- "raw-process.el"
- "version.el")
+ "raw-process.el")
"Lisp files that should not be byte compiled.
Files in `additional-dump-dependencies' do not need to be listed here.")
Index: lisp/version.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/version.el,v
retrieving revision 1.50
diff -u -r1.50 version.el
--- lisp/version.el 2002/08/28 05:36:32 1.50
+++ lisp/version.el 2007/07/25 15:10:35
＠＠ -129,14 +129,6 ＠＠
;;; We hope that this alias is easier for people to find.
(define-function 'version 'emacs-version)
-;; Put the emacs version number into the `pure[]' array in a form that
-;; `what(1)' can extract from the executable or a core file. We don't
-;; actually need this to be pointed to from lisp; pure objects can't
-;; be GCed.
-(concat "\n＠" "(#)" (emacs-version)
- "\n＠" "(#)" "Configuration: "
- system-configuration "\n")
-
;;Local variables:
;;version-control: never
;;End:
--
On the quay of the little Black Sea port, where the rescued pair came once
more into contact with civilization, Dobrinton was bitten by a dog which was
assumed to be mad, though it may only have been indiscriminating. (Saki)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Re: [Q] Switch the redisplay CCL program to the new syntax for mule-to-unicode
17 years, 5 months
Aidan Kehoe
Aidan Kehoe
Ar an ceathrú lá is fiche de mí Iúil, scríobh Stephen J. Turnbull:
> QUERY
>
> Aidan Kehoe writes:
> >
> > NOTE: This patch has been committed.
> >
> > APPROVE COMMIT
> >
> > mule-packages/mule-base/ChangeLog addition:
> >
> > 2007-07-23 Aidan Kehoe <kehoea(a)parhasard.net>
> >
> > * fsf-compat-unicode.el (eval-when-compile):
> > Switch to the << 7-bits approach for arguments to mule-to-unicode,
> > to better accord with the rest of the CCL calls. Already applied
> > to the C core.
>
> Has this been tested for compatibility with 21.4?
The file compiles under 21.4, but the mule-to-unicode CCL instruction has
never been available there, so it errors at runtime,
And oops, the compiled program literal is outdated too, and I didn’t update
it.
--
On the quay of the little Black Sea port, where the rescued pair came once
more into contact with civilization, Dobrinton was bitten by a dog which was
assumed to be mad, though it may only have been indiscriminating. (Saki)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Switch the redisplay CCL program to the new syntax for mule-to-unicode
17 years, 5 months
Aidan Kehoe
Aidan Kehoe
NOTE: This patch has been committed.
APPROVE COMMIT
mule-packages/mule-base/ChangeLog addition:
2007-07-23 Aidan Kehoe <kehoea(a)parhasard.net>
* fsf-compat-unicode.el (eval-when-compile):
Switch to the << 7-bits approach for arguments to mule-to-unicode,
to better accord with the rest of the CCL calls. Already applied
to the C core.
XEmacs Packages source patch:
Diff command: cvs -q diff -Nu
Files affected: mule-packages/mule-base/fsf-compat-unicode.el
===================================================================
RCS
Index: mule-packages/mule-base/fsf-compat-unicode.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/mule-packages/mule-base/fsf-compat-unicode.el,v
retrieving revision 1.2
diff -u -u -r1.2 fsf-compat-unicode.el
--- mule-packages/mule-base/fsf-compat-unicode.el 2006/12/01 21:27:39 1.2
+++ mule-packages/mule-base/fsf-compat-unicode.el 2007/07/23 21:18:52
＠＠ -55,10 +55,10 ＠＠
(eval
'(define-ccl-program fsf-compat-ccl-encode-to-ucs-2
`(1
- ((r1 = (r1 << 8))
+ ((r1 = (r1 << 7))
(r1 = (r1 | r2))
(mule-to-unicode r0 r1)
- (r1 = (r0 >> 8))
+ (r1 = (r0 >> 7))
(r2 = (r0 & 255))))
"CCL program to transform Mule characters to UCS-2."))
--
On the quay of the little Black Sea port, where the rescued pair came once
more into contact with civilization, Dobrinton was bitten by a dog which was
assumed to be mad, though it may only have been indiscriminating. (Saki)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments