1. xemacs
  2. mule-ucs

Source

mule-ucs / lisp / tae.el

   1
   2
   3
   4
   5
   6
   7
   8
   9
  10
  11
  12
  13
  14
  15
  16
  17
  18
  19
  20
  21
  22
  23
  24
  25
  26
  27
  28
  29
  30
  31
  32
  33
  34
  35
  36
  37
  38
  39
  40
  41
  42
  43
  44
  45
  46
  47
  48
  49
  50
  51
  52
  53
  54
  55
  56
  57
  58
  59
  60
  61
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186
 187
 188
 189
 190
 191
 192
 193
 194
 195
 196
 197
 198
 199
 200
 201
 202
 203
 204
 205
 206
 207
 208
 209
 210
 211
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
;;; -*- coding: iso-2022-7bit  -*-
;;; tae.el --- Translation And Encoding compiler(TAE:$BL/(B):-)

;; Copyright (C) 1997-2000 Miyashita Hisashi

;; Keywords: mule, multilingual, encoder

;; This file is part of Mule-UCS

;; Mule-UCS 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.

;; Mule-UCS 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 this program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; This module manages Translation And Encodings.
;;; This is main and very important module to Mule-UCS.
;;; TAE is CORE module. But this is VERY insufficient version.

(require 'mucs)
(require 'mucs-type)
(require 'tbl-mg)

;;; TAE control variables

(defvar tae-enable-register-translation t
  "This variable controls whether TAE register translation to package.")

;;; primitive data for translation.

(defun tae-generate-project-table-symbol (val)
  (cond ((numberp val)
	 (intern (format "tae-project-all-to-%d" val)))
	((eq val 'invalid)
	 'tae-project-all-to-invalid)
	((eq val t)
	 'tae-project-all-to-restore)
	((eq val 'identity)
	 'tae-project-all-to-identity)
	((eq val 'lambda)
	 'tae-project-all-to-lambda)
	(t
	 (signal 'wrong-type-argument
		 (list val)))))

(defun tae-generate-special-project-table-symbol (code)
  (if (numberp code)
      (intern (format "tae-project-special-%d-to-identity" code))
    (signal 'wrong-type-argument
	    (list code))))

(defun tae-project-all-table (val)
  (let ((sym (tae-generate-project-table-symbol val)))
    (if (get sym 'code-conversion-map)
	sym
      (register-code-conversion-map
       sym
       (vector t
	       (cond ((eq val 'invalid)
		      mucs-invalid-code)
		     ((eq val 'identity)
		      (mucs-ccl-nop-program))
		     (t
		      val))
	       0 (mucs-max-number)))
      sym)))

(defun tae-project-all-arith-to-lambda ()
  (if (null (get 'tae-project-all-arith-to-lambda
		 'code-conversion-map))
      (register-code-conversion-map
       'tae-project-all-arith-to-lambda
       (vector t 'lambda
	       (mucs-arithmetic-range-lower)
	       (1+ (mucs-arithmetic-range-upper)))))
  'tae-project-all-arith-to-lambda)

(defun tae-force-project-to-lambda ()
  (if (null (get 'tae-force-project-to-lambda
		 'code-conversion-map))
      (register-code-conversion-map
       'tae-force-project-to-lambda
       (vector t 'lambda
	       (mucs-special-code 0)
	       (mucs-max-code))))
  'tae-force-project-to-lambda)

(defun tae-project-special-to-identity-table (code)
  (let ((sym (tae-generate-project-table-symbol code)))
    (if (null (get sym 'code-conversion-map))
	(register-code-conversion-map
	 sym
	 (vector (mucs-special-code code) t)))
    sym))
      

(defun tae-project-all-specials-to-identity-table ()
  (if (null (get 'tae-project-all-special-to-identity
		 'code-conversion-map))
      (register-code-conversion-map
       'tae-project-all-special-to-identity
       (vector t t
	       (mucs-special-code 0)
	       (1+ (mucs-special-code
		    (1- mucs-code-range-specials))))))
  'tae-project-all-special-to-identity)

(defun tae-project-all-to-special-table (code)
  (tae-project-all-table (mucs-special-code code)))

;;; generate unique symbol

(defvar tae-embedded-name-obarry
  (make-vector 37 0))

(defun tae-generate-unique-symbol-for-embed (name type decodep)
  (intern
   (format "%s-%s-%s"
	   (symbol-name name)
	   (symbol-name type)
	   (if decodep
	       "decode"
	     "encode"))
   tae-embedded-name-obarry))

;; table set manager

(defvar tae-translation-table-set-index 1)
(defsubst tae-generate-translation-table-set-name
  (tr-name &optional type decodep index)
    "Return a name of a symbol used to register a table-set,
which is managed by TAE."
    (if (null index)
	(setq index tae-translation-table-set-index
	      tae-translation-table-set-index (1+ index)))
    (format "%s-tts-%s-%s-%d"
	    (symbol-name tr-name)
	    (symbol-name type)
	    (if decodep "decode" "encode")
	    index))

(defvar tae-current-compiling-translation nil)

;;
;;
;; Interface to declare translation
;;
;;  Note about internals:
;;         A declared translation is distinguished by SYMBOL
;;         that is specified by users.
;;         The SYMBOL has the follwing properties.
;;               SYMBOL's VALUE.
;;                    TRANSLATION itself.
;;               tae-translation:
;;                    t(In the future, this property may be
;;                      used to express something.)
;;               tae-reduced-translation-for-encode:
;;                    Reduced translation for encode.
;;               tae-reduced-translation-for-decode:
;;                    Reduced translation for decode.
;;               tae-dynamic-translation:
;;                    If non-nil, TAE assumes this translation
;;                   may be modified after its compilation.
;;                   Concretely, TAE remember the location of
;;                   CCL and TABLE-SET where this translation correspond.
;;                   And then embed the location to compiled result and
;;                   the state of MUCS-CCL, which
;;                   can be refered by the property of 
;;                   `tae-translation-location-and-state'.
;;               tae-products-for-encode:
;;                   Produced TAE messages for encode.
;;               tae-products-for-decode:
;;                   Produced TAE messages for decode.
;;               tae-table-set-for-encode:
;;               tae-table-set-for-decode:
;;                   Generated table-sets.
;;                   Each has an A-list whose key is
;;                   (TYPE . TABLE-SET)

(defvar tae-internal-translation-property
  '(tae-translation
    tae-dynamic-translation
    tae-reduced-translation-for-encode
    tae-reduced-translation-for-decode
    tae-products-for-encode
    tae-products-for-decode
;;
    tae-table-set-for-encode
    tae-table-set-for-decode
;;
    tae-dependent-translations
    tae-dependent-conversions))

(defsubst tae-get-translation-definition (name)
  (symbol-value name))

(defsubst tae-declared-translation-p (name)
  (and (symbolp name)
       (get name 'tae-translation)))

(defsubst tae-translation-dynamic-p (name)
  (get name 'tae-dynamic-translation))

(defun tae-copy-declared-translation (dest src)
  (mapcar
   (lambda (x)
     (put dest x (get src x)))
   tae-internal-translation-property)
  ;;; declared table-set must be copied.
  (let ((table-sets (append (get src 'tae-table-set-for-encode)
			    (get src 'tae-table-set-for-decode)))
	new-table-set-name)
    (while table-sets
      (table-set-add-reference (car table-sets))
      (setq table-sets (cdr table-sets)))))

(defun tae-translation-add-table-set (name table-set type decodep)
  (let* ((sym (if decodep
		  'tae-table-set-for-decode
		'tae-table-set-for-encode))
	 (alist (get name sym))
	 (maybe (assq type alist)))
    (if (cdr maybe)
	(error "Translation %S has already have table-set:%S(TYPE:%S, DECODEP:%S)."
	       name maybe type decodep))
    (if maybe
	(setcdr maybe table-set)
      (put name sym
	   (cons (cons type table-set)
		 alist)))))

(defsubst tae-translation-get-table-set (name type decodep)
  (if decodep
      (cdr (assq type (get name 'tae-table-set-for-decode)))
    (cdr (assq type (get name 'tae-table-set-for-encode)))))

(defun tae-initialize-translation (name)
  (set name nil)

  ;;; Initialize internal properties.
  (mapcar
   (lambda (x)
     (put name x nil))
   tae-internal-translation-property)

  ;;; Remove references to all generated table-sets.
  (mapcar
   (lambda (x)
     (table-set-remove-reference (cdr x)))
   (get name 'tae-table-set-for-encode))
  (mapcar
   (lambda (x)
     (table-set-remove-reference (cdr x)))
   (get name 'tae-table-set-for-decode)))

(defsubst tae-get-translation-produced-products (translation type decodep)
  (cdr (assq type
	     (get translation
		  (if decodep
		      'tae-products-for-decode
		    'tae-products-for-encode)))))

(defun tae-set-translation-produced-products (translation type decodep value)
  (let* ((prop (if decodep
		  'tae-products-for-decode
		'tae-products-for-encode))
	 (slots (get translation prop))
	 (slot (assq type slots)))
    (if slot
	(setcdr slot value))
    (put translation prop 
	 (cons (cons type value)
	       slots))))

;;; registered translation manager

(defun tae-register-translation (name type decodep)
  (if tae-enable-register-translation
      (progn
	(mucs-register-object 'tae-translation name)
	(let* ((n (if decodep 3 2))
	       (slot (mucs-get-registered-slot
		      'tae-translation name))
	       (typelist (nth n slot))
	       (typeslot (assq type typelist)))
	  (if typeslot
	      nil
	    (if (< (length slot) 4)
		(setcdr (nthcdr 1 slot) (list nil nil)))
	    (setcar (nthcdr n slot) (cons (list type nil) typelist)))))))

(defsubst tae-registered-translation-rule-list ()
  (mucs-registered-object-list 'tae-translation))

(defun tae-notify-embedment-product-list (name product-list decodep)
  (let* ((slot (mucs-get-registered-slot 'tae-translation name))
	 (prlist (nth (if decodep 3 2) slot))
	 elem rec)
    (while (setq elem (car product-list))
      (setq rec (assq elem prlist)
	    product-list (cdr product-list))
      (if (null rec)
	  (error "TAE Internal error:%S is not product of %S"
		 elem name))
      (setcar (cdr rec) t)))
  nil)

(defun tae-embedment-required-product-list (name decodep)
  (let* ((slot (mucs-get-registered-slot 'tae-translation name))
	 (prlist (nth (if decodep 3 2) slot))
	 elem result)
;    (message "NAME:%S PL:%S" name prlist)
    (while (setq elem (car prlist))
      (if (not (nth 1 elem))
	  (setq result (cons (car elem) result)))
      (setq prlist (cdr prlist)))
    result))

(defun tae-register-dependent-translation (dep-name)
  (let ((trlist (get tae-current-compiling-translation
		     'tae-dependent-translations)))
    (if (not (memq dep-name trlist))
	(put tae-current-compiling-translation
	     'tae-dependent-translations
	     (cons dep-name trlist)))))

(defun tae-get-dependent-translations (name)
  (let ((dealing (list name))
	dealt)
    (while (setq name (car dealing))

      (or (memq name dealt)
	  (setq dealt (cons name dealt)))
      (setq dealing (append (get name 'tae-dependent-translations)
			    (cdr dealing))))
    dealt))

(defun tae-register-conversion (name type decodep conversion)
  (let ((trlist (tae-get-dependent-translations name))
	marksym
	slot
	convlist
	cur)
;    (message "MS:%S->%S" marksym trlist)
    (while (setq cur (car trlist))
      (setq convlist (get cur 'tae-dependent-conversions)
	    trlist (cdr trlist))
;      (message "TR:%S NM:%S CONV:%S" cur name conversion)
      (setq marksym (tae-generate-unique-symbol-for-embed
		     name type decodep))
      (if (not (and (setq slot (assq conversion convlist))
		    (eq marksym (nth 1 slot))))
	  (put cur 'tae-dependent-conversions
	       (cons (list conversion name marksym type decodep)
		     convlist))))))

;;; translation declaration.

(defun tae-declare-translation (name translation &optional holdp dynamicp)
  "Declare translation.
NAME must be a symbol to distinguish TRANSLATION.
If HOLDP is non-nil, the declared translation is not initialized on
already produced products and others.
If DYNAMICP is non-nil, this translation can be modified
after its compilation."
  (if (not (symbolp name))
      (error "NAME:%S must be a symbol!" name))

  (if (tae-declared-translation-p translation)
      (tae-copy-declared-translation name translation)
    (if (not holdp)
	(tae-initialize-translation name))
    (set name translation)
    (put name 'tae-translation t)
    (if dynamicp
	(put name 'tae-dynamic-translation t))))

;;; Translation rule syntax
;;;
;;; TR-ELEM := (`assoc' TYPE-SPEC A-LIST [OPTION-ALIST])
;;;            | (`range' TYPE-SPEC RANGE-A-LIST [OPTION-ALIST]) 
;;;            | (`ccl' TYPE-SPEC CCL_Program [OPTION-ALIST])
;;; Notice that `ccl' TR-ELEM does not work currently.
;;;
;;; If type of TR-ELEM is A-LIST or CCL program,
;;;  this TR-ELEM is called PRECOMPILED.
;;;
;;; RANGE-A-LIST := (RANGE-A-LIST-ELEMENT ...)
;;; RANGE-A-LIST-ELEMENT := (RANGE . RANGE) | (RANGE . OBJECT) | (OBJECT . RANGE)
;;; DEF-RANGE, VAL-RANGE := RANGE
;;; TYPE-SPEC := (CAR-TYPE . CDR-TYPE)
;;; RANGE := ((OBJECT-MIN . OBJECT-MAX) ...)
;;; A-LIST := ((OBJECT . OBJECT) ...)
;;; OBJECT_MIN, OBJECT_MAX := OBJECT
;;;
;;; TYPE := registered type (see mucs-types.el)
;;; OBJECT := Lisp Object
;;;  (that must be valid in terms of the specified TYPE) (see mucs-types.el)
;;;
;;;
;;; TRANSLATION := TRANSLATION-ELEMENT  |
;;;                DECLARED-TRANSLATION |
;;;                (OP TRANSLATION [...TRANSLATION] ) |
;;;                (FOP TRANSLATION TRANSLATION)
;;;
;;; DECLARED-TRANSLATION := SYMBOL (see `tae-declare-translation')
;;;
;;; OP := `&' | `|' | `c'
;;; FOP := `ct' | `f' | `ff'
;;; TAG := symbol

;;;;;;   A-LIST note.
;;;;;;
;;;;;;     A-LIST is an association list to describe connections between
;;;;;;   mainly OBJECT and OBJECT.
;;;;;;   For example, an A-LIST, ((A1 . A2) (B1 . B2) ... (Z1 . Z2)),
;;;;;;   means correspondences between A1 and A2, B1 and B2, and so on.
;;;;;;   The element of A-LIST is a cons cell.
;;;;;;     In encoding, TAE regard it as car element to cdr element
;;;;;;   translation, and in decoding, regard it as cdr to car translation.
;;;;;;   Threfore, in above example, TAE translates A1 to A2 in encoding,
;;;;;;   and translates A2 to A1 in decoding.
;;;
;;;;;;     In a special case, an element of A-LIST can have 'all(SYMBOL)
;;;;;;   that matches anything.  For example, an A-LIST, ((1 . 5) (all . 10))
;;;;;;   directs to translate 1 to 5, and any other number to 10 in encoding.
;;;;;;   In decoding, TAE ignores the (all . 10) element, because it is
;;;;;;   impossible to translate a number to everything.
;;;;;;     And, in another special case, it can also have 'invalid(SYMBOL)
;;;;;;   that matches nothing and if a translated result is invalid, it
;;;;;;   ceases any further translation, and make the CCL state invalid.

;;;;;;   RANGE-A-LIST note.
;;;;;;     RANGE-A-LIST is NOT an association list in the normal meanings
;;;;;;   of Lisp.  


(defmacro tae-get-tr-elem-type (tr-elem-zzz)
  (list 'car tr-elem-zzz))

(defmacro tae-tr-elem-assoc-p (tr-elem-zzz)
  (list 'eq (list 'car-safe tr-elem-zzz)
	''assoc))

(defmacro tae-tr-elem-ccl-p (tr-elem-zzz)
  (list 'eq (list 'car-safe tr-elem-zzz)
	''ccl))

(defmacro tae-tr-elem-range-p (tr-elem-zzz)
  (list 'eq (list 'car-safe tr-elem-zzz)
	''range))

(defmacro tae-tr-elem-p (tr-elem-zzz)
  (list 'memq (list 'car-safe tr-elem-zzz)
	''(assoc range ccl)))

(defsubst tae-get-tr-elem-type-spec (tr-elem)
  (nth 1 tr-elem))

(defsubst tae-get-tr-elem-assoc (tr-elem)
  (nth 2 tr-elem))

(defsubst tae-set-tr-elem-assoc (tr-elem assoc)
  (setcar (nthcdr 2 tr-elem) assoc))

(defsubst tae-get-tr-elem-ccl (tr-elem)
  (nth 2 tr-elem))

(defsubst tae-get-tr-elem-range-alist (tr-elem)
  (nth 2 tr-elem))

;(defsubst tae-get-tr-elem-range (tr-elem)
;  (if (tae-tr-elem-elisp-p tr-elem)
;      (nth 3 tr-elem)
;    (error "This translation element:%S have no RANGE."
;	   tr-elem)))

(defsubst tae-get-tr-elem-option-alist (tr-elem)
   (cond ((tae-tr-elem-assoc-p tr-elem)
	  (nth 3 tr-elem))
	 ((tae-tr-elem-range-p tr-elem)
	  (nth 3 tr-elem))
	 ((tae-tr-elem-ccl-p tr-elem)
	  (nth 3 tr-elem))
	 (t
	  nil)))

(defsubst tae-set-tr-elem-option-alist (tr-elem alist)
  (let (slot)
    (cond ((tae-tr-elem-assoc-p tr-elem)
	   (setq slot (nthcdr 3 tr-elem)))
	  ((tae-tr-elem-range-p tr-elem)
	   (setq slot (nthcdr 3 tr-elem)))
	  ((tae-tr-elem-ccl-p tr-elem)
	   (setq slot (nthcdr 3 tr-elem))))
    (if slot
	(setcar slot alist)
      (setq tr-elem (nconc tr-elem (list alist)))))
  tr-elem)

(defsubst tae-assq-tr-elem-option-alist (tr-elem key)
  (assq key (tae-get-tr-elem-option-alist tr-elem)))

(defsubst tae-delq-tr-elem-option-alist (tr-elem key)
  (let ((alist (tae-get-tr-elem-option-alist tr-elem)))
    (tae-set-tr-elem-option-alist
     tr-elem
     (delq (assq key alist) alist))))

(defsubst tae-put-tr-elem-option-alist (tr-elem key value)
  (let* ((alist (tae-get-tr-elem-option-alist tr-elem))
	 (slot (assq key alist)))
    (if slot
	(setcdr slot value)
      (setq alist (cons (cons key value) alist))
      (tae-set-tr-elem-option-alist tr-elem alist))
    slot))

(defsubst tae-tr-elem-set-normalized-flag (tr-elem decodep &optional resetp)
  (tae-put-tr-elem-option-alist
   tr-elem
   'normalized (and (not resetp)
		    (if decodep
			'decode
		      'encode))))

(defsubst tae-tr-elem-normalized-p (tr-elem decodep)
  (eq (cdr (tae-assq-tr-elem-option-alist tr-elem 'normalized))
      (if decodep
	  'decode
	'encode)))

(defsubst tae-get-tr-elem-all-key (tr-elem)
  (cdr (tae-assq-tr-elem-option-alist tr-elem 'all)))

(defsubst tae-set-tr-elem-all-key (tr-elem value)
  (tae-put-tr-elem-option-alist tr-elem 'all value))

(defsubst tae-tr-elem-not-inverse-p (tr-elem)
  (cdr (tae-assq-tr-elem-option-alist tr-elem 'not-inverse)))

(defun tae-tr-elem-inverse-p (tr-elem decodep)
  (and decodep
       (if (tae-tr-elem-not-inverse-p tr-elem)
	   (let ((slot (tae-get-tr-elem-type-spec tr-elem)))
	     (if (eq (car slot) (cdr slot))
		 nil
	       (error "not-inverse option flag is valid only if both of the specified types is identical.")))
	 t)))
  
(defun tae-check-and-normalize-range (range-list)
  (let (reduced-range
    	max-rl
	max-re
	min-rl
	min-re)
    (mapcar
     (lambda (x)
       (if (numberp x) (setq x (cons x x))
	 (if (not (and (numberp (car x))
		       (numberp (cdr x))
		       (>= (cdr x) (car x))))
	     (error "Invalid range!:%S" x)))

       (setq  min-re (car reduced-range)
	      min-rl (cons nil reduced-range))
       (while 
	   (if (null min-re)
	       (progn
		 (setq reduced-range
		       (nconc reduced-range
			      (list x)))
		 nil)
	     (if (<= (car x) (1+ (cdr min-re)))
		 (progn

		   ;; (message "%S: (%S-->)" x min-re)

		   (setq  max-re min-re
			  max-rl min-rl)
		   (while
		       (and (> (1+ (cdr x)) (cdr max-re))
			    (setq max-rl (cdr max-rl)
				  max-re (car (cdr max-rl)))))

		   ;;; fix up list
		   ;;; (message "%S: (%S<->%S)" x min-re max-re)

		   (if (< (car x) (car min-re))
		       (setcar min-re (car x)))
		   (if (> (cdr x) (cdr min-re))
		       (setcdr min-re (cdr x)))
		   (if (and max-re
			    (<= (car max-re)(cdr min-re)))
		       (progn
			 (setcdr min-re (cdr max-re))
			 (setq max-rl (cdr max-rl))))
		   (setcdr (cdr min-rl) (cdr max-rl))

		   nil)
	       (setq min-rl (cdr min-rl)
		     min-re (car (cdr min-rl)))
	       t))))
     range-list)
;;    (mapcar
;;     (lambda (x)
;;       (if (eq (car x) (cdr x))
;;	   (car x)
;;	 x))
;;     reduced-range)
    reduced-range
    ))

(defun tae-normalize-translation (tr-elem decodep)
  "Normalized TR.
TR-ELEM, the translation element, are reduced to
ASSOC or CCL program. 
But, we have not be able to reduce
Emacs Lisp Function to CCL program yet.
And then, if the translation-element is ASSOC, sort it.

When decodep is non-nil, normalize for decording."
  (setq tr-elem (copy-sequence tr-elem))
  (cond ((tae-tr-elem-assoc-p tr-elem)
	 (let ((curll (tae-get-tr-elem-assoc tr-elem))
	       key-type relative-op
	       curel alist-copy all-slot)
	   
	   ;;; copy alist and remove 'all and invalid slot.
	   (if (tae-tr-elem-inverse-p tr-elem decodep)
	       (progn
		 (setq key-type (cdr (tae-get-tr-elem-type-spec tr-elem))
		       relative-op (mucs-type-get-relative-op key-type))
		 (while 
		     (and (setq curel (car curll))
			  (cond ((eq (cdr curel) 'all)
				 (setq all-slot (cons (cdr curel)
						      (car curel)))
				 nil)
				;; skip the slot
				((or (eq (car curel) 'all)
				     (eq (cdr curel) 'invalid))
				 (setq curll (cdr curll)))
				(t
				 (setq alist-copy (cons (cons (cdr curel)
							      (car curel))
							alist-copy))
				 (setq curll (cdr curll)))))))
	     (setq key-type (cdr (tae-get-tr-elem-type-spec tr-elem))
		   relative-op (mucs-type-get-relative-op key-type))
	     (while 
		 (and (setq curel (car curll))
		      (cond ((eq (car curel) 'all)
			     (setq all-slot curel)
			     nil)
			    ;; skip the slot
			    ((or (eq (cdr curel) 'all)
				 (eq (car curel) 'invalid))
			     (setq curll (cdr curll)))
			    (t
			     (setq alist-copy (cons (cons (car curel)
							  (cdr curel))
						    alist-copy))
			     (setq curll (cdr curll)))))))

	   (tae-set-tr-elem-assoc
	    tr-elem
	    (nconc
	     (sort alist-copy
		   (lambda (x y) (funcall relative-op
					  (car x) (car y))))))
	   (if all-slot
	       (tae-set-tr-elem-all-key tr-elem
					(cdr all-slot)))))

	((tae-tr-elem-range-p tr-elem)
	 (let ((alist (tae-get-tr-elem-range-alist tr-elem))
	       range-elem i j
	       newalist)
	   ;;; We should implement normalization processes on range tr-elem.
	   ))

	((tae-tr-elem-ccl-p tr-elem)
	 ))
  (tae-tr-elem-set-normalized-flag tr-elem decodep)
  tr-elem)

(defun tae-reduce-OR-translations (tr-elems decodep)
  "Reduce `OR' translations.
TR-ELEMS must be a list that consists of TR-ELEMs
that must be normalized.
When DECODEP is t, reduce for decodeing translation."
  (let ((tr1 (car tr-elems))
	(tr2 (nth 1 tr-elems))
	(tr-curl (cdr tr-elems))
	result-list result tmp)
    (while (and tr2
		(not (tae-get-tr-elem-all-key tr1)))
      (setq result
	    (cond ((and (tae-tr-elem-assoc-p tr1)
			(tae-tr-elem-assoc-p tr2))
		   (let* ((alist1 (tae-get-tr-elem-assoc tr1))
			  (alist2 (tae-get-tr-elem-assoc tr2))
			  (cur-ll2 alist2)
			  (type-spec (tae-get-tr-elem-type-spec tr1))
			  (key-type (if decodep (cdr type-spec)
				      (car type-spec)))
			  (relative-op (mucs-type-get-relative-op key-type))
			  (equal-op (mucs-type-get-equal-op key-type))
			  cur-ll1 cur-el1 cur-el2 result)
		     (setq cur-el1 (car alist1)
			   cur-ll1 (cons nil alist1))
		     (while (setq cur-el2 (car cur-ll2))
		       (while 
			   (progn
			     (cond ((funcall relative-op
					     (car cur-el2)
					     (car cur-el1))
				    (if (null (car cur-ll1))
					(setq alist1
					      (cons cur-el2
						    alist1))
				      (setcdr cur-ll1
					      (cons cur-el2
						    (cdr cur-ll1))))
				    nil)
				   ((funcall equal-op
					     (car cur-el1)
					     (car cur-el2))
				    nil)
				   (t
				    (setq cur-ll1 (cdr cur-ll1))
				    (if (setq cur-el1 (car (cdr cur-ll1)))
					t
				      (setq alist1 (nconc alist1
							  cur-ll2)
					    cur-ll2 nil)
				      nil)))))
		       (setq cur-ll2 (cdr cur-ll2)))
		     ;; making assoc tr-elem
		     (setq result
			   (list 'assoc
				 ;; TYPE spec
				 (tae-get-tr-elem-type-spec tr1)
				 ;; Association
				 alist1))

		     ;; set all key
		     (tae-set-tr-elem-all-key
		      result
		      (tae-get-tr-elem-all-key tr2))

		     result))

		  ((or (and (tae-tr-elem-assoc-p tr1)
			    (tae-tr-elem-range-p tr2))
		       (and (tae-tr-elem-assoc-p tr2)
			    (tae-tr-elem-range-p tr1)
			    (setq tmp tr2
				  tr2 tr1
				  tr1 tmp)))
		   ;; tr1 ... assoc tr element
		   ;; tr2 ... range tr element
		   nil)

		  ((and (tae-tr-elem-range-p tr1)
			(tae-tr-elem-range-p tr2))
		   ;; tr1, tr2 ... range tr elements
		   nil)

		  ((or (or (tae-tr-elem-ccl-p tr1)
			   (tae-tr-elem-range-p tr1))
		       (or (tae-tr-elem-ccl-p tr2)
			   (tae-tr-elem-range-p tr2)))
		   nil)
		  ((or (tae-declared-translation-p tr1)
		       (tae-declared-translation-p tr2))
		   nil)
		  (t
		   (error "Unknown translations:%S, %S" tr1 tr2))
		  ))
      (if result
	  (progn
	    (tae-tr-elem-set-normalized-flag result decodep)
	    (setq tr1 result))
	(setq result-list (cons tr1 result-list)
	      tr1 tr2))
      (setq tr-curl (cdr tr-curl)
	    tr2 (car tr-curl)))
    (setq result-list (cons tr1 result-list))
    (nreverse result-list)))

(defun tae-reduce-AND-translations (tr-elems decodep)
  "Reduce `AND' translations.
TR-ELEMS must be a list that consists of TR-ELEMs
that must be normalized.
When DECODEP is t, reduce for decodeing translation."
  (let ((tr1 (car tr-elems))
	(tr2 (nth 1 tr-elems))
	(tr-curl (cdr tr-elems))
	result-list result)
    (while tr2
      (if (tae-get-tr-elem-all-key tr2)
	  (setq result tr1)
	(setq result
	      (cond ((and (tae-tr-elem-assoc-p tr1)
			  (tae-tr-elem-assoc-p tr2))
		     (tae-set-tr-elem-all-key tr1 nil)
		     (let* (result-alist
			    (alist1 (tae-get-tr-elem-assoc tr1))
			    (alist2 (tae-get-tr-elem-assoc tr2))
			    (cur-ll2 alist2)
			    (type-spec (tae-get-tr-elem-type-spec tr1))
			    (key-type (if decodep (cdr type-spec)
					(car type-spec)))
			    (relative-op (mucs-type-get-relative-op key-type))
			    (equal-op (mucs-type-get-equal-op key-type))
			    cur-ll1 cur-el1 cur-el2)
		       (while (setq cur-el2 (car cur-ll2))
			 (setq cur-el1 (car alist1)
			       cur-ll1 (cons nil alist1))
			 (while 
			     (progn
			       (cond ((funcall equal-op
					       (car cur-el1)
					       (car cur-el2))
				      (setq result-alist
					    (cons cur-el2 result-alist))
				      nil)
				     (t
				      (setq cur-ll1 (cdr cur-ll1)
					    cur-el1 (car (cdr cur-ll1)))
				      ))))
			 (setq cur-ll2 (cdr cur-ll2)))
		       (list 'assoc
			     (tae-get-tr-elem-type-spec tr1)
			     result-alist)))
		    ((or (or (tae-tr-elem-ccl-p tr1)
			     (tae-tr-elem-range-p tr1))
			 (or (tae-tr-elem-ccl-p tr2)
			     (tae-tr-elem-range-p tr2)))
		     nil)
		    ((or (tae-declared-translation-p tr1)
			 (tae-declared-translation-p tr2))
		     nil)
		    (t
		     (error "Unknown translations:%S, %S" tr1 tr2))
		    )))
      (if result
	  (progn
	    (tae-tr-elem-set-normalized-flag result decodep)
	    (setq tr1 result))
	(setq result-list (cons tr1 result-list)
	      tr1 tr2))
      (setq tr-curl (cdr tr-curl)
	    tr2 (car tr-curl)))
    (setq result-list (cons tr1 result-list))
    (nreverse result-list)))

(defun tae-reduce-composite-translations (tr-elems decodep)
  "Reduce `composite' translations.
TR-ELEMS must be a list that consists of TR-ELEMs
that must be normalized.
When DECODEP is t, reduce for decodeing translation."
  (let* ((trs (if decodep (reverse tr-elems) tr-elems))
	 (tr1 (car trs))
	 (tr2 (nth 1 trs))
	 (tr-curl (cdr trs))
	 tr1-all-key
	 tr2-all-key
	 result-list result)
    (while tr2
      (setq tr1-all-key (tae-get-tr-elem-all-key tr1)
	    tr2-all-key (tae-get-tr-elem-all-key tr2))
      (setq result
	    (cond ((and (tae-tr-elem-assoc-p tr1)
			(tae-tr-elem-assoc-p tr2))
		   (let* (result-alist
			  (alist1 (tae-get-tr-elem-assoc tr1))
			  (alist2 (tae-get-tr-elem-assoc tr2))
			  (cur-ll2 alist2)
			  (type-spec (tae-get-tr-elem-type-spec tr1))
			  (key-type (if decodep (cdr type-spec)
				      (car type-spec)))
			  (relative-op (mucs-type-get-relative-op key-type))
			  (equal-op (mucs-type-get-equal-op key-type))
			  cur-ll1 cur-el1 cur-el2
			  tr-new-all-key)
		     (while (setq cur-el2 (car cur-ll2))
		       (setq cur-el1 (car alist1)
			     cur-ll1 (cons nil alist1))
		       (while 
			   (progn
			     (cond ((funcall equal-op
					     (cdr cur-el1)
					     (car cur-el2))
				    (setq result-alist
					  (cons
					   (cons (car cur-el1)
						 (cdr cur-el2))
						result-alist))
				    ;; remove the slot that is never used.
				    (if (null (car cur-ll1))
					(setq alist1 (cdr alist1))
				      (setcdr cur-ll1 (cdr cur-ll1)))

				    nil)

				   (t
				    (setq cur-ll1 (cdr cur-ll1)
					  cur-el1 (car (cdr cur-ll1))))
				   )))

		       (if tr1-all-key
			   (if (and (null tr-new-all-key)
				    (funcall equal-op
					     tr1-all-key
					     (car cur-el2)))
			       (setq tr-new-all-key (cdr cur-el2))))
		       (setq cur-ll2 (cdr cur-ll2)))

		     ;; operate tr2-all-key
		     (if tr2-all-key
		     ;;; At encoding, append the rest of alist1.
			 (progn
			   (setq cur-ll1 alist1)
			   (while cur-ll1
			     (setq result-alist
				   (cons
				    (cons (car (car cur-ll1))
					  tr2-all-key)
				    result-alist)
				   cur-ll1 (cdr cur-ll1)))
			   (if (null tr-new-all-key)
			       (setq tr-new-all-key
				     tr2-all-key))))

		     (list 'assoc 
			   (tae-get-tr-elem-type-spec tr1)
			   result-alist
			   (list (cons 'all tr-new-all-key)))
		     ))
		  ((or (or (tae-tr-elem-ccl-p tr1)
			   (tae-tr-elem-range-p tr1))
		       (or (tae-tr-elem-ccl-p tr2)
			   (tae-tr-elem-range-p tr2)))
		   nil)
		  ((or (tae-declared-translation-p tr1)
		       (tae-declared-translation-p tr2))
		   nil)
		  (t
		   (error "Unknown translations:%S, %S" tr1 tr2))
		  ))
      (if result
	  (setq tr1 (tae-normalize-translation result decodep))
	;;; unreduced
	(setq result-list (cons tr1 result-list)
	      tr1 tr2))
      (setq tr-curl (cdr tr-curl)
	    tr2 (car tr-curl)))
    (setq result-list (cons tr1 result-list))
    (nreverse result-list)))

(defun tae-reduce-composite-transparent-translations (tr-elems decodep)
  "Reduce `composite' translations.
TR-ELEMS must be a list that consists of two TR-ELEMs
that must be normalized.
When DECODEP is t, reduce for decodeing translation."
  (if (/= (length tr-elems) 2)
      (error "Composite Transparent requires two arguments:%S"
	     tr-elems))
  (let ((copied (copy-sequence (car tr-elems))))
    (setq tr-elems
	  (tae-reduce-composite-translations tr-elems decodep))
    (setq tr-elems (mapcar
		    (lambda (x)
		      (if (tae-tr-elem-normalized-p x decodep)
			  x
			(tae-normalize-translation x decodep)))
		    tr-elems))
    (tae-reduce-OR-translations
     (nconc tr-elems (list copied)) decodep)))

;;
;;
;;

(defun tae-normalize-reduction-unit (unit &optional decodep)
  "Destructively, normalize reduction unit.
This function checks type-spec of UNIT, and
according to it, rearrange the elements of UNIT."
  (let ((cur-ll unit)
	cur-el)
  (while (setq cur-el (car cur-ll))
    (if (tae-tr-elem-p cur-el)
	(if (tae-tr-elem-normalized-p cur-el decodep)
	    nil
	  (setcar cur-ll (tae-normalize-translation cur-el decodep)))
      (setcar cur-ll (tae-reduce-translation-internal cur-el decodep)))
    (setq cur-ll (cdr cur-ll))))
  unit)

(defun tae-reduce-translation-internal (translation &optional decodep)
  (cond ((tae-declared-translation-p translation)
	 translation)
	((tae-tr-elem-p translation)
	 (or (tae-tr-elem-normalized-p translation decodep)
	     (setq translation
		   (tae-normalize-translation translation decodep)))
	 translation)
	(t
	 (let ((op (car translation))
	       (args (copy-sequence (cdr translation))))
	   (cond ((eq op '|)
		  (setq args (tae-normalize-reduction-unit args decodep))
		  (setq args (tae-reduce-OR-translations args decodep))
		  (if (= (length args) 1)
		      (car args)
		    (cons '| args)))
		 ((eq op '&)
		  (setq args (tae-normalize-reduction-unit args decodep))
		  (setq args (tae-reduce-AND-translations args decodep))
		  (if (= (length args) 1)
		      (car args)
		    (cons '& args)))
		 ((eq op 'c)
		  (setq args (tae-normalize-reduction-unit args decodep))
		  (setq args 
			(tae-normalize-reduction-unit
			 (tae-reduce-composite-translations args decodep)
			 decodep))
		  (if (= (length args) 1)
		      (car args)
		    (cons 'c args)))
; 		 ((eq op 'ct)
; 		  (setq args (tae-normalize-reduction-unit args decodep))
; 		  (setq args 
; 			(tae-normalize-reduction-unit
; 			 (tae-reduce-composite-transparent-translations
; 			  args decodep)
; 			 decodep))
; 		  (if (= (length args) 1)
; 		      (car args)
; 		    (cons 'ct args)))
		 (t
		  (error "TAE have not supported OP:`%S' yet!!" op)))))))

(defsubst tae-reduce-translation (name &optional decodep)
  "Reduce translation."
  (let ((sym (if decodep
		 'tae-reduced-translation-for-decode
	       'tae-reduced-translation-for-encode)))
    (or (get name sym)
	(put name sym
	     (tae-reduce-translation-internal
	      (symbol-value name)
	      decodep)))))

;; TAE message
;;   Not yet fixed :-P.
;;       ((tables . ...) ...???)

;; currently, nested table only --> table-set

;;
;; Produce MYO from translation rule.
;;

(defsubst tae-message-append (mes1 mes2)
  (let ((alist1 mes1)
	(alist2 mes2)
	elem1 elem2)
    (while (setq elem1 (car alist1))
      (setq elem2 (assq (car elem1) alist2)
	    alist1 (cdr alist1))
      (if elem2
	  (progn
	    (setq alist2 (delq elem2 alist2))
	    (if (memq (car elem1) '(new-type))     ;;;; non merged key list.
		(setcdr elem1 (cdr elem2))
	      (nconc elem1 (cdr elem2))
	      ))))
    (nconc mes1 alist2)))

(defsubst tae-message-add (message key data)
  (nconc (assq key message) (list data))
  message)

(defsubst tae-message-get (message key)
  (cdr (assq key message)))

(defsubst tae-message-put (message key value)
  (setcdr (assq key message) value))

(defsubst tae-get-message-from-translation (tr type decodep)
  (let ((result (copy-sequence
		 (tae-get-compiled-products-internal tr type decodep)))
	tables-new-slot)
    ;;; defined table-set.
    (if (tae-declared-translation-p tr)
	(progn
	  (if (assq 'tables result)
	      (error "Internal Error:message(%S)" result))
	  (cons result
		(list
		 (tae-translation-get-table-set tr type decodep))))
      ;;; generated 'tables
      (if (setq tables-new-slot (assq 'tables result))
	  (cons
	   (delq tables-new-slot result)
	   (cdr tables-new-slot))))))

(defsubst tae-message-set-tables (message tables)
  (let ((tables-slot (assq 'tables message)))
    (if tables-slot
	(setcdr tables-slot tables)
      (setq message (cons
		     (cons 'tables tables)
		     message)))
    message))

(defsubst tae-message-set-new-type (message type &optional orig-type)
  (let ((slot (assq 'new-type message)))
    (if slot
	(progn
	  (cond (type
		 (setcdr slot (list type orig-type)))
		(orig-type
		 (setcdr (cdr slot) (list orig-type))))
	  message)
      (cons (list 'new-type type orig-type) message))))

(defsubst tae-message-get-new-type (message &optional origp)
  (let ((slot (assq 'new-type message)))
    (and slot
	 (if origp (nth 2 slot) (nth 1 slot)))))

(defsubst tae-message-set-arithmetic (message flag)
  (let ((slot (assq 'arithmetic message)))
    (if slot
	(progn
	  (setcdr slot flag)
	  message)
      (cons (cons 'arithmetic flag) message))))

(defsubst tae-message-arithmetic-p (message)
  (cdr (assq 'arithmetic message)))

(defun tae-generate-new-table-set (tables name type decodep)
;  (message "NAME:%S TYPE:%S DECODEP:%S" name type decodep)
  (let (table-set)
    (while
	(progn
	  (setq table-set
		;;; It is useful for debugging
		;;; to intern generated symbols.
		(intern
		 (tae-generate-translation-table-set-name
		  name type decodep)))
	  (table-set-p table-set)))
    (tae-translation-add-table-set
     name table-set type decodep)
    (define-table-set table-set tables)
    table-set))

(defun tae-compile-translation-element (tr-elem type decodep)
  (let* ((type-spec (tae-get-tr-elem-type-spec tr-elem))
	 (from-type (if decodep
			(cdr type-spec)
		      (car type-spec)))
	 (to-type (if decodep
		      (car type-spec)
		    (cdr type-spec)))
	 (type-func (mucs-type-get-ccl-representation type))
	 (to-func (mucs-type-get-ccl-representation to-type))
	 (conv-func (if (eq type from-type)
			'identity
		      (mucs-type-get-conversion-force
		       from-type type)))
	 (tr-elem-all-key (funcall
			   to-func
			   (tae-get-tr-elem-all-key tr-elem)))
	 conv-slot
	 result)
    (setq result
	  (cond ((tae-tr-elem-assoc-p tr-elem)
		 (if (not (tae-tr-elem-normalized-p tr-elem decodep))
		     (error "TAE cannot compile unnormalized translation:%S"
			    tr-elem))
		   
		   ;; type-func, conv-func, and to-func are bound by the above `let'.
		   ;; Owing to Dynamic Binding of Emacs, this function can call
		   ;; a function bounded by them respectively.
		 (setq conv-slot (lambda (x)
				   (cons
				    (funcall type-func
					     (funcall conv-func (car x)))
				    (funcall to-func (cdr x)))))
		 (list 
		  (cons 'tables
			(nconc
			 (make-code-conversion-tables
			  (tae-get-tr-elem-assoc tr-elem)
			  conv-slot)
			 (if tr-elem-all-key
			     (list
			      (tae-project-all-table
			       tr-elem-all-key))
			   nil)))))

		((tae-tr-elem-ccl-p tr-elem)
		 (list (cons 'ccl (tae-get-tr-elem-ccl tr-elem))))

		((tae-tr-elem-range-p tr-elem)
		 (if (not (tae-tr-elem-normalized-p tr-elem decodep))
		     (error "TAE cannot compile unnormalized translation:%S"
			    tr-elem))
		 (let ((ralist (tae-get-tr-elem-range-alist tr-elem))
		       slot1 slot2 st1 end1 st2 end2
		       elem tables)

		   (while (setq elem (car ralist))
		     (setq ralist (cdr ralist))

		     ;; set st1, st2, end1, end2
		     (if (tae-tr-elem-inverse-p tr-elem decodep)
			 (setq slot1 (cdr elem)
			       slot2 (car elem))
		       (setq slot1 (car elem)
			     slot2 (cdr elem)))
		     (if (consp slot1)
			 (setq st1
			       (funcall type-func
					(funcall conv-func
						 (car slot1)))
			       end1
			       (funcall type-func
					(funcall conv-func
						 (cdr slot1))))
		       (setq st1
			     (funcall type-func
				      (funcall conv-func
					       slot1))
			     end1 nil))
		     (if (consp slot2)
			 (setq st2
			       (funcall to-func
					(car slot2))
			       end2
			       (funcall to-func
					(cdr slot2)))
		       (setq st2
			     (funcall to-func slot2)
			     end2 nil))

		     (cond ((and (null end1) (null end2))
			    (error "Invalid range slot:%S!" elem))
			   ((null end1)
			    (setq end1 (+ st1 (- end2 st2))))
			   ((null end2)
			    (setq end2 (+ st2 (- end1 st1))))
			   (t
			    (if (/= (- end1 st1) (- end2 st2))
				(error "Inconsistent range slot:%S(%d, %d)-(%d, %d)"
				       elem st1 end1 st2 end2))))
		     (if (mucs-ccl-inspect-facility 'valid-map-multiple)
			 (setq tables
			       (cons
				(vector t (mucs-ccl-add-program
					   'r0 (- st2 st1))
					st1 (1+ end1))
				tables))
		       (setq tables
			     (cons
			      (vector t (+ (- st2 st1)
					   (mucs-arithmetic-adjust))
				      st1 (1+ end1))
			      tables))))
		   (list 
		    (cons 'tables
			  (nreverse tables))
		    '(arithmetic . t))))))

    (tae-message-set-new-type result
			      to-type from-type)))

(defun tae-compile-OR-operation (translations type decodep)
  (let (tr mes-tbl mes tbls result-mes to-type new-type arith)
    (while (setq tr (car translations))
      (setq translations (cdr translations)
	    mes-tbl (tae-get-message-from-translation
		     tr type decodep)
	    mes (car mes-tbl)
	    tbls (nconc tbls (cdr mes-tbl))
	    new-type (tae-message-get-new-type mes)
	    arith (or arith (tae-message-arithmetic-p mes)))

      ;;; operate type.
      (if to-type
	  (if (not (eq to-type new-type))
	      (signal 'mucs-type-mismatch-error
		      (list to-type new-type)))
	(setq to-type new-type)
	(setq result-mes
	      (tae-message-set-new-type result-mes to-type)))

      ;; normal message keys are preserved.
      (setq result-mes (tae-message-append result-mes mes)))
    (tae-message-set-arithmetic
     (tae-message-set-tables result-mes
			     tbls)
     arith)))

(defun tae-compile-AND-operation (translations type decodep)
  (mucs-ccl-facility-error
   'valid-map-multiple
   "Sorry.  AND operation on compilation is disabled.")
  (let (tr mes-tbl mes tbls result-mes to-type new-type
	   arith first-tbl)
    (while (setq tr (car translations))
      (setq translations (cdr translations)
	    mes-tbl (tae-get-message-from-translation
		     tr type decodep)
	    mes (car mes-tbl)
	    new-type (tae-message-get-new-type mes))

      ;;; operate type.
      (if to-type
	  (if (not (eq to-type new-type))
	      (signal 'mucs-type-mismatch-error
		      (list to-type new-type)))
	(setq to-type new-type)
	(setq result-mes
	      (tae-message-set-new-type result-mes to-type)))
      (if first-tbl
	  (setq tbls (cons 
		      (cdr mes-tbl)
		      (cons
		       (tae-project-all-table t)
		       tbls)))
	(setq first-tbl (list (cdr mes-tbl))
	      tbls first-tbl
	      arith (tae-message-arithmetic-p mes)))

      ;; normal message keys are preserved.
      (setq result-mes (tae-message-append result-mes mes)))
    (tae-message-set-arithmetic
     (tae-message-set-tables result-mes
			     (list tbls))
     arith)))

(defun tae-compile-composite-operation (translations type decodep)
  (mucs-ccl-facility-error
   'valid-map-multiple
   "Sorry.  Composite operation on compilation is disabled.")
  (let (mes-tbl mes
	tbls result-mes
	new-type
	tr arith)
    (setq tr (car translations)
	  translations (cdr translations))
    (if tr
	(while 
	    (progn
	      (setq mes-tbl (tae-get-message-from-translation
			     tr type decodep)
		    mes (car mes-tbl)
		    new-type (tae-message-get-new-type mes)
		    arith (tae-message-arithmetic-p mes))

	      ;; operate type.
	      (setq type new-type)
	      (setq result-mes
		    (tae-message-set-new-type result-mes type))

	      ;; normal message keys are preserved.
	      (setq result-mes (tae-message-append result-mes mes))
	      translations)

	  ;; build up table structure.
	  (setq tbls (nconc tbls
			    (list (cdr mes-tbl))
;			    (if arith (list (tae-project-all-arith-to-lambda)
			    ))

	  (setq	tr (car translations)
		translations (cdr translations))))

    (setq tbls (list
		(nconc tbls
		       (list (cdr mes-tbl))
;		       (if arith (list (tae-project-all-arith-to-lambda)))
		       )
		(tae-project-all-table t)))
    (tae-message-set-arithmetic
     (tae-message-set-tables result-mes
			     tbls)
     arith)))

(defun tae-compile-composite-transparent-operation (translations type decodep)
  (error "Sorry!.  In this version, compilation of
composite-transparent operation is disabled intentionally.")
  (if (/= (length translations) 2)
      (error "Composite Transparent requires two arguments:%S"
	     translations))
  (let ((mes-tbl-a (tae-get-message-from-translation
		    (car translations) type decodep))
	mes-tbl-b mes tbls result-mes)
    (setq mes (car mes-tbl-a)
	  type (tae-message-get-new-type mes)
	  mes-tbl-b (tae-get-message-from-translation
		     (nth 1 translations) type decodep)
	  tbls (cons (cdr mes-tbl-a)
		     (nconc (cdr mes-tbl-b)
			    (list (tae-project-all-table t))
			    (cdr mes-tbl-a))))

    ;; normal message keys are preserved.
    (setq result-mes (tae-message-append mes (car mes-tbl-b)))
    (tae-message-set-tables
     (tae-message-set-new-type result-mes type)
     tbls)))

(defun tae-get-compiled-products-internal (translation type decodep)
  (let (op args)
    (if (consp translation)
	(setq op (car translation)
	      args (cdr translation)))
    (cond ((tae-declared-translation-p translation)
	   ;;; If this translation is dynamic,
	   ;;; all referred translations are used to
	   ;;; dynamic modification.
	   ;(if (tae-translation-dynamic-p
	   ;   tae-current-compiling-translation)
	   ;   (tae-register-dependent-translation
	   ;   translation nil))
	   ;;; If the referred transation is dynamic,
	   ;;; this translation must be also modified by
	   ;;; dynamic modification.
	   ;(if (tae-translation-dynamic-p translation)
	   ;    (tae-register-dependent-translation
	   ;    translation t))
	   (tae-register-dependent-translation
	    translation)
	   (tae-get-compiled-products translation type decodep))
	  ((tae-tr-elem-p translation)
	   (tae-compile-translation-element translation type decodep))
	  ((eq op '|)
	   (tae-compile-OR-operation args type decodep))
	  ((eq op '&)
	   (tae-compile-AND-operation args type decodep))
	  ((eq op 'c)
	   (tae-compile-composite-operation args type decodep))
;	  ((eq op 'ct)
;	   (tae-compile-composite-transparent-operation args type decodep))
	  (t
	   (error "TAE have not supported OP:`%S' yet!!" op)))))

(defun tae-get-compiled-products (name type decodep)
  (let ((products (tae-get-translation-produced-products
		   name type decodep))
	table-set tables-slot translation)
    ;; In order to make traslation data persistent.
    (tae-register-translation name type decodep)

    (if products
	products
      (setq translation (tae-reduce-translation
			 name decodep)
	    products (tae-get-compiled-products-internal
		      translation type decodep))

      ;; deal with 'tables message.
      ;; convert it to table-set.
      (if (setq tables-slot (assq 'tables products))
	  (progn
	    (if (setq table-set
		      (tae-translation-get-table-set
		       name type decodep))
		(progn
		  (define-table-set
		    table-set
		    (cdr tables-slot))
		  table-set)
	      (tae-generate-new-table-set
	       (cdr tables-slot) name type decodep))
	    (setq products
		  (delq tables-slot products))))
      ;; register products.
      (tae-set-translation-produced-products
       name type decodep products)
      ;; return products.
      products)))

;;;
;;; Persistent data for translation rule.
;;;   `Persistent' means data that is necessary
;;; to manipulate the tranlation rule for storing into
;;; a byte-compiled file.

(defun tae-persistent-program-template (name item objs replacep)
  ;;(message "NAME:%S ITEM:%S OBJS:%S" name item objs)
  (if replacep
      `(put (quote ,name)
	    (quote ,item)
	    (quote ,objs))
    `(put (quote ,name)
	  (quote ,item)
	  (nconc (quote ,objs)
		 (get (quote ,name)
		      (quote ,item))))))

(defun tae-generate-persistent-program (name persistent-items)
  "Generate programs to make translation NAME persistent."
  (if (not (tae-declared-translation-p name))
      (error "NAME:%S is not declared translation rule." name))
  (let (result current-item objs objlist replacep
	       product-list clist)
    (while (setq current-item (car persistent-items))
      (setq persistent-items (cdr persistent-items))
      (if (eq current-item 'tae-translation-definition)
	  (setq result
		(cons
		 `(setq ,name (quote ,(symbol-value name)))
		 result))
	(cond ((memq current-item
		     '(tae-translation
		       tae-dynamic-translation
		       tae-dependent-conversions))
	       (setq objs (get name current-item)
		     replacep t))

	      ((eq current-item
		   'tae-reduced-translation-for-encode)
	       (setq objs (tae-reduce-translation name nil)
		     replacep t))

	      ((eq current-item
		   'tae-reduced-translation-for-decode)
	       (setq objs (tae-reduce-translation name t)
		     replacep t))

	      ((eq current-item
		   'tae-products-for-encode)
	       (setq replacep nil
		     product-list (tae-embedment-required-product-list
				   name nil)
		     clist product-list
		     objs nil
		     objlist (get name 'tae-products-for-encode))
	       (while clist
		 (setq objs (cons (assq (car clist) objlist)
				  objs)
		       clist (cdr clist)))
	       (if objs 
		   (setq result
			 (cons (tae-persistent-program-template
				name 'tae-products-for-encode objs nil)
			       result)))
	       (setq objs nil
		     objlist (get name 'tae-table-set-for-encode)
		     clist product-list)
	       (while clist
		 (setq objs (cons (assq (car clist) objlist)
				  objs)
		       clist (cdr clist)))
	       (if objs
		   (setq result
			 (cons (tae-persistent-program-template
				name 'tae-table-set-for-encode objs nil)
			       result)))
	       (tae-notify-embedment-product-list
		name product-list nil))

	      ((eq current-item
		   'tae-products-for-decode)
	       (setq replacep nil
		     product-list (tae-embedment-required-product-list
				   name t)
		     clist product-list
		     objs nil
		     objlist (get name 'tae-products-for-decode))
	       (while clist
		 (setq objs (cons (assq (car clist) objlist)
				  objs)
		       clist (cdr clist)))
	       (if objs
		   (setq result
			 (cons (tae-persistent-program-template
				name 'tae-products-for-decode objs nil)
			       result)))
	       (setq objs nil
		     objlist (get name 'tae-table-set-for-decode)
		     clist product-list)
	       (while clist
		 (setq objs (cons (assq (car clist) objlist)
				  objs)
		       clist (cdr clist)))
	       (if objs
		   (setq result
			 (cons (tae-persistent-program-template
				name 'tae-table-set-for-decode objs nil)
			       result)))
	       (tae-notify-embedment-product-list name product-list t))

	      (t
	       (error "%S is not valid item that can be persistent."
		      current-item)))
	(if (and objs
		 replacep)
	    (setq result
		  (cons (tae-persistent-program-template
			 name current-item objs t)
			result)))))

;    (message "TR:%S,Result:%S" name result)
    result
;;; enclose with `progn' form?
;    (if (> (length result) 1)
;	(cons 'progn result)
;      (car result))
    ))

(defun tae-compile-internal (name &optional decodep type)
  (if (not (tae-declared-translation-p name))
      (error "Undeclared or invalid translation:%S" name))
  (let* ((tae-current-compiling-translation name)
	 (messages (tae-get-compiled-products name type decodep))
	 (mes-cur messages)
	 (result-myo (mucs-ccl-empty-myo))
	 (tae-translation-table-set-index
	  tae-translation-table-set-index)
	 mes-el
	 table-set table-syms table-syms-nested-p)
    ;; Mainly for dynamic modification,
    ;; register dependent conversions.
    (if mucs-current-conversion
	(tae-register-conversion
	 name type decodep
	 mucs-current-conversion))
    ;; We should not directly access message-slots...
    (while (setq mes-el (car mes-cur))
      (setq mes-cur (cdr mes-cur))
      (cond ((eq 'new-type (car mes-el))
	     (setq mucs-current-type (nth 1 mes-el)))

	    ((eq 'arithmetic (car mes-el))
	     ;; do nothing.
	     )
	    (t
	     (error "Internal error.  unknown TAE message:%S" mes-el)
	     )))
    (setq table-set
	  (tae-translation-get-table-set
	   name type decodep)
	  table-syms (get-table-set-symbol-list-recursively
		      table-set)
	  result-myo (mucs-ccl-myo-add-table-set
		      table-set result-myo))
    (if (table-set-nested-p table-set)
	(setq table-syms-nested-p t))
    (list
     result-myo
     table-syms
     table-syms-nested-p)))

(defun tae-compile-retrieve-ccl-prog (table-syms nestedp)
  (if (mucs-ccl-inspect-facility 'valid-map-multiple)
      (if nestedp
	  `(loop
	    (r1 = 0)
	    (r4 = r0)
	    (map-multiple r1 r0 ,table-syms))
	`(loop
	  (r1 = 0)
	  (r4 = r0)
	  (iterate-multiple-map r1 r0 ,@table-syms)))
    (if nestedp
	`(loop
	  (r1 = 0)
	  (r4 = r0)
	  (loop
	   (map-multiple r1 r0 ,table-syms)
	   (if (r0 > ,(mucs-max-number))
	       ((if (r0 == ,(mucs-special-code 1))
		    ((r0 = r4)
		     (r1 += 1)
		     (repeat))
		  ((r0 += (r4 - ,(mucs-arithmetic-adjust)))
		   (r1 += 1)
		   (repeat)))))))
      `(loop
	(r1 = 0)
	(r4 = r0)
	(iterate-multiple-map r1 r0 ,@table-syms)
	(if (r0 > ,(mucs-max-number))
	    ((r0 += (r4 - ,(mucs-arithmetic-adjust)))))))))

;; API for compilation.

(defun tae-compile (name &optional decodep applied-type)
  "Retrieve MYO from the declared translation.
NAME must be a declared translation."
  (if (not (tae-declared-translation-p name))
      (error "Undeclared or invalid translation:%S" name))
  (let* ((tae-enable-register-translation
	  (if mucs-current-package
	      tae-enable-register-translation
	    nil))
	 (type (or applied-type
		   mucs-current-type))
	 (intdata (tae-compile-internal name decodep type))
	 (result-myo (car intdata))
	 (table-syms (nth 1 intdata))
	 (table-syms-nested-p (nth 2 intdata)))
    (mucs-ccl-myo-add-ccl
     (list
      (mucs-conversion-set-program-marker
       (tae-generate-unique-symbol-for-embed
	name type decodep)
       (tae-compile-retrieve-ccl-prog
	table-syms
	table-syms-nested-p)))
     result-myo)
    result-myo))

;;; API for modification

(defun tae-modify-translation (name rule)
  "Modify declared tralslation.(Dynamic modification)"
  (if (not (tae-translation-dynamic-p name))
      (error "%S cannot be modified dynamically!"
	     name))
  (let ((tae-enable-register-translation nil)
	(conversion-list (get name 'tae-dependent-conversions))
	intdata	slot conv root-tr mark type decodep)
    (set name rule)
    (mapcar
     (lambda (x)
       (put name x nil))
     '(tae-reduced-translation-for-encode
       tae-reduced-translation-for-decode
       tae-products-for-encode
       tae-products-for-decode))
    (while conversion-list
      (setq slot (car conversion-list)
	    conv (car slot)
	    root-tr (nth 1 slot)
	    mark (nth 2 slot)
	    type (nth 3 slot)
	    decodep (nth 4 slot)
	    conversion-list (cdr conversion-list))

      ;; reconstruct translation products.
      (tae-compile-internal name decodep type)
      ; flush generated products.
;       (put root-tr
; 	   (if decodep
; 	       'tae-products-for-decode
; 	     'tae-products-for-encode)
; 	   nil)
      (setq intdata (tae-compile-internal root-tr decodep type))
      ;; modify conversion.
      (mucs-modify-conversion
       conv mark
       (tae-compile-retrieve-ccl-prog
	(nth 1 intdata)
	(nth 2 intdata))))))

;;; slightly ad-hoc.
;;; We should separate mucs-ccl and setup part to other modules.
(defmacro tae-embed-for-dynamic-modification (name rule)
  (setq name (eval name)
	rule (eval rule))
  (if (not (tae-translation-dynamic-p name))
      (error "%S cannot be modified dynamically!"
	     name))
  (let ((conversion-list (get name 'tae-dependent-conversions))
	cdata-myo rdata-myo slot conv root-tr mark type decodep
	result)
    (set name rule)
    (mapcar
     (lambda (x)
       (put name x nil))
     '(tae-reduced-translation-for-encode
       tae-reduced-translation-for-decode
       tae-products-for-encode
       tae-products-for-decode))
    (while conversion-list
      (setq slot (car conversion-list)
	    conv (car slot)
	    root-tr (nth 1 slot)
	    mark (nth 2 slot)
	    type (nth 3 slot)
	    decodep (nth 4 slot)
	    conversion-list (cdr conversion-list))

      ;; reconstruct translation products.
      (setq cdata-myo
	    (car (tae-compile-internal name decodep type)))
      ; flush generated products.
;       (put root-tr
; 	   (if decodep
; 	       'tae-products-for-decode
; 	     'tae-products-for-encode)
; 	   nil)
      (setq rdata-myo
	    (car (tae-compile-internal root-tr decodep type)))
      (setq result
	    (append result
		    (mucs-ccl-make-elisp-preparation-from-myo
		     cdata-myo)
		    (mucs-ccl-make-elisp-preparation-from-myo
		     rdata-myo))))
    (cons 'progn
	  result)))

;; MAPPING FUNCTION
;;
;;  mapping functions are 
;;

;; this is a temporal function.

(defun tae-generate-union-func-map (funcs decodep)
  "Make a union function from a list of functions."
  (let (elem func-alist tables ctables)
    (while funcs
	(setq elem (car funcs)
	      funcs (cdr funcs))
	(cond ((table-set-p elem)
	       (setq ctables
		     (get-table-set-symbol-list-recursively
		      elem)
		     tables (append tables ctables)))
	       (t
		(error "Not yet supported type! %S" elem))))
	tables))

(defun tae-generate-func-to-func-map (funcs decodep &optional type)
  "Recieve a-list of (TAG . function)s.
Return a-list<CAR> (TAG . TABLE-NO(index of <CDR> list from 0)) and
a list<CDR> (TABLE<SYMBOL> TABLE<SYMBOL> ...)."
  (let ((idx 0) tbl-alist tbl-c
	elem elemt elemf func-alist tables)
    (while (setq elem (car funcs))
      (setq elemt (car elem)
	    elemf (cdr elem)
	    funcs (cdr funcs))
      (cond ((table-set-p elemf)
	     (if (setq tbl-c (assq elemt tbl-alist))
		 (setcdr tbl-c
			 (nconc
			  (cdr tbl-c)
			  (get-table-set-symbol-list-recursively
			   elemf)))
	       (setq tbl-alist
		     (nconc
		      tbl-alist
		      (list
		       (cons elemt
			     (get-table-set-symbol-list-recursively
			      elemf)))))))
	    (t
	     (error "Not yet supported type! %S" elem))))
    (while (setq elem (car tbl-alist))
      (setq elemt (car elem)
	    elemf (cdr elem)
	    tbl-alist (cdr tbl-alist)
	    func-alist (cons
			(cons elemt
			      (cond ((eq type 'symbol)
				     (car elemf))
				    (t idx)))
			func-alist)
	    idx (+ idx (length elemf) 1)
	    tables (append tables
			   (if tables
			       '(tae-cease-translation-table)
			     nil)
			   elemf)))
    (cons func-alist tables)))

;; Generative Functions
;;

(defun tae-function-union-1 (func1 func2))
(defun tae-function-union-2 (func1 func2))

(defun tae-function-intersection-1 (func1 func2))
(defun tae-function-intersection-2 (func1 func2))

(defun tae-function-compose-1 (func1 func2))
(defun tae-function-compose-2 (func1 func2))

(defun tae-function-to-function (func1 reg))

;;; generate registration program

(defun tae-generate-registration-program ()
  (let ((translation-list (tae-registered-translation-rule-list))
	tr result)
    (while (setq tr (car translation-list))
      ;; (message "TR:%S EB:%S SP:%S" tr (mucs-embedded-p 'tae-translation tr)
      (setq result
	    (append
	     (tae-generate-persistent-program
	      tr
	      (if (mucs-embedded-p 'tae-translation tr)
		  '(tae-products-for-encode
		    tae-products-for-decode)
		(mucs-notify-embedment 'tae-translation tr)
		(if (tae-translation-dynamic-p tr)
		    '(tae-translation-definition
		      tae-translation
		      tae-dynamic-translation
		      tae-products-for-encode
		      tae-products-for-decode
		      tae-dependent-conversions)
		  '(tae-translation
		    tae-products-for-encode
		    tae-products-for-decode))))
	     result)
	    translation-list
	    (cdr translation-list)))
    result))

;;; Add hook for embedding translation informations to a package.
(add-hook 'mucs-package-definition-end-hook
	  (function tae-generate-registration-program))

(provide 'tae)