runes.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RUNES; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: Unicode strings (called RODs)
   4 ;;;   Created: 1999-05-25 22:29
   5 ;;;    Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
   6 ;;;   License: Lisp-LGPL (See file COPYING for details).
   7 ;;; ---------------------------------------------------------------------------
   8 ;;;  (c) copyright 1998,1999 by Gilbert Baumann
   9
  10 ;;; This code is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the version 2.1 of the GNU Lesser General Public
  12 ;;; License as published by the Free Software Foundation, as clarified
  13 ;;; by the "Preamble to the Gnu Lesser General Public License" found in
  14 ;;; the file COPYING.
  15 ;;;
  16 ;;; This code is distributed in the hope that it will be useful,
  17 ;;; but without any warranty; without even the implied warranty of
  18 ;;; merchantability or fitness for a particular purpose.  See the GNU
  19 ;;; Lesser General Public License for more details.
  20 ;;;
  21 ;;; Version 2.1 of the GNU Lesser General Public License is in the file
  22 ;;; COPYING that was distributed with this file.  If it is not present,
  23 ;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until
  24 ;;; superseded by a newer version) or write to the Free Software
  25 ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  26
  27 ;; Changes
  28 ;;
  29 ;;  When        Who     What
  30 ;; ----------------------------------------------------------------------------
  31 ;;  1999-08-15  GB      - ROD=, ROD-EQUAL
  32 ;;                        RUNE<=, RUNE>=
  33 ;;                        MAKE-ROD, ROD-SUBSEQ
  34 ;;                        CHAR-RUNE, RUNE-CHAR, ROD-STRING, STRING-ROD
  35 ;;                        new functions
  36 ;;                      - Added rune reader
  37 ;;
  38
  39 (in-package :runes)
  40
  41 (deftype rune () '(unsigned-byte 16))
  42 (deftype rod () '(array rune (*)))
  43 (deftype simple-rod () '(simple-array rune (*)))
  44
  45 (definline rune (rod index)
  46   (aref rod index))
  47
  48 (defun (setf rune) (new rod index)
  49   (setf (aref rod index) new))
  50
  51 (definline %rune (rod index)
  52   (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)))
  53
  54 (definline (setf %rune) (new rod index)
  55   (setf (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)) new))
  56
  57 (defun rod-capitalize (rod)
  58   (warn "~S is not implemented." 'rod-capitalize)
  59   rod)
  60
  61 (definline code-rune (x) x)
  62 (definline rune-code (x) x)
  63
  64 (definline rune= (x y)
  65   (= x y))
  66
  67 (defun rune-downcase (rune)
  68   (cond ((<= #x0041 rune #x005a) (+ rune #x20))
  69         ((= rune #x00d7) rune)
  70         ((<= #x00c0 rune #x00de) (+ rune #x20))
  71         (t rune)))
  72
  73 (definline rune-upcase (rune)
  74   (cond ((<= #x0061 rune #x007a) (- rune #x20))
  75         ((= rune #x00f7) rune)
  76         ((<= #x00e0 rune #x00fe) (- rune #x20))
  77         (t rune)))
  78
  79 (defun rune-upper-case-letter-p (rune)
  80   (or (<= #x0041 rune #x005a) (<= #x00c0 rune #x00de)))
  81
  82 (defun rune-lower-case-letter-p (rune)
  83   (or (<= #x0061 rune #x007a) (<= #x00e0 rune #x00fe)
  84       (= rune #x00d7)))
  85
  86
  87 (defun rune-equal (x y)
  88   (rune= (rune-upcase x) (rune-upcase y)))
  89
  90 (defun rod-downcase (rod)
  91   ;; FIXME
  92   (map '(simple-array (unsigned-byte 16) (*)) #'rune-downcase rod))
  93
  94 (defun rod-upcase (rod)
  95   ;; FIXME
  96   (map '(simple-array (unsigned-byte 16) (*)) #'rune-upcase rod))
  97
  98 (definline white-space-rune-p (char)
  99   (or (= char 9)        ;TAB
 100       (= char 10)       ;Linefeed
 101       (= char 13)       ;Carriage Return
 102       (= char 32)))     ;Space
 103
 104 (definline digit-rune-p (char &optional (radix 10))
 105   (cond ((<= #.(char-code #\0) char #.(char-code #\9))
 106          (and (< (- char #.(char-code #\0)) radix)
 107               (- char #.(char-code #\0))))
 108         ((<= #.(char-code #\A) char #.(char-code #\Z))
 109          (and (< (- char #.(char-code #\A) -10) radix)
 110               (- char #.(char-code #\A) -10)))
 111         ((<= #.(char-code #\a) char #.(char-code #\z))
 112          (and (< (- char #.(char-code #\a) -10) radix)
 113               (- char #.(char-code #\a) -10))) ))
 114
 115 (defun rod (x)
 116   (cond ((stringp x)    (map 'rod #'char-code x))
 117         ((symbolp x)    (rod (string x)))
 118         ((characterp x) (rod (string x)))
 119         ((vectorp x)    (coerce x 'rod))
 120         ((integerp x)   (map 'rod #'identity (list x)))
 121         (t              (error "Cannot convert ~S to a ~S" x 'rod))))
 122
 123 (defun runep (x)
 124   (and (integerp x)
 125        (<= 0 x #xFFFF)))
 126
 127 (defun sloopy-rod-p (x)
 128   (and (not (stringp x))
 129        (vectorp x)
 130        (every #'runep x)))
 131
 132 (defun rod= (x y)
 133   (and (= (length x) (length y))
 134        (dotimes (i (length x) t)
 135          (unless (rune= (rune x i) (rune y i))
 136            (return nil)))))
 137
 138 (defun rod-equal (x y)
 139   (and (= (length x) (length y))
 140        (dotimes (i (length x) t)
 141          (unless (rune-equal (rune x i) (rune y i))
 142            (return nil)))))
 143
 144 (definline make-rod (size)
 145   (make-array size :element-type 'rune))
 146
 147 (defun char-rune (char)
 148   (code-rune (char-code char)))
 149
 150 (defparameter *invalid-rune* nil ;;#\?
 151   "Rune to use as a replacement in RUNE-CHAR and ROD-STRING for runes not
 152    representable as characters.  If NIL, an error is signalled instead.")
 153
 154 (defun rune-char (rune &optional (default *invalid-rune*))
 155   (or (if (>= rune char-code-limit)
 156           default
 157           (or (code-char rune) default))
 158       (error "rune cannot be represented as a character: ~A" rune)))
 159
 160 (defun rod-string (rod &optional (default-char *invalid-rune*))
 161   (map 'string (lambda (x) (rune-char x default-char)) rod))
 162
 163 (defun string-rod (string)
 164   (let* ((n (length string))
 165          (res (make-rod n)))
 166     (dotimes (i n)
 167       (setf (%rune res i) (char-rune (char string i))))
 168     res))
 169
 170 ;;;;
 171
 172 (defun rune<= (rune &rest more-runes)
 173   (apply #'<= rune more-runes))
 174
 175 (defun rune>= (rune &rest more-runes)
 176   (apply #'>= rune more-runes))
 177
 178 (defun rodp (object)
 179   (typep object 'rod))
 180
 181 (defun rod-subseq (source start &optional (end (length source)))
 182   (unless (rodp source)
 183     (error "~S is not of type ~S." source 'rod))
 184   (unless (and (typep start 'fixnum) (>= start 0))
 185     (error "~S is not a non-negative fixnum." start))
 186   (unless (and (typep end 'fixnum) (>= end start))
 187     (error "END argument, ~S, is not a fixnum no less than START, ~S." end start))
 188   (when (> start (length source))
 189     (error "START argument, ~S, should be no greater than length of rod." start))
 190   (when (> end (length source))
 191     (error "END argument, ~S, should be no greater than length of rod." end))
 192   (locally
 193       (declare (type rod source)
 194                (type fixnum start end))
 195     (let ((res (make-rod (- end start))))
 196       (declare (type rod res))
 197       (do ((i (- (- end start) 1) (the fixnum (- i 1))))
 198           ((< i 0) res)
 199         (declare (type fixnum i))
 200         (setf (%rune res i) (%rune source (the fixnum (+ i start))))))))
 201
 202 (defun rod-subseq* (source start &optional (end (length source)))
 203   (unless (and (typep start 'fixnum) (>= start 0))
 204     (error "~S is not a non-negative fixnum." start))
 205   (unless (and (typep end 'fixnum) (>= end start))
 206     (error "END argument, ~S, is not a fixnum no less than START, ~S." end start))
 207   (when (> start (length source))
 208     (error "START argument, ~S, should be no greater than length of rod." start))
 209   (when (> end (length source))
 210     (error "END argument, ~S, should be no greater than length of rod." end))
 211   (locally
 212       (declare (type fixnum start end))
 213     (let ((res (make-rod (- end start))))
 214       (declare (type rod res))
 215       (do ((i (- (- end start) 1) (the fixnum (- i 1))))
 216           ((< i 0) res)
 217         (declare (type fixnum i))
 218         (setf (%rune res i) (aref source (the fixnum (+ i start))))))))
 219
 220 (defun rod< (rod1 rod2)
 221   (do ((i 0 (+ i 1)))
 222       (nil)
 223     (cond ((= i (length rod1))
 224            (return t))
 225           ((= i (length rod2))
 226            (return nil))
 227           ((< (aref rod1 i) (aref rod2 i))
 228            (return t))
 229           ((> (aref rod1 i) (aref rod2 i))
 230            (return nil)))))