hash table lookup from CCL

[Dave Love]

These changes to Emacs 21.1-ish source add lookup in hash tables to
CCL, somewhat analogously to character translation tables (which only
allow valid character codes as input and output).  Currently the only
way to index sparse tables by arbitrary codes, e.g. unicodes, is with
the complicated map-multiple function.

This allows replacing Mule-UCS for the purpose it's mostly used --
mapping UTF-8 to Emacs characters throughout the BMP, or even outside
it -- by simple changes to utf-8.el.  This is a lot simpler (more
understandable) and can't corrupt unrepresentable characters as
Mule-UCS currently can.  Introducing new 16- and 20-bit charsets is
obviously preferable, but is more involved and not completely
backwards-compatible.

2002-04-01  Dave Love  <address@hidden>

        * international/ccl.el (ccl-command-table): Add lookup-character,
        lookup-integer.
        (ccl-extended-code-table): Add lookup-int-const-tbl,
        lookup-char-const-tbl.
        (ccl-compile-lookup-integer, ccl-compile-lookup-character): New
        function.

        * international/mule.el (define-translation-hash-table): New
        function.

2002-04-01  Dave Love  <address@hidden>

        * ccl.c (Vtranslation_hash_table_vector, GET_HASH_TABLE)
        (HASH_VALUE, CCL_LookupIntConstTbl, CCL_LookupCharConstTbl): New.
        (ccl_driver): Add cases for CCL_LookupIntConstTbl,
        CCL_LookupCharConstTbl.
        (syms_of_ccl): Defvar translation-hash-table-vector.

--- src/ccl.c   2002/03/30 23:00:29     1.1
+++ src/ccl.c   2002/03/31 22:18:54
@@ -65,6 +65,15 @@
    already resolved to index numbers or not.  */
 Lisp_Object Vccl_program_table;
 
+/* Vector of registered hash tables for translation.  */
+Lisp_Object Vtranslation_hash_table_vector;
+
+/* Return a hash table of id number ID.  */
+#define GET_HASH_TABLE(id) \
+  (XHASH_TABLE (XCDR(XVECTOR(Vtranslation_hash_table_vector)->contents[(id)])))
+/* Copied from fns.c.  */
+#define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
+
 /* CCL (Code Conversion Language) is a simple language which has
    operations on one input buffer, one output buffer, and 7 registers.
    The syntax of CCL is described in `ccl.el'.  Emacs Lisp function
@@ -648,6 +657,18 @@
                                          set reg[RRR] to -1.
                                     */
 
+#define CCL_LookupIntConstTbl 0x13 /* Lookup multibyte character by
+                                     integer key.  Afterwards R7 set
+                                     to 1 iff lookup succeeded.
+                                     1:ExtendedCOMMNDRrrRRRXXXXXXXX
+                                     2:ARGUMENT(Hash table ID) */
+
+#define CCL_LookupCharConstTbl 0x14 /* Lookup integer by multibyte
+                                      character key.  Afterwards R7 set
+                                      to 1 iff lookup succeeded.
+                                      1:ExtendedCOMMNDRrrRRRrrrXXXXX
+                                      2:ARGUMENT(Hash table ID) */
+
 /* CCL arithmetic/logical operators. */
 #define CCL_PLUS       0x00    /* X = Y + Z */
 #define CCL_MINUS      0x01    /* X = Y - Z */
@@ -1403,6 +1424,50 @@
              reg[rrr] = i;
              break;
 
+           case CCL_LookupIntConstTbl:
+             op = XINT (ccl_prog[ic]); /* table */
+             ic++;
+             {         
+               struct Lisp_Hash_Table *h = GET_HASH_TABLE (op);
+
+               op = hash_lookup (h, make_number (reg[RRR]), NULL);
+               if (op >= 0)
+                 {
+                   op = HASH_VALUE (h, op);
+                   if (!CHAR_VALID_P (op, 0))
+                     CCL_INVALID_CMD;
+                   SPLIT_CHAR (XINT (op), reg[RRR], i, j);
+                   if (j != -1)
+                     i = (i << 7) | j;
+                   reg[rrr] = i;
+                   reg[7] = 1; /* r7 true for success */
+                 }
+               else
+                 reg[7] = 0;
+             }
+             break;
+
+           case CCL_LookupCharConstTbl:
+             op = XINT (ccl_prog[ic]); /* table */
+             ic++;
+             CCL_MAKE_CHAR (reg[RRR], reg[rrr], i);
+             {         
+               struct Lisp_Hash_Table *h = GET_HASH_TABLE (op);
+
+               op = hash_lookup (h, make_number (i), NULL);
+               if (op >= 0)
+                 {
+                   op = HASH_VALUE (h, op);
+                   if (!INTEGERP (op))
+                     CCL_INVALID_CMD;
+                   reg[RRR] = XINT (op);
+                   reg[7] = 1; /* r7 true for success */
+                 }
+               else
+                 reg[7] = 0;
+             }
+             break;
+
            case CCL_IterateMultipleMap:
              {
                Lisp_Object map, content, attrib, value;
@@ -2334,6 +2399,13 @@
  when the execution terminated.\n\
 If the font is single-byte font, the register R2 is not used.");
   Vfont_ccl_encoder_alist = Qnil;
+
+  DEFVAR_LISP ("translation-hash-table-vector", 
&Vtranslation_hash_table_vector,
+    "Vector containing all translation hash tables ever defined.
+Comprises pairs (SYMBOL . TABLE) where SYMBOL and TABLE were set up by calls
+to `define-translation-hash-table'.  The vector is indexed by the table id
+used by CCL.");
+    Vtranslation_hash_table_vector = Qnil;
 
   defsubr (&Sccl_program_p);
   defsubr (&Sccl_execute);
--- lisp/international/mule.el  2002/03/31 13:46:48     1.1
+++ lisp/international/mule.el  2002/03/31 13:51:29
@@ -1,7 +1,7 @@
 ;;; mule.el --- basic commands for mulitilingual environment
 
 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002 Free Software Foundation, Inc.
 ;; Licensed to the Free Software Foundation.
 
 ;; Keywords: mule, multilingual, character set, coding system
@@ -1719,6 +1719,33 @@
      (unwind-protect
         (progn ,@body)
        (set-category-table current-category-table))))
+
+(defun define-translation-hash-table (symbol table)
+  "Define SYMBOL as the name of the hash translation TABLE for use in CCL.
+
+Analogous to `define-translation-table', but updates
+`translation-hash-table-vector' and the table is for use in the CCL
+`lookup-integer' and `lookup-character' functions."
+  (unless (and (symbolp symbol)
+              (hash-table-p table))
+    (error "Bad args to define-translation-hash-table"))
+  (let ((len (length translation-hash-table-vector))
+       (id 0)
+       done)
+    (put symbol 'translation-hash-table table)
+    (while (not done)
+      (if (>= id len)
+         (setq translation-hash-table-vector
+               (vconcat translation-hash-table-vector [nil])))
+      (let ((slot (aref translation-hash-table-vector id)))
+       (if (or (not slot)
+               (eq (car slot) symbol))
+           (progn
+             (aset translation-hash-table-vector id (cons symbol table))
+             (setq done t))
+         (setq id (1+ id)))))
+    (put symbol 'translation-hash-table-id id)
+    id))
 
 ;;; Initialize some variables.
 
--- lisp/international/ccl.el   2002/03/31 13:21:27     1.1
+++ lisp/international/ccl.el   2002/04/01 10:02:22
@@ -2,6 +2,7 @@
 
 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
 ;; Licensed to the Free Software Foundation.
+;; Copyright (C) 2002 Free Software Foundation, Inc.
 
 ;; Keywords: CCL, mule, multilingual, character set, coding-system
 
@@ -52,7 +53,8 @@
       read read-if read-branch write call end
       read-multibyte-character write-multibyte-character
       translate-character
-      iterate-multiple-map map-multiple map-single]
+      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.
@@ -107,6 +109,8 @@
    iterate-multiple-map
    map-multiple
    map-single
+   lookup-int-const-tbl
+   lookup-char-const-tbl
    ]
   "Vector of CCL extended compiled codes (symbols).")
 
@@ -196,8 +200,8 @@
 
 ;; Embed pair of SYMBOL and PROP where (get SYMBOL PROP) should give
 ;; proper index number for SYMBOL.  PROP should be
-;; `translation-table-id', `code-conversion-map-id', or
-;; `ccl-program-idx'.
+;; `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)))
 
@@ -833,6 +837,46 @@
           (ccl-embed-extended-command 'translate-character rrr RRR Rrr))))
   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)
@@ -905,7 +949,7 @@
       (setq args (cdr args)))))
 
 
-;;; CCL dump staffs
+;;; CCL dump stuff
 
 ;; To avoid byte-compiler warning.
 (defvar ccl-code)
@@ -1271,7 +1315,7 @@
 
 STATEMENT :=
        SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL
-       | TRANSLATE | END
+       | TRANSLATE | MAP | LOOKUP | END
 
 SET := (REG = EXPRESSION)
        | (REG ASSIGNMENT_OPERATOR EXPRESSION)
@@ -1438,6 +1482,10 @@
        (translate-character REG(table) REG(charset) REG(codepoint))
        | (translate-character SYMBOL REG(charset) REG(codepoint))
         ;; SYMBOL must refer to a table defined by `define-translation-table'.
+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))