Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/cl-babel-babel-20240610131823/src/enc-ebcdic.lisp

KindCoveredAll%
expression0102 0.0
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2
 ;;;
3
 ;;; enc-ebcdic.lisp --- Localized EBCDIC variant encodings.
4
 ;;;
5
 ;;; Copyright (C) 2007, Luis Oliveira  <loliveira@common-lisp.net>
6
 ;;; Copyright (C) 2020, Timo Myyrä  <timo.myyra@bittivirhe.fi>
7
 ;;;
8
 ;;; Permission is hereby granted, free of charge, to any person
9
 ;;; obtaining a copy of this software and associated documentation
10
 ;;; files (the "Software"), to deal in the Software without
11
 ;;; restriction, including without limitation the rights to use, copy,
12
 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
13
 ;;; of the Software, and to permit persons to whom the Software is
14
 ;;; furnished to do so, subject to the following conditions:
15
 ;;;
16
 ;;; The above copyright notice and this permission notice shall be
17
 ;;; included in all copies or substantial portions of the Software.
18
 ;;;
19
 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
20
 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
21
 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
22
 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
23
 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
24
 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
25
 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
26
 ;;; DEALINGS IN THE SOFTWARE.
27
 
28
 (in-package #:babel-encodings)
29
 
30
 (define-character-encoding :ebcdic-us
31
     "An alleged character set used on IBM dinosaurs."
32
   :aliases '(:ibm-037))
33
 
34
 (define-character-encoding :ebcdic-us-euro
35
     "An alleged character set used on IBM dinosaurs using Euro sign."
36
   :aliases '(:ibm-1140))
37
 
38
 (define-character-encoding :ebcdic-fi
39
     "A character set used on IBM mainframes in Finland/Sweden."
40
   :aliases '(:ibm-278))
41
 
42
 (define-character-encoding :ebcdic-fi-euro
43
     "A character set used on IBM mainframes in Finland/Sweden using Euro sign."
44
   :aliases '(:ibm-1143))
45
 
46
 (define-constant +ebcdic-decode-table+
47
   (make-array
48
    256 :element-type 'ub8 :initial-contents
49
    '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d
50
      #x0e #x0f #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f
51
      #x1c #x1d #x1e #x1f #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89
52
      #x8a #x8b #x8c #x05 #x06 #x07 #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04
53
      #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a #x20 #xa0 #xe2 #xe4 #xe0 #xe1
54
      #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c #x26 #xe9 #xea #xeb
55
      #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac #x2d #x2f
56
      #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f
57
      #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27
58
      #x3d #x22 #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb
59
      #xf0 #xfd #xfe #xb1 #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72
60
      #xaa #xba #xe6 #xb8 #xc6 #xa4 #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78
61
      #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae #x5e #xa3 #xa5 #xb7 #xa9 #xa7
62
      #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7 #x7b #x41 #x42 #x43
63
      #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5 #x7d #x4a
64
      #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff
65
      #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2
66
      #xd3 #xd5 #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb
67
      #xdc #xd9 #xda #x9f))
68
   :test #'equalp)
69
 
70
 (define-constant +ebcdic-encode-table+
71
   (loop with rt = (make-array 256 :element-type 'ub8 :initial-element 0)
72
         for code across +ebcdic-decode-table+ for i from 0 do
73
         (assert (= 0 (aref rt code)))
74
         (setf (aref rt code) i)
75
         finally (return rt))
76
   :test #'equalp)
77
 
78
 (define-unibyte-encoder :ebcdic-us (code)
79
   (if (>= code 256)
80
       (handle-error)
81
       (aref +ebcdic-encode-table+ code)))
82
 
83
 (define-unibyte-decoder :ebcdic-us (octet)
84
   (aref +ebcdic-decode-table+ octet))
85
 
86
 (define-unibyte-encoder :ebcdic-us-euro (code)
87
   (if (>= code 256)
88
       (handle-error)
89
       (if (= code #x20ac)
90
           #x9f
91
           (aref +ebcdic-encode-table+ code))))
92
 
93
 (define-unibyte-decoder :ebcdic-us-euro (octet)
94
   (if (= octet #x9f)
95
       #x20ac
96
       (aref +ebcdic-decode-table+ octet)))
97
 
98
 (defun ebcdic-fi-encoder (code)
99
   (or (case code
100
         (#x7b #x43)
101
         (#x7d #x47)
102
         (#xa7 #x4a)
103
         (#x21 #x4f)
104
         (#x60 #x51)
105
         (#xa4 #x5a)
106
         (#xc5 #x5b)
107
         (#x5e #x5f)
108
         (#x23 #x63)
109
         (#x24 #x67)
110
         (#xf6 #x6a)
111
         (#x5c #x71)
112
         (#xe9 #x79)
113
         (#xc4 #x7b)
114
         (#xd6 #x7c)
115
         (#x5d #x9f)
116
         (#xfc #xa1)
117
         (#xa2 #xb0)
118
         (#x5b #xb5)
119
         (#xac #xba)
120
         (#x7c #xbb)
121
         (#xe4 #xc0)
122
         (#xa6 #xcc)
123
         (#xe5 #xd0)
124
         (#x7e #xdc)
125
         (#xc9 #xe0)
126
         (#x40 #xec))
127
       (aref +ebcdic-encode-table+ code)))
128
 
129
 (defun ebcdic-fi-decoder (octet)
130
   (or (case octet
131
         (#x43 #x7b)
132
         (#x47 #x7d)
133
         (#x4a #xa7)
134
         (#x4f #x21)
135
         (#x51 #x60)
136
         (#x5a #xa4)
137
         (#x5b #xc5)
138
         (#x5f #x5e)
139
         (#x63 #x23)
140
         (#x67 #x24)
141
         (#x6a #xf6)
142
         (#x71 #x5c)
143
         (#x79 #xe9)
144
         (#x7b #xc4)
145
         (#x7c #xd6)
146
         (#x9f #x5d)
147
         (#xa1 #xfc)
148
         (#xb0 #xa2)
149
         (#xb5 #x5b)
150
         (#xba #xac)
151
         (#xbb #x7c)
152
         (#xc0 #xe4)
153
         (#xcc #xa6)
154
         (#xd0 #xe5)
155
         (#xdc #x7e)
156
         (#xe0 #xc9)
157
         (#xec #x40))
158
       (aref +ebcdic-decode-table+ octet)))
159
 
160
 (define-unibyte-encoder :ebcdic-fi (code)
161
   (if (>= code 256)
162
       (handle-error)
163
       (ebcdic-fi-encoder code)))
164
 
165
 (define-unibyte-decoder :ebcdic-fi (octet)
166
   (ebcdic-fi-decoder octet))
167
 
168
 (define-unibyte-encoder :ebcdic-fi-euro (code)
169
   (if (= code #x20ac)
170
       #x5a
171
       (if (>= code 256)
172
           (handle-error)
173
           (ebcdic-fi-encoder code))))
174
 
175
 (define-unibyte-decoder :ebcdic-fi-euro (octet)
176
   (if (= octet #x5a)
177
       #x20ac
178
       (ebcdic-fi-decoder octet)))
179
 �