Changeset 5247
- Timestamp:
- Sep 23, 2006, 4:31:02 AM (18 years ago)
- File:
-
- 1 edited
-
trunk/ccl/level-1/l1-unicode.lisp (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/level-1/l1-unicode.lisp
r5228 r5247 81 81 ;; Code units and character codes less than this value map to themselves 82 82 (literal-char-code-limit 0) 83 84 ;; Function to translate all #\Return characters in a vector to #\Linefeed 85 (translate-cr-to-lf-function 'u8-translate-cr-to-lf) 86 87 ;; Function to translate all #\Linefeed characters in a vector to #\Return 88 (translate-lf-to-cr-function 'u8-translate-lf-to-cr) 83 89 ) 84 90 91 85 92 86 93 (defmethod print-object ((ce character-encoding) stream) … … 125 132 iso-8859-1-vector-encode 126 133 (lambda (char vector idx) 127 (declare (type (simple-array (unsigned-byte 8) (*)) vector)) 134 (declare (type (simple-array (unsigned-byte 8) (*)) vector) 135 (fixnum idx)) 128 136 (let* ((code (char-code char))) 129 137 (declare (type (mod #x110000) code)) … … 131 139 (< idx (the fixnum (length vector)))) 132 140 (setf (aref vector idx) code) 133 1))))141 (the fixnum (1+ idx)))))) 134 142 :vector-decode-function 135 143 (nfunction … … 193 201 ;;; the break is at #x80 instead of #xa0). 194 202 195 196 ;;; Later. 203 (defparameter *iso-8859-2-to-unicode* 204 #( 205 ;; #xa0 206 #\u+00a0 #\u+0104 #\u+02d8 #\u+0141 #\u+00a4 #\u+013d #\u+015a #\u+00a7 207 #\u+00a8 #\u+0160 #\u+015e #\u+0164 #\u+0179 #\u+00ad #\u+017d #\u+017b 208 ;; #xb0 209 #\u+00b0 #\u+0105 #\u+02db #\u+0142 #\u+00b4 #\u+013e #\u+015b #\u+02c7 210 #\u+00b8 #\u+0161 #\u+015f #\u+0165 #\u+017a #\u+02dd #\u+017e #\u+017c 211 ;; #xc0 212 #\u+0154 #\u+00c1 #\u+00c2 #\u+0102 #\u+00c4 #\u+0139 #\u+0106 #\u+00c7 213 #\u+010c #\u+00c9 #\u+0118 #\u+00cb #\u+011a #\u+00cd #\u+00ce #\u+010e 214 ;; #xd0 215 #\u+0110 #\u+0143 #\u+0147 #\u+00d3 #\u+00d4 #\u+0150 #\u+00d6 #\u+00d7 216 #\u+0158 #\u+016e #\u+00da #\u+0170 #\u+00dc #\u+00dd #\u+0162 #\u+00df 217 ;; #xe0 218 #\u+0155 #\u+00e1 #\u+00e2 #\u+0103 #\u+00e4 #\u+013a #\u+0107 #\u+00e7 219 #\u+010d #\u+00e9 #\u+0119 #\u+00eb #\u+011b #\u+00ed #\u+00ee #\u+010f 220 ;; #xf0 221 #\u+0111 #\u+0144 #\u+0148 #\u+00f3 #\u+00f4 #\u+0151 #\u+00f6 #\u+00f7 222 #\u+0159 #\u+016f #\u+00fa #\u+0171 #\u+00fc #\u+00fd #\u+0163 #\u+02d9 223 )) 224 225 (defparameter *unicode-00a0-0180-to-iso8859-2* 226 #( 227 #xa0 nil nil nil #xa4 nil nil #xa7 ; #xa0-#xa7 228 #xa8 nil nil nil nil #xad nil nil ; #xa8-#xaf 229 #xb0 nil nil nil #xb4 nil nil nil ; #xb0-#xb7 230 #xb8 nil nil nil nil nil nil nil ; #xb8-#xbf 231 nil #xc1 #xc2 nil #xc4 nil nil #xc7 ; #xc0-#xc7 232 nil #xc9 nil #xcb nil #xcd #xce nil ; #xc8-#xcf 233 nil nil nil #xd3 #xd4 nil #xd6 #xd7 ; #xd0-#xd7 234 nil nil #xda nil #xdc #xdd nil #xdf ; #xd8-#xdf 235 nil #xe1 #xe2 nil #xe4 nil nil #xe7 ; #xe0-#xe7 236 nil #xe9 nil #xeb nil #xed #xee nil ; #xe8-#xef 237 nil nil nil #xf3 #xf4 nil #xf6 #xf7 ; #xf0-#xf7 238 nil nil #xfa nil #xfc #xfd nil nil ; #xf8-#xff 239 ;; #x0100 240 nil nil #xc3 #xe3 #xa1 #xb1 #xc6 #xe6 ; #x100-#x107 241 nil nil nil nil #xc8 #xe8 #xcf #xef ; #x108-#x10f 242 #xd0 #xf0 nil nil nil nil nil nil ; #x110-#x117 243 #xca #xea #xcc #xec nil nil nil nil ; #x118-#x11f 244 nil nil nil nil nil nil nil nil ; #x120-#x127 245 nil nil nil nil nil nil nil nil ; #x128-#x12f 246 nil nil nil nil nil nil nil nil ; #x130-#x137 247 nil #xc5 #xe5 nil nil #xa5 #xb5 nil ; #x138-#x13f 248 nil #xa3 #xb3 #xd1 #xf1 nil nil #xd2 ; #x140-#x147 249 #xf2 nil nil nil nil nil nil nil ; #x148-#x14f 250 #xd5 #xf5 nil nil #xc0 #xe0 nil nil ; #x150-#x157 251 #xd8 #xf8 #xa6 #xb6 nil nil #xaa #xba ; #x158-#x15f 252 #xa9 #xb9 #xde #xfe #xab #xbb nil nil ; #x160-#x167 253 nil nil nil nil nil nil #xd9 #xf9 ; #x168-#x16f 254 #xdb #xfb nil nil nil nil nil nil ; #x170-#x177 255 nil #xac #xbc #xaf #xbf #xae #xbe nil ; #x178-#x17f 256 )) 257 258 (defparameter *unicode-00c0-00e0-to-iso8859-2* 259 #( 260 nil nil nil nil nil nil nil #xb7 ; #xc0-#xc7 261 nil nil nil nil nil nil nil nil ; #xc8-#xcf 262 nil nil nil nil nil nil nil nil ; #xd0-#xd7 263 #xa2 #xff nil #xb2 nil #xbd nil nil ; #xd8-#xdf 264 )) 265 266 (define-character-encoding :iso-8859-2 267 :stream-encode-function 268 (nfunction 269 iso-8859-2-stream-encode 270 (lambda (char write-function stream) 271 (let* ((code (char-code char)) 272 (c2 (cond ((< code #xa0) code) 273 ((< code #x180) 274 (svref *unicode-00a0-0180-to-iso8859-2* 275 (the fixnum (- code #xa0)))) 276 ((and (>= code #x2c0) (< code #x2e0)) 277 (svref *unicode-00c0-00e0-to-iso8859-2* 278 (the fixnum (- code #x2c0))))))) 279 280 (declare (type (mod #x110000) code)) 281 (when c2 282 (funcall write-function stream code) 283 1)))) 284 :stream-decode-function 285 (nfunction 286 iso-8859-2-stream-decode 287 (lambda (1st-unit next-unit-function stream) 288 (declare (ignore next-unit-function stream) 289 (type (unsigned-byte 8) 1st-unit)) 290 (if (< 1st-unit #xa0) 291 (code-char 1st-unit) 292 (svref *iso-8859-2-to-unicode* (the fixnum (- 1st-unit #xa0)))))) 293 :vector-encode-function 294 (nfunction 295 iso-8859-2-vector-encode 296 (lambda (char vector idx) 297 (declare (type (simple-array (unsigned-byte 8) (*)) vector) 298 (fixnum idx)) 299 (let* ((code (char-code char)) 300 (c2 (when (< idx (the fixnum (length vector))) 301 (cond ((< code #xa0) code) 302 ((< code #x180) 303 (svref *unicode-00a0-0180-to-iso8859-2* 304 (the fixnum (- code #xa0)))) 305 ((and (>= code #x2c0) (< code #x2e0)) 306 (svref *unicode-00c0-00e0-to-iso8859-2* 307 (the fixnum (- code #x2c0)))))))) 308 (declare (type (mod #x110000) code)) 309 (when c2 310 (setf (aref vector idx) c2) 311 (the fixnum (1+ idx)))))) 312 :vector-decode-function 313 (nfunction 314 iso-8859-2-vector-decode 315 (lambda (vector idx) 316 (declare (type (simple-array (unsigned-byte 8) (*)) vector)) 317 (if (< idx (length vector)) 318 (let* ((1st-unit (aref vector idx))) 319 (declare (type (unsigned-byte 8) 1st-unit)) 320 (values 321 (if (< 1st-unit #xa0) 322 (code-char 1st-unit) 323 (svref *iso-8859-2-to-unicode* (the fixnum (- 1st-unit #xa0)))) 324 (the fixnum (1+ (the fixnum idx))))) 325 (values nil idx)))) 326 :memory-encode-function 327 (nfunction 328 iso-8859-2-memory-encode 329 (lambda (char pointer idx) 330 (let* ((code (char-code char)) 331 (c2 (cond ((< code #xa0) code) 332 ((< code #x180) 333 (svref *unicode-00a0-0180-to-iso8859-2* 334 (the fixnum (- code #xa0)))) 335 ((and (>= code #x2c0) (< code #x2e0)) 336 (svref *unicode-00c0-00e0-to-iso8859-2* 337 (the fixnum (- code #x2c0))))))) 338 (declare (type (mod #x110000) code)) 339 (when c2 340 (setf (%get-unsigned-byte pointer idx) c2) 341 (1+ idx))))) 342 :memory-decode-function 343 (nfunction 344 iso-8859-2-memory-decode 345 (lambda (pointer idx) 346 (let* ((1st-unit (%get-unsigned-byte pointer idx))) 347 (declare (type (unsigned-byte 8) 1st-unit)) 348 (values (if (< 1st-unit #xa0) 349 (code-char 1st-unit) 350 (svref *iso-8859-2-to-unicode* (the fixnum (- 1st-unit #xa0)))) 351 (the fixnum (1+ (the fixnum idx))))))) 352 :units-in-string-function 353 (nfunction 354 iso-8859-2-units-in-string 355 (lambda (string &optional (start 0) (end (length string))) 356 (when (>= end start) 357 (do* ((i start (1+ i))) 358 ((= i end) (- end start)) 359 (let* ((code (char-code (schar string i))) 360 (c2 (cond ((< code #xa0) code) 361 ((< code #x180) 362 (svref *unicode-00a0-0180-to-iso8859-2* 363 (the fixnum (- code #xa0)))) 364 ((and (>= code #x2c0) (< code #x2e0)) 365 (svref *unicode-00c0-00e0-to-iso8859-2* 366 (the fixnum (- code #x2c0))))))) 367 (declare (type (mod #x110000) code)) 368 (unless c2 (return nil))))))) 369 :length-of-vector-encoding-function 370 (nfunction 371 iso-8859-2-length-of-vector-encoding 372 (lambda (vector &optional (start 0) (end (length vector))) 373 (when (>= end start) 374 (- end start)))) 375 :length-of-memory-encoding-function 376 (nfunction 377 iso-8859-2-length-of-memory-encoding 378 (lambda (pointer nunits &optional start) 379 (declare (ignore pointer start)) 380 nunits)) 381 :literal-char-code-limit #xa0 382 ) 383 384 (defparameter *iso-8859-3-to-unicode* 385 #( 386 ;; #xa0 387 #\u+00a0 #\u+0126 #\u+02d8 #\u+00a3 #\u+00a4 #\u+fffd #\u+0124 #\u+00a7 388 #\u+00a8 #\u+0130 #\u+015e #\u+011e #\u+0134 #\u+00ad #\u+fffd #\u+017b 389 ;; #xb0 390 #\u+00b0 #\u+0127 #\u+00b2 #\u+00b3 #\u+00b4 #\u+00b5 #\u+0125 #\u+00b7 391 #\u+00b8 #\u+0131 #\u+015f #\u+011f #\u+0135 #\u+00bd #\u+fffd #\u+017c 392 ;; #xc0 393 #\u+00c0 #\u+00c1 #\u+00c2 #\u+fffd #\u+00c4 #\u+010a #\u+0108 #\u+00c7 394 #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf 395 ;; #xd0 396 #\u+fffd #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+0120 #\u+00d6 #\u+00d7 397 #\u+011c #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+016c #\u+015c #\u+00df 398 ;; #xe0 399 #\u+00e0 #\u+00e1 #\u+00e2 #\u+fffd #\u+00e4 #\u+010b #\u+0109 #\u+00e7 400 #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef 401 ;; #xf0 402 #\u+fffd #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+0121 #\u+00f6 #\u+00f7 403 #\u+011d #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+016d #\u+015d #\u+02d9 404 )) 405 406 (defparameter *unicode-a0-100-to-iso8859-3* 407 #( 408 #xa0 nil nil #xa3 #xa4 nil nil #xa7 ; #xa0-#xa7 409 #xa8 nil nil nil nil #xad nil nil ; #xa8-#xaf 410 #xb0 nil #xb2 #xb3 #xb4 #xb5 nil #xb7 ; #xb0-#xb7 411 #xb8 nil nil nil nil #xbd nil nil ; #xb8-#xbf 412 #xc0 #xc1 #xc2 nil #xc4 nil nil #xc7 ; #xc0-#xc7 413 #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf 414 nil #xd1 #xd2 #xd3 #xd4 nil #xd6 #xd7 ; #xd0-#xd7 415 nil #xd9 #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf 416 #xe0 #xe1 #xe2 nil #xe4 nil nil #xe7 ; #xe0-#xe7 417 #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef 418 nil #xf1 #xf2 #xf3 #xf4 nil #xf6 #xf7 ; #xf0-#xf7 419 nil #xf9 #xfa #xfb #xfc nil nil nil ; #xf8-#xff 420 )) 421 422 (defparameter *unicode-108-180-to-iso8859-3* 423 #( 424 #xc6 #xe6 #xc5 #xe5 #x00 #x00 #x00 #x00 ; #x108-#x10f 425 nil nil nil nil nil nil nil nil ; #x110-#x117 426 nil nil nil nil #xd8 #xf8 #xab #xbb ; #x118-#x11f 427 #xd5 #xf5 nil nil #xa6 #xb6 #xa1 #xb1 ; #x120-#x127 428 nil nil nil nil nil nil nil nil ; #x128-#x12f 429 #xa9 #xb9 nil nil #xac #xbc nil nil ; #x130-#x137 430 nil nil nil nil nil nil nil nil ; #x138-#x13f 431 nil nil nil nil nil nil nil nil ; #x140-#x147 432 nil nil nil nil nil nil nil nil ; #x148-#x14f 433 nil nil nil nil nil nil nil nil ; #x150-#x157 434 nil nil nil nil #xde #xfe #xaa #xba ; #x158-#x15f 435 nil nil nil nil nil nil nil nil ; #x160-#x167 436 nil nil nil nil #xdd #xfd nil nil ; #x168-#x16f 437 nil nil nil nil nil nil nil nil ; #x170-#x177 438 nil nil nil #xaf #xbf nil nil nil ; #x178-#x17f 439 )) 440 441 (defparameter *unicode-2d8-2e0-to-iso8859-3* 442 #( 443 #xa2 #xff nil nil nil nil nil nil ; #x2d8-#x2df 444 )) 445 446 447 448 (define-character-encoding :iso-8859-3 449 :stream-encode-function 450 (nfunction 451 iso-8859-3-stream-encode 452 (lambda (char write-function stream) 453 (let* ((code (char-code char)) 454 (c2 (cond ((< code #xa0) code) 455 ((< code #x100) 456 (svref *unicode-a0-100-to-iso8859-3* 457 (the fixnum (- code #xa0)))) 458 ((and (>= code #x108) (< code #x180)) 459 (svref *unicode-108-180-to-iso8859-3* 460 (the fixnum (- code #x108)))) 461 ((and (>= code #x2d8) (< code #x2e0)) 462 (svref *unicode-2d8-2e0-to-iso8859-3* 463 (the fixnum (- code #x2d8))))))) 464 465 (declare (type (mod #x110000) code)) 466 (when c2 467 (funcall write-function stream code) 468 1)))) 469 :stream-decode-function 470 (nfunction 471 iso-8859-3-stream-decode 472 (lambda (1st-unit next-unit-function stream) 473 (declare (ignore next-unit-function stream) 474 (type (unsigned-byte 8) 1st-unit)) 475 (if (< 1st-unit #xa0) 476 (code-char 1st-unit) 477 (svref *iso-8859-3-to-unicode* (the fixnum (- 1st-unit #xa0)))))) 478 :vector-encode-function 479 (nfunction 480 iso-8859-3-vector-encode 481 (lambda (char vector idx) 482 (declare (type (simple-array (unsigned-byte 8) (*)) vector) 483 (fixnum idx)) 484 (let* ((code (char-code char)) 485 (c2 (when (< idx (the fixnum (length vector))) 486 (cond ((< code #xa0) code) 487 ((< code #x100) 488 (svref *unicode-a0-100-to-iso8859-3* 489 (the fixnum (- code #xa0)))) 490 ((and (>= code #x108) (< code #x180)) 491 (svref *unicode-108-180-to-iso8859-3* 492 (the fixnum (- code #x108)))) 493 ((and (>= code #x2d8) (< code #x2e0)) 494 (svref *unicode-2d8-2e0-to-iso8859-3* 495 (the fixnum (- code #x2d8)))))))) 496 (declare (type (mod #x110000) code)) 497 (when c2 498 (setf (aref vector idx) c2) 499 (the fixnum (1+ idx)))))) 500 :vector-decode-function 501 (nfunction 502 iso-8859-3-vector-decode 503 (lambda (vector idx) 504 (declare (type (simple-array (unsigned-byte 8) (*)) vector)) 505 (if (< idx (length vector)) 506 (let* ((1st-unit (aref vector idx))) 507 (declare (type (unsigned-byte 8) 1st-unit)) 508 (values 509 (if (< 1st-unit #xa0) 510 (code-char 1st-unit) 511 (svref *iso-8859-3-to-unicode* (the fixnum (- 1st-unit #xa0)))) 512 (the fixnum (1+ (the fixnum idx))))) 513 (values nil idx)))) 514 :memory-encode-function 515 (nfunction 516 iso-8859-3-memory-encode 517 (lambda (char pointer idx) 518 (let* ((code (char-code char)) 519 (c2 (cond ((< code #xa0) code) 520 ((< code #x100) 521 (svref *unicode-a0-100-to-iso8859-3* 522 (the fixnum (- code #xa0)))) 523 ((and (>= code #x108) (< code #x180)) 524 (svref *unicode-108-180-to-iso8859-3* 525 (the fixnum (- code #x108)))) 526 ((and (>= code #x2d8) (< code #x2e0)) 527 (svref *unicode-2d8-2e0-to-iso8859-3* 528 (the fixnum (- code #x2d8))))))) 529 (declare (type (mod #x110000) code)) 530 (when c2 531 (setf (%get-unsigned-byte pointer idx) c2) 532 (1+ idx))))) 533 :memory-decode-function 534 (nfunction 535 iso-8859-3-memory-decode 536 (lambda (pointer idx) 537 (let* ((1st-unit (%get-unsigned-byte pointer idx))) 538 (declare (type (unsigned-byte 8) 1st-unit)) 539 (values (if (< 1st-unit #xa0) 540 (code-char 1st-unit) 541 (svref *iso-8859-3-to-unicode* (the fixnum (- 1st-unit #xa0)))) 542 (the fixnum (1+ (the fixnum idx))))))) 543 :units-in-string-function 544 (nfunction 545 iso-8859-1-units-in-string 546 (lambda (string &optional (start 0) (end (length string))) 547 (when (>= end start) 548 (do* ((i start (1+ i))) 549 ((= i end) (- end start)) 550 (let* ((code (char-code (schar string i))) 551 (c2 (cond ((< code #xa0) code) 552 ((< code #x100) 553 (svref *unicode-a0-100-to-iso8859-3* 554 (the fixnum (- code #xa0)))) 555 ((and (>= code #x108) (< code #x180)) 556 (svref *unicode-108-180-to-iso8859-3* 557 (the fixnum (- code #x108)))) 558 ((and (>= code #x2d8) (< code #x2e0)) 559 (svref *unicode-2d8-2e0-to-iso8859-3* 560 (the fixnum (- code #x2d8))))))) 561 (declare (type (mod #x110000) code)) 562 (unless c2 (return nil))))))) 563 :length-of-vector-encoding-function 564 (nfunction 565 iso-8859-3-length-of-vector-encoding 566 (lambda (vector &optional (start 0) (end (length vector))) 567 (when (>= end start) 568 (- end start)))) 569 :length-of-memory-encoding-function 570 (nfunction 571 iso-8859-3-length-of-memory-encoding 572 (lambda (pointer nunits &optional start) 573 (declare (ignore pointer start)) 574 nunits)) 575 :literal-char-code-limit #xa0 576 ) 577 578 579 (defparameter *iso-8859-4-to-unicode* 580 #( 581 ;; #xa0 582 #\u+00a0 #\u+0104 #\u+0138 #\u+0156 #\u+00a4 #\u+0128 #\u+013b #\u+00a7 583 #\u+00a8 #\u+0160 #\u+0112 #\u+0122 #\u+0166 #\u+00ad #\u+017d #\u+00af 584 ;; #xb0 585 #\u+00b0 #\u+0105 #\u+02db #\u+0157 #\u+00b4 #\u+0129 #\u+013c #\u+02c7 586 #\u+00b8 #\u+0161 #\u+0113 #\u+0123 #\u+0167 #\u+014a #\u+017e #\u+014b 587 ;; #xc0 588 #\u+0100 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+012e 589 #\u+010c #\u+00c9 #\u+0118 #\u+00cb #\u+0116 #\u+00cd #\u+00ce #\u+012a 590 ;; #xd0 591 #\u+0110 #\u+0145 #\u+014c #\u+0136 #\u+00d4 #\u+00d5 #\u+00d6 #\u+00d7 592 #\u+00d8 #\u+0172 #\u+00da #\u+00db #\u+00dc #\u+0168 #\u+016a #\u+00df 593 ;; #xe0 594 #\u+0101 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+012f 595 #\u+010d #\u+00e9 #\u+0119 #\u+00eb #\u+0117 #\u+00ed #\u+00ee #\u+012b 596 ;; #xf0 597 #\u+0111 #\u+0146 #\u+014d #\u+0137 #\u+00f4 #\u+00f5 #\u+00f6 #\u+00f7 598 #\u+00f8 #\u+0173 #\u+00fa #\u+00fb #\u+00fc #\u+0169 #\u+016b #\u+02d9 599 )) 600 601 602 (defparameter *unicode-a0-180-to-iso8859-4* 603 #( 604 #xa0 nil nil nil #xa4 nil nil #xa7 ; #xa0-#xa7 605 #xa8 nil nil nil nil #xad nil #xaf ; #xa8-#xaf 606 #xb0 nil nil nil #xb4 nil nil nil ; #xb0-#xb7 607 #xb8 nil nil nil nil nil nil nil ; #xb8-#xbf 608 nil #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 nil ; #xc0-#xc7 609 nil #xc9 nil #xcb nil #xcd #xce nil ; #xc8-#xcf 610 nil nil nil nil #xd4 #xd5 #xd6 #xd7 ; #xd0-#xd7 611 #xd8 nil #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf 612 nil #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 nil ; #xe0-#xe7 613 nil #xe9 nil #xeb nil #xed #xee nil ; #xe8-#xef 614 nil nil nil nil #xf4 #xf5 #xf6 #xf7 ; #xf0-#xf7 615 #xf8 nil #xfa #xfb #xfc nil nil nil ; #xf8-#xff 616 #xc0 #xe0 nil nil #xa1 #xb1 nil nil ; #x100-#x107 617 nil nil nil nil #xc8 #xe8 nil nil ; #x108-#x10f 618 #xd0 #xf0 #xaa #xba nil nil #xcc #xec ; #x110-#x117 619 #xca #xea nil nil nil nil nil nil ; #x118-#x11f 620 nil nil #xab #xbb nil nil nil nil ; #x120-#x127 621 #xa5 #xb5 #xcf #xef nil nil #xc7 #xe7 ; #x128-#x12f 622 nil nil nil nil nil nil #xd3 #xf3 ; #x130-#x137 623 #xa2 nil nil #xa6 #xb6 nil nil nil ; #x138-#x13f 624 nil nil nil nil nil #xd1 #xf1 nil ; #x140-#x147 625 nil nil #xbd #xbf #xd2 #xf2 nil nil ; #x148-#x14f 626 nil nil nil nil nil nil #xa3 #xb3 ; #x150-#x157 627 nil nil nil nil nil nil nil nil ; #x158-#x15f 628 #xa9 #xb9 nil nil nil nil #xac #xbc ; #x160-#x167 629 #xdd #xfd #xde #xfe nil nil nil nil ; #x168-#x16f 630 nil nil #xd9 #xf9 nil nil nil nil ; #x170-#x177 631 nil nil nil nil nil #xae #xbe nil ; #x178-#x17f 632 )) 633 634 (defparameter *unicode-2c0-2e0-to-iso8859-4* 635 #( 636 nil nil nil nil nil nil nil #xb7 ; #x2c0-#x2c7 637 nil nil nil nil nil nil nil nil ; #x2c8-#x2cf 638 nil nil nil nil nil nil nil nil ; #x2d0-#x2d7 639 nil #xff nil #xb2 nil nil nil nil ; #x2d8-#x2df 640 )) 641 642 643 644 (define-character-encoding :iso-8859-4 645 :stream-encode-function 646 (nfunction 647 iso-8859-4-stream-encode 648 (lambda (char write-function stream) 649 (let* ((code (char-code char)) 650 (c2 (cond ((< code #xa0) code) 651 ((< code #x180) 652 (svref *unicode-a0-180-to-iso8859-4* 653 (the fixnum (- code #xa0)))) 654 ((and (>= code #x2d8) (< code #x2e0)) 655 (svref *unicode-2c0-2e0-to-iso8859-4* 656 (the fixnum (- code #x2c0))))))) 657 658 (declare (type (mod #x110000) code)) 659 (when c2 660 (funcall write-function stream code) 661 1)))) 662 :stream-decode-function 663 (nfunction 664 iso-8859-4-stream-decode 665 (lambda (1st-unit next-unit-function stream) 666 (declare (ignore next-unit-function stream) 667 (type (unsigned-byte 8) 1st-unit)) 668 (if (< 1st-unit #xa0) 669 (code-char 1st-unit) 670 (svref *iso-8859-4-to-unicode* (the fixnum (- 1st-unit #xa0)))))) 671 :vector-encode-function 672 (nfunction 673 iso-8859-4-vector-encode 674 (lambda (char vector idx) 675 (declare (type (simple-array (unsigned-byte 8) (*)) vector) 676 (fixnum idx)) 677 (let* ((code (char-code char)) 678 (c2 (when (< idx (the fixnum (length vector))) 679 (cond ((< code #xa0) code) 680 ((< code #x180) 681 (svref *unicode-a0-180-to-iso8859-4* 682 (the fixnum (- code #xa0)))) 683 ((and (>= code #x2d8) (< code #x2e0)) 684 (svref *unicode-2c0-2e0-to-iso8859-4* 685 (the fixnum (- code #x2c0)))))))) 686 (declare (type (mod #x110000) code)) 687 (when c2 688 (setf (aref vector idx) c2) 689 (the fixnum (1+ idx)))))) 690 :vector-decode-function 691 (nfunction 692 iso-8859-4-vector-decode 693 (lambda (vector idx) 694 (declare (type (simple-array (unsigned-byte 8) (*)) vector)) 695 (if (< idx (length vector)) 696 (let* ((1st-unit (aref vector idx))) 697 (declare (type (unsigned-byte 8) 1st-unit)) 698 (values 699 (if (< 1st-unit #xa0) 700 (code-char 1st-unit) 701 (svref *iso-8859-4-to-unicode* (the fixnum (- 1st-unit #xa0)))) 702 (the fixnum (1+ (the fixnum idx))))) 703 (values nil idx)))) 704 :memory-encode-function 705 (nfunction 706 iso-8859-4-memory-encode 707 (lambda (char pointer idx) 708 (let* ((code (char-code char)) 709 (c2 (cond ((< code #xa0) code) 710 ((< code #x180) 711 (svref *unicode-a0-180-to-iso8859-4* 712 (the fixnum (- code #xa0)))) 713 ((and (>= code #x2d8) (< code #x2e0)) 714 (svref *unicode-2c0-2e0-to-iso8859-4* 715 (the fixnum (- code #x2c0))))))) 716 (declare (type (mod #x110000) code)) 717 (when c2 718 (setf (%get-unsigned-byte pointer idx) c2) 719 (1+ idx))))) 720 :memory-decode-function 721 (nfunction 722 iso-8859-4-memory-decode 723 (lambda (pointer idx) 724 (let* ((1st-unit (%get-unsigned-byte pointer idx))) 725 (declare (type (unsigned-byte 8) 1st-unit)) 726 (values (if (< 1st-unit #xa0) 727 (code-char 1st-unit) 728 (svref *iso-8859-4-to-unicode* (the fixnum (- 1st-unit #xa0)))) 729 (the fixnum (1+ (the fixnum idx))))))) 730 :units-in-string-function 731 (nfunction 732 iso-8859-1-units-in-string 733 (lambda (string &optional (start 0) (end (length string))) 734 (when (>= end start) 735 (do* ((i start (1+ i))) 736 ((= i end) (- end start)) 737 (let* ((code (char-code (schar string i))) 738 (c2 (cond ((< code #xa0) code) 739 ((< code #x180) 740 (svref *unicode-a0-180-to-iso8859-4* 741 (the fixnum (- code #xa0)))) 742 ((and (>= code #x2d8) (< code #x2e0)) 743 (svref *unicode-2c0-2e0-to-iso8859-4* 744 (the fixnum (- code #x2c0))))) )) 745 (declare (type (mod #x110000) code)) 746 (unless c2 (return nil))))))) 747 :length-of-vector-encoding-function 748 (nfunction 749 iso-8859-4-length-of-vector-encoding 750 (lambda (vector &optional (start 0) (end (length vector))) 751 (when (>= end start) 752 (- end start)))) 753 :length-of-memory-encoding-function 754 (nfunction 755 iso-8859-4-length-of-memory-encoding 756 (lambda (pointer nunits &optional start) 757 (declare (ignore pointer start)) 758 nunits)) 759 :literal-char-code-limit #xa0 760 ) 197 761 198 762 ;;; UTF-8. Decoding checks for malformed sequences; it might be faster (and
Note:
See TracChangeset
for help on using the changeset viewer.
