3 (defmacro define-unibyte-permutation-mapper
(byte-code-name code-byte-name table
)
4 (let ((byte-to-code-table
5 (!make-specialized-array
256 '(unsigned-byte 8) table
))
7 (!make-specialized-array
256 '(unsigned-byte 8))))
9 (setf (aref code-to-byte-table
(aref byte-to-code-table i
)) i
))
11 (defun ,byte-code-name
(byte)
12 (declare (optimize speed
(safety 0))
13 (type (unsigned-byte 8) byte
))
14 (aref ,byte-to-code-table byte
))
15 (defun ,code-byte-name
(code)
16 (declare (optimize speed
(safety 0))
17 (type char-code code
))
20 (aref ,code-to-byte-table code
))))))
22 (define-unibyte-permutation-mapper ebcdic-us-
>code-mapper code-
>ebcdic-us-mapper
23 (#x00
#x01
#x02
#x03
#x9c
#x09
#x86
#x7f
#x97
#x8d
#x8e
#x0b
#x0c
#x0d
#x0e
#x0f
24 #x10
#x11
#x12
#x13
#x9d
#x85
#x08
#x87
#x18
#x19
#x92
#x8f
#x1c
#x1d
#x1e
#x1f
25 #x80
#x81
#x82
#x83
#x84
#x0a
#x17
#x1b
#x88
#x89
#x8a
#x8b
#x8c
#x05
#x06
#x07
26 #x90
#x91
#x16
#x93
#x94
#x95
#x96
#x04
#x98
#x99
#x9a
#x9b
#x14
#x15
#x9e
#x1a
27 #x20
#xa0
#xe2
#xe4
#xe0
#xe1
#xe3
#xe5
#xe7
#xf1
#xa2
#x2e
#x3c
#x28
#x2b
#x7c
28 #x26
#xe9
#xea
#xeb
#xe8
#xed
#xee
#xef
#xec
#xdf
#x21
#x24
#x2a
#x29
#x3b
#xac
29 #x2d
#x2f
#xc2
#xc4
#xc0
#xc1
#xc3
#xc5
#xc7
#xd1
#xa6
#x2c
#x25
#x5f
#x3e
#x3f
30 #xf8
#xc9
#xca
#xcb
#xc8
#xcd
#xce
#xcf
#xcc
#x60
#x3a
#x23
#x40
#x27
#x3d
#x22
31 #xd8
#x61
#x62
#x63
#x64
#x65
#x66
#x67
#x68
#x69
#xab
#xbb
#xf0
#xfd
#xfe
#xb1
32 #xb0
#x6a
#x6b
#x6c
#x6d
#x6e
#x6f
#x70
#x71
#x72
#xaa
#xba
#xe6
#xb8
#xc6
#xa4
33 #xb5
#x7e
#x73
#x74
#x75
#x76
#x77
#x78
#x79
#x7a
#xa1
#xbf
#xd0
#xdd
#xde
#xae
34 #x5e
#xa3
#xa5
#xb7
#xa9
#xa7
#xb6
#xbc
#xbd
#xbe
#x5b
#x5d
#xaf
#xa8
#xb4
#xd7
35 #x7b
#x41
#x42
#x43
#x44
#x45
#x46
#x47
#x48
#x49
#xad
#xf4
#xf6
#xf2
#xf3
#xf5
36 #x7d
#x4a
#x4b
#x4c
#x4d
#x4e
#x4f
#x50
#x51
#x52
#xb9
#xfb
#xfc
#xf9
#xfa
#xff
37 #x5c
#xf7
#x53
#x54
#x55
#x56
#x57
#x58
#x59
#x5a
#xb2
#xd4
#xd6
#xd2
#xd3
#xd5
38 #x30
#x31
#x32
#x33
#x34
#x35
#x36
#x37
#x38
#x39
#xb3
#xdb
#xdc
#xd9
#xda
#x9f
))
40 (declaim (inline get-ebcdic-us-bytes
))
41 (defun get-ebcdic-us-bytes (string pos
)
42 (declare (optimize speed
(safety 0))
43 (type simple-string string
)
44 (type array-range pos
))
45 (get-latin-bytes #'code-
>ebcdic-us-mapper
:ebcdic-us string pos
))
47 (defun string->ebcdic-us
(string sstart send null-padding
)
48 (declare (optimize speed
(safety 0))
49 (type simple-string string
)
50 (type array-range sstart send
))
51 (values (string->latin% string sstart send
#'get-ebcdic-us-bytes null-padding
)))
53 (defmacro define-ebcdic-us-
>string
* (accessor type
)
54 (declare (ignore type
))
55 (let ((name (make-od-name 'ebcdic-us-
>string
* accessor
)))
57 (defun ,name
(string sstart send array astart aend
)
58 (,(make-od-name 'latin-
>string
* accessor
) string sstart send array astart aend
#'ebcdic-us-
>code-mapper
)))))
59 (instantiate-octets-definition define-ebcdic-us-
>string
*)
61 (defmacro define-ebcdic-us-
>string
(accessor type
)
62 (declare (ignore type
))
63 `(defun ,(make-od-name 'ebcdic-us-
>string accessor
) (array astart aend
)
64 (,(make-od-name 'latin-
>string accessor
) array astart aend
#'ebcdic-us-
>code-mapper
)))
65 (instantiate-octets-definition define-ebcdic-us-
>string
)
67 (define-unibyte-external-format :ebcdic-us
(:cp037
:|cp037|
:ibm-037
:ibm037
)
68 (let ((ebcdic-us-byte (code->ebcdic-us-mapper bits
)))
70 (setf (sap-ref-8 sap tail
) ebcdic-us-byte
)
71 (external-format-encoding-error stream bits
)))
72 (code-char (ebcdic-us->code-mapper byte
))
73 ebcdic-us-
>string-aref
