Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-debug.el @ 102:a145efe76779 r20-1b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b3
author cvs
date Mon, 13 Aug 2007 09:15:49 +0200
parents 131b0175ea99
children fe104dbd9147
comparison
equal deleted inserted replaced
101:a0ec055d74dd 102:a145efe76779
42 (princ "## LIST OF CHARACTER SETS\n") 42 (princ "## LIST OF CHARACTER SETS\n")
43 (princ 43 (princ
44 "NAME REGISTRY BYTES CHARS FINAL GRAPHIC DIR\n") 44 "NAME REGISTRY BYTES CHARS FINAL GRAPHIC DIR\n")
45 (princ 45 (princ
46 "--------------------------------------------------------------------") 46 "--------------------------------------------------------------------")
47 (mapcar 47 (dolist (charset (charset-list))
48 (lambda (name) 48 (setq charset (get-charset charset))
49 (let ((charset (get-charset name))) 49 (princ (format
50 (princ (format 50 "%20s %15s %5d %5d %5d %7d %s\n"
51 "%20s %15s %5d %5d %5d %7d %s\n" 51 (charset-name charset)
52 name 52 (charset-registry charset)
53 (charset-registry charset) 53 (charset-dimension charset)
54 (charset-dimension charset) 54 (charset-chars charset)
55 (charset-chars charset) 55 (charset-final charset)
56 (charset-final charset) 56 (charset-graphic charset)
57 (charset-graphic charset) 57 (charset-direction charset)))
58 (charset-direction charset))) 58 (princ " ")
59 (princ " ") 59 (princ "%s\n" (charset-doc-string charset)))))
60 (princ "%s\n" (charset-doc-string charset)))) 60
61 (charset-list)) 61 ; (princ "## CCL PROGRAM TO CONVERT INTERNAL TO EXTERNAL CODE\n")
62 62 ; (princ "NAME CCL-PROGRAMS\n")
63 (princ "## CCL PROGRAM TO CONVERT INTERNAL TO EXTERNAL CODE\n") 63 ; (mapcar
64 (princ "NAME CCL-PROGRAMS\n") 64 ; (lambda (name)
65 (mapcar 65 ; (let ((ccl (charset-ccl-program name)))
66 (lambda (name) 66 ; (if ccl
67 (let ((ccl (charset-ccl-program name))) 67 ; (let ((i 0) (len (length ccl)))
68 (if ccl 68 ; (princ (format "%20s " name))
69 (let ((i 0) (len (length ccl))) 69 ; (while (< i len)
70 (princ (format "%20s " name)) 70 ; (princ (format " %x" (aref ccl i)))
71 (while (< i len) 71 ; (setq i (1+ i)))
72 (princ (format " %x" (aref ccl i))) 72 ; (princ "\n")))))
73 (setq i (1+ i))) 73 ; (charset-list))
74 (princ "\n"))))) 74 ; ))
75 (charset-list)) 75
76 )) 76 (defun describe-designation (cs register)
77 77 (let ((charset
78 (defun describe-designation (flags graphic) 78 (coding-system-property
79 (let ((lc (aref flags graphic)) 79 cs (intern (format "charset-g%d" register))))
80 lc1) 80 (force
81 (if (integerp lc) (setq lc1 (if (> lc 0) lc (- lc)))) 81 (coding-system-property
82 (princ (format " G%d -- %s" 82 cs (intern (format "force-g%d-on-output" register)))))
83 graphic 83 (princ
84 (or (and lc1 (char-description lc1)) 84 (format
85 (and (eq lc t) "never used") 85 " G%d: %s%s\n"
86 "none"))) 86 register
87 (princ (if (and lc1 (< lc 0)) 87 (cond ((null charset) "never used")
88 " (explicit designation required)\n" 88 ((eq t charset) "none")
89 "\n")))) 89 (t (charset-name charset)))
90 ;; end of patch 90 (if force " (explicit designation required)" "")))))
91 91
92 ;;;###autoload 92 ;;;###autoload
93 (defun describe-coding-system (cs) 93 (defun describe-coding-system (cs)
94 "Display documentation of the coding-system CS." 94 "Display documentation of the coding-system CS."
95 (interactive "zCoding-system: ") 95 (interactive "zCoding-system: ")
96 (get-coding-system cs);; correctness check 96 (setq cs (get-coding-system cs))
97 (with-output-to-temp-buffer "*Help*" 97 (with-output-to-temp-buffer "*Help*"
98 (princ "Coding-system ") 98 (princ (format "Coding-system %s [%s]:\n"
99 (princ cs) 99 (coding-system-name cs)
100 (princ " [") 100 (coding-system-mnemonic cs)))
101 (princ (coding-system-mnemonic cs)) 101 (princ (format " %s\n" (coding-system-doc-string cs)))
102 (princ "]: \n") 102 (let ((type (coding-system-type cs)))
103 (if (not cs) nil 103 (princ "Type: ") (princ type) (terpri)
104 (princ " ") 104 (case type
105 (princ (coding-system-doc-string cs)) 105 ('iso2022
106 (princ "\nType: ") 106 (princ "\nInitial designations:\n")
107 (let ((type (coding-system-type cs))) 107 (dolist (register '(0 1 2 3))
108 (princ type) 108 (describe-designation cs register))
109 (cond ((eq type 'iso2022) 109 (princ "\nOther properties: \n")
110 (princ "ISO-2022]\n") 110 (dolist (prop '(short no-ascii-eol no-ascii-cntl seven lock-shift no-iso6429))
111 (princ "Initial designations:\n") 111 (princ (format " %s: " (symbol-name prop)))
112 (describe-designation coding-system 0) 112 (princ (coding-system-property cs prop))
113 (describe-designation coding-system 1) 113 (terpri)))
114 (describe-designation coding-system 2) 114 ;;(princ " short: ") (princ (coding-system-short))
115 (describe-designation coding-system 3) 115 ;;(princ (if (aref flags 4) "ShortForm" "LongForm"))
116 (princ "Other Form: \n") 116 ;;(if (aref flags 5) (princ ", ASCII@EOL"))
117 (princ (if (aref flags 4) "ShortForm" "LongForm")) 117 ;;(if (aref flags 6) (princ ", ASCII@CNTL"))
118 (if (aref flags 5) (princ ", ASCII@EOL")) 118 ;;(princ (if (coding-system-seven cs) ", 7bit" ", 8bit"))
119 (if (aref flags 6) (princ ", ASCII@CNTL")) 119 ;;(if (aref flags 8) (princ ", UseLockingShift"))
120 (princ (if (aref flags 7) ", 7bit" ", 8bit")) 120 ;;(if (aref flags 9) (princ ", UseRoman"))
121 (if (aref flags 8) (princ ", UseLockingShift")) 121 ;;(if (aref flags 10) (princ ", UseOldJIS"))
122 (if (aref flags 9) (princ ", UseRoman")) 122 ;;(if (aref flags 11) (princ ", No ISO6429"))
123 (if (aref flags 10) (princ ", UseOldJIS")) 123 ;;(terpri))
124 (if (aref flags 11) (princ ", No ISO6429")) 124
125 (princ ".\n")) 125 ('big5
126 ((eq type 'big5) 126 ;;(princ (if flags "Big-ETen\n" "Big-HKU\n")))
127 (princ (if flags "Big-ETen\n" "Big-HKU\n"))) 127 ))
128 )) 128 (princ (format "\nEOL-Type: %s\n"
129 (princ "\nEOL-Type: ") 129 (case (coding-system-eol-type cs)
130 (let ((eol-type (coding-system-eol-type cs))) 130 ('nil "null (= LF)")
131 (cond ((null eol-type) 131 ('lf "LF")
132 (princ "null (= LF)\n")) 132 ('crlf "CRLF")
133 ((vectorp eol-type) 133 ('cr "CR")
134 (princ "Automatic selection from ") 134 (t "invalid"))))
135 (princ eol-type)
136 (princ "\n"))
137 ((eq eol-type 1) (princ "LF\n"))
138 ((eq eol-type 2) (princ "CRLF\n"))
139 ((eq eol-type 3) (princ "CR\n"))
140 (t (princ "invalid\n"))))
141 ))) 135 )))
142 136
143 ;;;###autoload 137 ;;;###autoload
144 (defun list-coding-system-briefly () 138 (defun list-coding-system-briefly ()
145 "Display coding-systems currently used with a brief format in mini-buffer." 139 "Display coding-systems currently used with a brief format in mini-buffer."