Changed the license to the AGPL3. Downcased all the lisp sources. Completed the READM...
[com-informatimago:com-informatimago.git] / clext / character-sets.lisp
1 ;;;; -*- mode:lisp;coding:utf-8 -*-
2 ;;;;**************************************************************************
3 ;;;;FILE:               character-sets.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    Portability layer over character sets and external-formats.
10 ;;;;    
11 ;;;;AUTHORS
12 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
13 ;;;;MODIFICATIONS
14 ;;;;    2012-04-06 <PJB> Extracted from
15 ;;;;                     com.informatimago.common-lisp.cesarum.character-sets.
16 ;;;;BUGS
17 ;;;;LEGAL
18 ;;;;    AGPL3
19 ;;;;    
20 ;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
21 ;;;;    
22 ;;;;    This program is free software: you can redistribute it and/or modify
23 ;;;;    it under the terms of the GNU Affero General Public License as published by
24 ;;;;    the Free Software Foundation, either version 3 of the License, or
25 ;;;;    (at your option) any later version.
26 ;;;;    
27 ;;;;    This program is distributed in the hope that it will be useful,
28 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
29 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
30 ;;;;    GNU Affero General Public License for more details.
31 ;;;;    
32 ;;;;    You should have received a copy of the GNU Affero General Public License
33 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
34 ;;;;**************************************************************************
35
36 (in-package "COMMON-LISP-USER")
37 (defpackage "COM.INFORMATIMAGO.CLEXT.CHARACTER-SETS"
38   (:use "COMMON-LISP"
39         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STRING"
40         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CHARACTER-SETS")
41   (:export
42    "MAKE-EXTERNAL-FORMAT"
43    "EXTERNAL-FORMAT-CHARACTER-ENCODING"
44    "EXTERNAL-FORMAT-LINE-TERMINATION"
45    "CHARACTER-SET-TO-LISP-ENCODING"
46    "CHARACTER-SET-FOR-LISP-ENCODING"
47    "CHARACTER-SET-TO-EMACS-ENCODING"
48    "CHARACTER-SET-FROM-EMACS-ENCODING"
49    "EMACS-ENCODING-TO-LISP-EXTERNAL-FORMAT")
50   (:documentation "
51 This package exports functions to manage character-sets,
52 character encodings, coding systems and external format.
53 It's all the same, but everyone likes to have his own terms...
54
55 Copyright Pascal J. Bourguignon 2005 - 2012
56 This package is provided under the GNU General Public Licence.
57 See the source file for details.
58 "))
59 (in-package "COM.INFORMATIMAGO.CLEXT.CHARACTER-SETS")
60
61
62 (defparameter *aliases*
63   '(
64     ;; clisp, emacs:
65     ("UNICODE-32-LITTLE-ENDIAN" "UTF-32-LE" "UTF-32LE")
66     ("UNICODE-32-BIG-ENDIAN"    "UTF-32-BE" "UTF-32BE")
67     ("UNICODE-16-LITTLE-ENDIAN" "UTF-16-LE" "UTF-16LE")
68     ("UNICODE-16-BIG-ENDIAN"    "UTF-16-BE" "UTF-16BE")
69     ;; clisp
70     ("CP437-IBM" "CP437")
71     ("CP852-IBM" "CP852")
72     ("CP860-IBM" "CP860")
73     ("CP861-IBM" "CP861")
74     ("CP862-IBM" "CP862")
75     ("CP863-IBM" "CP863")
76     ("CP864-IBM" "CP864")
77     ("CP865-IBM" "CP865")
78     ("CP869-IBM" "CP869")
79     ("CP874-IBM" "CP874")
80     ;; emacs:
81     ("VSCII" "VISCII")
82     ;; Aliases for other implementations:
83     ("LATIN1"  "ISO-8859-1")
84     ("LATIN2"  "ISO-8859-2")
85     ("LATIN3"  "ISO-8859-3")
86     ("LATIN4"  "ISO-8859-4")
87     ("LATIN5"  "ISO-8859-9")
88     ("LATIN6"  "ISO-8859-10")
89     ("LATIN8"  "ISO-8859-14")
90     ("LATIN9"  "ISO-8859-15")
91
92     ("LATIN-1"  "ISO-8859-1")
93     ("LATIN-2"  "ISO-8859-2")
94     ("LATIN-3"  "ISO-8859-3")
95     ("LATIN-4"  "ISO-8859-4")
96     ("LATIN-5"  "ISO-8859-9")
97     ("LATIN-6"  "ISO-8859-10")
98     ("LATIN-8"  "ISO-8859-14")
99     ("LATIN-9"  "ISO-8859-15")
100     )
101
102   "A list of lists of aliases for character-set.")
103
104
105
106 (defun add-aliases-to-group (encoding-name-and-aliases aliases)
107   "
108 ENCODING-NAME-AND-ALIASES:
109             A list of name and aliases of character-sets.
110
111 ALIASES:    A list of lists of aliases, each sublist naming the same character-set.
112
113 RETURN:     A new list of name and aliases, with the ALIASES added, if
114             they name the same character-set as ENCODING-NAME-AND-ALIASES.
115 "
116   (let ((alias (find-if
117                 (lambda (alias)
118                   (intersection encoding-name-and-aliases alias :test (function string-equal)))
119                 aliases)))
120     (if alias
121         (remove-duplicates (cons (car encoding-name-and-aliases)
122                                  (union (cdr encoding-name-and-aliases) alias
123                                         :test (function string-equal)))
124                            :test (function string-equal))
125         encoding-name-and-aliases)))
126
127
128
129 (defparameter *lisp-encodings*
130   
131   #+(and ccl (not ccl-1.6))
132   (mapcar (lambda (x) (mapcar (function string-upcase) x))
133           '((:iso-8859-1 :iso_8859-1 :latin1 :l1 :ibm819 :cp819 :csisolatin1)
134             (:iso-8859-2 :iso_8859-2 :latin-2 :l2 :csisolatin2)
135             (:iso-8859-3 :iso_8859-3 :latin3 :l3 :csisolatin3)
136             (:iso-8859-4 :iso_8859-4 :latin4 :l4 :csisolatin4)
137             (:iso-8859-5 :iso_8859-5 :cyrillic :csisolatincyrillic :iso-ir-144)
138             (:iso-8859-6 :iso_8859-6 :arabic :csisolatinarabic :iso-ir-127)
139             (:iso-8859-7 :iso_8859-7 :greek :greek8 :csisolatingreek :iso-ir-126 :elot_928 :ecma-118)
140             (:iso-8859-8 :iso_8859-8 :hebrew :csisolatinhebrew :iso-ir-138)
141             (:iso-8859-9 :iso_8859-9 :latin5 :csisolatin5 :iso-ir-148)
142             (:iso-8859-10 :iso_8859-10 :latin6 :csisolatin6 :iso-ir-157)
143             (:iso-8859-11)
144             (:iso-8859-13)
145             (:iso-8859-14 :iso_8859-14 :iso-ir-199 :latin8 :l8 :iso-celtic)
146             (:iso-8859-15 :iso_8859-15 :latin9)
147             (:iso-8859-16 :iso_8859-16 :iso-ir-199 :latin8 :l8 :iso-celtic)
148             (:macintosh :macos-roman :macosroman :mac-roman :macroman)
149             (:ucs-2)
150             (:ucs-2be)
151             (:ucs-2le)
152             (:us-ascii :csascii :cp637 :ibm637 :us :iso646-us :ascii :iso-ir-6)
153             (:utf-16)
154             (:utf-16be)
155             (:utf-16le)
156             (:utf-32 :utf-4)
157             (:utf-32be :ucs-4be)
158             (:utf-8)
159             (:utf-32le :ucs-4le)
160             (:windows-31j  :cp932 :cswindows31j)
161             (:euc-jp :eucjp)))
162
163   #+(and ccl ccl-1.6)
164   (mapcar (lambda (x) (mapcar (function string-upcase) x))
165           '((:iso-8859-1 :iso_8859-1  :latin1  :l1  :ibm819  :cp819  :csisolatin1)
166             (:iso-8859-2 :iso_8859-2  :latin-2  :l2  :csisolatin2)
167             (:iso-8859-3 :iso_8859-3  :latin3 :l3  :csisolatin3)
168             (:iso-8859-4 :iso_8859-4  :latin4  :l4  :csisolatin4)
169             (:iso-8859-5 :iso_8859-5  :cyrillic  :csisolatincyrillic  :iso-ir-144)
170             (:iso-8859-6 :iso_8859-6  :arabic  :csisolatinarabic  :iso-ir-127)
171             (:iso-8859-7 :iso_8859-7  :greek  :greek8  :csisolatingreek  :iso-ir-126  :elot_928  :ecma-118)
172             (:iso-8859-8 :iso_8859-8  :hebrew  :csisolatinhebrew  :iso-ir-138)
173             (:iso-8859-9 :iso_8859-9  :latin5  :csisolatin5  :iso-ir-148)
174             (:iso-8859-10 :iso_8859-10  :latin6  :csisolatin6  :iso-ir-157)
175             (:iso-8859-11)
176             (:iso-8859-13)
177             (:iso-8859-14 :iso_8859-14  :iso-ir-199  :latin8  :l8  :iso-celtic)
178             (:iso-8859-15 :iso_8859-15  :latin9)
179             (:iso-8859-16 :iso_8859-16  :iso-ir-199  :latin8  :l8  :iso-celtic)
180             (:macintosh :macos-roman  :macosroman  :mac-roman  :macroman)
181             (:ucs-2)
182             (:ucs-2be)
183             (:ucs-2le)
184             (:us-ascii :csascii  :cp637 :ibm637  :us  :iso646-us  :ascii  :iso-ir-6)
185             (:utf-16)
186             (:utf-16be)
187             (:utf-16le)
188             (:utf-32 :utf-4)
189             (:utf-32be :ucs-4be)
190             (:utf-8)
191             (:utf-32le :ucs-4le)
192             (:windows-31j :cp932  :cswindows31j)
193             (:euc-jp :eucjp)
194             (:gb2312 :gb2312-80 :gb2312-1980 :euc-cn :euccn)
195             (:cp936 :gbk :ms936 :windows-936)))
196
197   #+clisp
198   (let ((h (make-hash-table)))
199     (do-external-symbols (s "CHARSET")
200       (push (string-upcase s) (gethash (ext:encoding-charset s) h)))
201     (let ((r '()))
202       (maphash (lambda (k v) (declare (ignore k)) (push  v r)) h)
203       r))
204   
205   #+cmu   '(("ISO-8859-1"))          ; :iso-latin-1-unix ;  what else?
206
207   #+ecl   '(("ISO-8859-1")
208             #+unicode ("UTF-8"))
209
210   #+sbcl
211   (etypecase sb-impl::*external-formats*
212     (hash-table (let ((result '()))
213                   (maphash (lambda (name encoding) (pushnew encoding result))
214                            sb-impl::*external-formats*)
215                   (mapcar (lambda (encoding)
216                             (mapcar (function string-upcase)
217                                     (slot-value encoding 'sb-impl::names)))
218                           result)))
219     (list (mapcar (lambda (x) (mapcar (function string-upcase) (first x)))
220                   sb-impl::*external-formats*)))
221   
222   #-(or ccl clisp cmu sbcl)
223   (progn
224     (warn "What are the available external formats in ~A ?"
225           (lisp-implementation-type))
226     '(("US-ASCII")))
227
228   "Give an a-list of name and list of aliases of encoding systems in
229 the current Common Lisp implementation.  Those names and aliases are strings.")
230
231
232
233 (defun fill-character-set-lisp-encoding ()
234   "
235 DO:         Set the cs-lisp-encoding of the character-sets present in
236             the current implementation.
237 "
238   (dolist (lsl *lisp-encodings* (values))
239     (let* ((aliases (add-aliases-to-group lsl *aliases*))
240            (cs (some (function find-character-set) aliases)))
241       (when cs
242         ;; We don't add the aliases to the lisp-encoding, since this
243         ;; list is used to make the implementation specific encodings
244         ;; and external-formats.
245         (setf (cs-lisp-encoding cs) lsl)))))
246
247
248
249
250
251
252 (defgeneric make-external-format (character-encoding &optional line-termination)
253   (:documentation "Makes an implementation specific external-format.")
254   
255   (:method ((cs character-set) &optional line-termination)
256     (if (cs-lisp-encoding cs)
257         (let ((encoding         (first (cs-lisp-encoding cs)))
258               (line-termination (or line-termination
259                                     #+ccl ccl:*default-line-termination*
260                                     #-ccl :unix)))
261           (check-type line-termination (member :unix :mac :dos))
262
263           #+ccl
264           (ccl:make-external-format :domain nil
265                                     :character-encoding (intern encoding "KEYWORD")
266                                     :line-termination line-termination)
267           
268           #+clisp
269           (ext:make-encoding :charset (symbol-value (intern (first (cs-lisp-encoding cs)) "CHARSET"))
270                              :line-terminator line-termination
271                              :input-error-action :error
272                              :output-error-action :error)
273
274           #+cmu
275           (if (string-equal (first (cs-lisp-encoding cs)) "ISO-8859-1")
276               :iso-latin-1-unix
277               (progn #|should not occur|#
278                 (cerror 'character-set-error
279                         :character-set cs
280                         :format-control "The character-set ~S has no lisp-encoding in ~A"
281                         :format-arguments (list (cs-name cs) (lisp-implementation-type)))
282                 :default))
283
284           #+ecl
285           (cond
286             ((string-equal encoding "ISO-8859-1")
287              :iso-8859-1)
288             #+unicode
289             ((string-equal encoding "UTF-8")
290              :utf-8)
291             (t  #|should not occur|#
292              (cerror 'character-set-error
293                      :character-set cs
294                      :format-control "The character-set ~S has no lisp-encoding in ~A"
295                      :format-arguments (list (cs-name cs) (lisp-implementation-type)))
296              :default))
297           
298           #+sbcl
299           (intern (first (cs-lisp-encoding cs)) "KEYWORD")
300
301
302           #-(or clisp) (values
303                       (find (lambda (cs) (member encoding (cs-lisp-encoding cs)
304                                                  :test (function string-equal)))
305                             *character-sets*)
306                       :unix))
307         (error 'character-set-error
308                :character-set cs
309                :format-control "The character-set ~S has no lisp-encoding in ~A"
310                :format-arguments (list (cs-name cs) (lisp-implementation-type)))))
311
312   (:method ((character-set-name string) &optional line-termination)
313     (let ((cs (find-character-set character-set-name)))
314       (if cs
315           (make-external-format cs line-termination)
316           (error 'character-set-error
317                  :character-set (string character-set-name)
318                  :format-control "There is no character-set named ~S"
319                  :format-arguments (list (string character-set-name))))))
320   
321   (:method ((character-set symbol) &optional line-termination)
322     (make-external-format (string character-set) line-termination)))
323
324
325 (defun external-format-character-encoding (external-format)
326   #+ccl (ccl:external-format-character-encoding external-format)
327   #+(and clisp unicode) (string (ext:encoding-charset external-format))
328   #+cmu (string external-format)
329   #+ecl (string external-format)
330   #+sbcl (string external-format)
331   #-(or ccl (and clisp unicode) cmu ecl sbcl)
332   (error "~S: How to decode an external-format in ~A"
333          'external-format-character-encoding
334          (lisp-implementation-type)))
335
336
337 (defun external-format-line-termination (external-format)
338   #+ccl (ccl:external-format-line-termination external-format)
339   #+(and clisp unicode) (string (ext:encoding-line-terminator external-format))
340   #+cmu :unix
341   #+ecl :unix
342   #+sbcl :unix
343   #-(or ccl (and clisp unicode) cmu ecl sbcl)
344   (error "~S: How to decode an external-format in ~A"
345          'external-format-line-termination
346          (lisp-implementation-type)))
347
348
349
350
351
352 (defun character-set-to-lisp-encoding (cs &key (line-termination :unix))
353   "
354 RETURN: An implementation specific object representing the  encoding for
355         the given character-set and line-termination.
356 SIGNAL: An error if line-termination is not (member :unix :mac :dos nil) or
357         if cs has no emacs encoding.
358 "
359   (assert (member line-termination '(:unix :mac :dos nil)))
360   (make-external-format cs line-termination))
361
362
363 (defun character-set-for-lisp-encoding (encoding)
364   "
365 ENCODING:  An implementation specific object representing an encoding.
366            possibly with line-termination.
367 RETURN:    The character-set that correspond to this emacs-encoding ;
368            the line-termination.
369 "
370   (values (external-format-character-encoding encoding)
371           (external-format-line-termination   encoding)))
372
373
374
375
376
377
378
379 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
380 ;;;
381 ;;; Emacs coding systems
382 ;;;
383
384 (defparameter *emacs-encodings*
385   #||
386   ;; emacs lisp code to generate the following list.
387   (require 'cl)
388   (sort*
389    (mapcar
390     (lambda (sl) (mapcar (lambda (sym) (upcase (symbol-name sym))) sl))
391     (delete-duplicates
392      (mapcar (lambda (coding-system)
393                (or (coding-system-get coding-system 'alias-coding-systems)
394                    (list coding-system)))
395              (let ((coding-system-list '()))
396                (mapatoms (lambda (sym) (when (and sym (coding-system-p sym))
397                                     (push sym coding-system-list))))
398                coding-system-list))
399      :test (function equal)))
400    (function string<) :key (function first))
401   ||#
402   (quote
403    (("CHINESE-BIG5" "BIG5" "CN-BIG5" "CP950")
404     ("CHINESE-HZ" "HZ-GB-2312" "HZ")
405     ("CHINESE-ISO-8BIT" "CN-GB-2312" "EUC-CHINA" "EUC-CN" "CN-GB" "GB2312" "CP936")
406     ("CHINESE-ISO-8BIT-WITH-ESC")
407     ("COMPOUND-TEXT" "X-CTEXT" "CTEXT")
408     ("COMPOUND-TEXT-WITH-EXTENSIONS" "X-CTEXT-WITH-EXTENSIONS" "CTEXT-WITH-EXTENSIONS")
409     ("CP1125" "RUSCII" "CP866U")
410     ("CP437")
411     ("CP720")
412     ("CP737")
413     ("CP775")
414     ("CP850")
415     ("CP851")
416     ("CP852")
417     ("CP855")
418     ("CP857")
419     ("CP860")
420     ("CP861")
421     ("CP862")
422     ("CP863")
423     ("CP864")
424     ("CP865")
425     ("CP866")
426     ("CP869")
427     ("CP874")
428     ("CTEXT-NO-COMPOSITIONS")
429     ("CYRILLIC-ALTERNATIVNYJ" "ALTERNATIVNYJ")
430     ("CYRILLIC-ISO-8BIT" "ISO-8859-5")
431     ("CYRILLIC-ISO-8BIT-WITH-ESC")
432     ("CYRILLIC-KOI8" "KOI8-R" "KOI8" "CP878")
433     ("EMACS-MULE")
434     ("EUC-TW" "EUC-TAIWAN")
435     ("GEORGIAN-PS")
436     ("GREEK-ISO-8BIT" "ISO-8859-7")
437     ("GREEK-ISO-8BIT-WITH-ESC")
438     ("HEBREW-ISO-8BIT" "ISO-8859-8" "ISO-8859-8-E" "ISO-8859-8-I")
439     ("HEBREW-ISO-8BIT-WITH-ESC")
440     ("IN-IS13194" "DEVANAGARI")
441     ("IN-IS13194-WITH-ESC")
442     ("ISO-2022-7BIT")
443     ("ISO-2022-7BIT-LOCK" "ISO-2022-INT-1")
444     ("ISO-2022-7BIT-LOCK-SS2" "ISO-2022-CJK")
445     ("ISO-2022-7BIT-SS2")
446     ("ISO-2022-8BIT-SS2")
447     ("ISO-2022-CN" "CHINESE-ISO-7BIT")
448     ("ISO-2022-CN-EXT")
449     ("ISO-2022-JP" "JUNET")
450     ("ISO-2022-JP-2")
451     ("ISO-2022-KR" "KOREAN-ISO-7BIT-LOCK")
452     ("ISO-8859-11")
453     ("ISO-8859-6" "ARABIC-ISO-8BIT")
454     ("ISO-LATIN-1" "ISO-8859-1" "LATIN-1")
455     ("ISO-LATIN-1-WITH-ESC")
456     ("ISO-LATIN-10" "ISO-8859-16" "LATIN-10")
457     ("ISO-LATIN-2" "ISO-8859-2" "LATIN-2")
458     ("ISO-LATIN-2-WITH-ESC")
459     ("ISO-LATIN-3" "ISO-8859-3" "LATIN-3")
460     ("ISO-LATIN-3-WITH-ESC")
461     ("ISO-LATIN-4" "ISO-8859-4" "LATIN-4")
462     ("ISO-LATIN-4-WITH-ESC")
463     ("ISO-LATIN-5" "ISO-8859-9" "LATIN-5")
464     ("ISO-LATIN-5-WITH-ESC")
465     ("ISO-LATIN-6" "ISO-8859-10" "LATIN-6")
466     ("ISO-LATIN-7" "ISO-8859-13" "LATIN-7")
467     ("ISO-LATIN-8" "ISO-8859-14" "LATIN-8")
468     ("ISO-LATIN-8-WITH-ESC")
469     ("ISO-LATIN-9" "ISO-8859-15" "LATIN-9" "LATIN-0")
470     ("ISO-LATIN-9-WITH-ESC")
471     ("ISO-SAFE" "US-ASCII")
472     ("JAPANESE-ISO-7BIT-1978-IRV" "ISO-2022-JP-1978-IRV" "OLD-JIS")
473     ("JAPANESE-ISO-8BIT" "EUC-JAPAN-1990" "EUC-JAPAN" "EUC-JP")
474     ("JAPANESE-ISO-8BIT-WITH-ESC")
475     ("JAPANESE-SHIFT-JIS" "SHIFT_JIS" "SJIS" "CP932")
476     ("KOI8-T" "CYRILLIC-KOI8-T")
477     ("KOI8-U")
478     ("KOREAN-ISO-8BIT" "EUC-KR" "EUC-KOREA" "CP949")
479     ("KOREAN-ISO-8BIT-WITH-ESC")
480     ("LAO")
481     ("LAO-WITH-ESC")
482     ("MAC-ROMAN")
483     ("MIK")
484     ("MULE-UTF-16" "UTF-16")
485     ("MULE-UTF-16BE" "UTF-16BE")
486     ("MULE-UTF-16BE-WITH-SIGNATURE" "UTF-16BE-WITH-SIGNATURE"
487                                     "MULE-UTF-16-BE" "UTF-16-BE")
488     ("MULE-UTF-16LE" "UTF-16LE")
489     ("MULE-UTF-16LE-WITH-SIGNATURE" "UTF-16LE-WITH-SIGNATURE"
490                                     "MULE-UTF-16-LE" "UTF-16-LE")
491     ("MULE-UTF-8" "UTF-8")
492     ("NEXT")
493     ("NO-CONVERSION")
494     ("PT154")
495     ("RAW-TEXT")
496     ("THAI-TIS620" "TH-TIS620" "TIS620" "TIS-620")
497     ("THAI-TIS620-WITH-ESC")
498     ("TIBETAN-ISO-8BIT" "TIBETAN")
499     ("TIBETAN-ISO-8BIT-WITH-ESC")
500     ("UNDECIDED")
501     ("UTF-7")
502     ("VIETNAMESE-TCVN" "TCVN" "TCVN-5712")
503     ("VIETNAMESE-VIQR" "VIQR")
504     ("VIETNAMESE-VISCII" "VISCII")
505     ("VIETNAMESE-VSCII" "VSCII")
506     ("W3M-EUC-JAPAN")
507     ("W3M-ISO-LATIN-1")
508     ("WINDOWS-1250" "CP1250")
509     ("WINDOWS-1251" "CP1251" "CP1251")
510     ("WINDOWS-1252" "CP1252" "CP1252")
511     ("WINDOWS-1253" "CP1253")
512     ("WINDOWS-1254" "CP1254")
513     ("WINDOWS-1255" "CP1255")
514     ("WINDOWS-1256" "CP1256")
515     ("WINDOWS-1257" "CP1257")
516     ("WINDOWS-1258" "CP1258")))
517   "List of emacs encoding, grouped by aliases")
518
519
520
521 (defun fill-character-set-emacs-encoding ()
522   "
523 DO:         Set the cs-emacs-encoding of the character-sets present in
524             the current implementation.
525 "
526   (dolist (ecsl *emacs-encodings* (values))
527     (let ((cs (some (function find-character-set)
528                     (add-aliases-to-group ecsl *aliases*))))
529       (when cs
530         (setf (cs-emacs-encoding cs) ecsl)))))
531
532
533
534
535 (defun character-set-to-emacs-encoding (cs &key (line-termination :unix))
536   "
537 RETURN: A string naming the emacs encoding for the given character-set
538         and line-termination.
539 SIGNAL: An error if line-termination is not (member :unix :mac :dos nil) or
540         if cs has no emacs encoding.
541 "
542   (assert (member line-termination '(:unix :mac :dos nil)))
543   (unless  (cs-emacs-encoding cs)
544     (error "The character-set ~A has no corresponding emacs encoding"
545            (cs-name cs)))
546   (format nil "~(~A~:[~;~:*-~A~]~)" (first (cs-emacs-encoding cs))
547           line-termination))
548
549
550 (defun character-set-from-emacs-encoding (ecs)
551   "
552 ECS:    A string or symbol naming the emacs encoding,
553         possibly suffixed by a line-termination.
554 RETURN: The character-set that correspond to this emacs-encoding ;
555         the line-termination.
556 "
557   (let ((line-termination nil)
558         (ecs (string ecs)))
559     (cond
560       ((suffixp "-unix" ecs :test (function char-equal))
561        (setf ecs  (subseq ecs 0 (- (length ecs) 5))
562              line-termination :unix))
563       ((suffixp "-dos" ecs :test (function char-equal))
564        (setf ecs (subseq ecs 0 (- (length ecs) 4))
565              line-termination :dos))
566       ((suffixp "-mac" ecs :test (function char-equal))
567        (setf ecs (subseq ecs 0 (- (length ecs) 4))
568              line-termination :mac)))
569     (values
570      (find (lambda (cs) (member ecs (cs-emacs-encoding cs)
571                            :test (function string-equal)))
572            *character-sets*)
573      line-termination)))
574
575
576 (defun emacs-encoding-to-lisp-external-format (emacs-encoding)
577   "
578 RETURN:  the external-format value corresponding to this EMACS-ENCODING.
579 "
580   (multiple-value-bind (charset line-termination)
581       (character-set-from-emacs-encoding emacs-encoding)
582     (when charset
583       (character-set-to-lisp-encoding charset :line-termination line-termination))))
584
585
586
587 (eval-when (:load-toplevel :execute)
588   (fill-character-set-emacs-encoding)
589   (fill-character-set-lisp-encoding))
590
591
592
593
594 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
595 ;;;
596 ;;; The rest was used to generate the data in
597 ;;; COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CHARACTER-SETS
598 ;;;
599
600 #+(and (and) clisp)
601 (defun compute-character-set-ranges ()
602   "
603 DO:     Read the character-set file and build the *character-sets* list,
604         then update the character sets with emacs encodings, lisp encodings,
605         and character set ranges (found in clisp).
606 RETURN: *character-sets*
607 "
608   (setf *character-sets* (read-character-sets-file "character-sets"))
609   (fill-character-set-emacs-encoding)
610   (fill-character-set-lisp-encoding)
611   (dolist (cs *character-sets*)
612     (when (cs-lisp-encoding cs)
613       (let ((charset (find-symbol (first (cs-lisp-encoding cs)) "CHARSET")))
614         (setf (cs-ranges cs)
615               #+#.(cl:if (cl:ignore-errors
616                           (cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
617                          '(:and) '(:or))
618               (map 'vector (function char-code)
619                    (system::get-charset-range charset))
620               #-#.(cl:if (cl:ignore-errors
621                           (cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
622                          '(:and) '(:or))
623               (coerce
624                (loop
625                   :with charset = (symbol-value charset)
626                   :with i = 0
627                   :for start = (loop
628                                   :until (or (< char-code-limit i)
629                                              (typep (code-char i) charset))
630                                   :do (incf i)
631                                   :finally (return (when (<= i char-code-limit)
632                                                      i)))
633                   :while start
634                   :nconc (list start
635                                (loop
636                                   :while (and (<= i char-code-limit)
637                                               (typep (code-char i) charset))
638                                   :do (incf i)
639                                   :finally (return (1- i)))))
640                'vector)))))
641   *character-sets*)
642
643
644 ;;; Provide a default value for  *CHARACTER-SETS*
645 #-(and)
646 (let ((*print-right-margin* 72))
647   (pprint
648    `(setf *character-sets*
649       (list
650        ,@(mapcar
651           (lambda (cs)
652             `(make-character-set
653               :mib-enum ,(cs-mib-enum cs)
654               :name ,(cs-name cs)
655               :aliases ',(cs-aliases cs)
656               :mime-encoding  ',(cs-mime-encoding cs)
657               :source ',(cs-source cs)
658               :comments ',(cs-comments cs)
659               :references ',(cs-references cs)
660               :ranges ,(cs-ranges cs)))
661           (compute-character-set-ranges))))))
662
663
664 ;;;; THE END ;;;;