274 lines
8.8 KiB
Common Lisp
274 lines
8.8 KiB
Common Lisp
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RUNES; -*-
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Title: Unicode strings (called RODs)
|
|
;;; Created: 1999-05-25 22:29
|
|
;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
|
|
;;; License: LLGPL (See file COPYING for details).
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; (c) copyright 1998,1999 by Gilbert Baumann
|
|
|
|
;;; This code is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the version 2.1 of the GNU Lesser General Public
|
|
;;; License as published by the Free Software Foundation, as clarified
|
|
;;; by the "Preamble to the Gnu Lesser General Public License" found in
|
|
;;; the file COPYING.
|
|
;;;
|
|
;;; This code is distributed in the hope that it will be useful,
|
|
;;; but without any warranty; without even the implied warranty of
|
|
;;; merchantability or fitness for a particular purpose. See the GNU
|
|
;;; Lesser General Public License for more details.
|
|
;;;
|
|
;;; Version 2.1 of the GNU Lesser General Public License is in the file
|
|
;;; COPYING that was distributed with this file. If it is not present,
|
|
;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until
|
|
;;; superseded by a newer version) or write to the Free Software
|
|
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
|
|
;; Changes
|
|
;;
|
|
;; When Who What
|
|
;; ----------------------------------------------------------------------------
|
|
;; 1999-08-15 GB - ROD=, ROD-EQUAL
|
|
;; RUNE<=, RUNE>=
|
|
;; MAKE-ROD, ROD-SUBSEQ
|
|
;; CHAR-RUNE, RUNE-CHAR, ROD-STRING, STRING-ROD
|
|
;; new functions
|
|
;; - Added rune reader
|
|
;;
|
|
|
|
(in-package :runes)
|
|
|
|
(deftype rune () '(unsigned-byte 16))
|
|
(deftype rod () '(array rune (*)))
|
|
(deftype simple-rod () '(simple-array rune (*)))
|
|
|
|
(defsubst rune (rod index)
|
|
(aref rod index))
|
|
|
|
(defun (setf rune) (new rod index)
|
|
(setf (aref rod index) new))
|
|
|
|
(defsubst %rune (rod index)
|
|
(aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)))
|
|
|
|
(defsubst (setf %rune) (new rod index)
|
|
(setf (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)) new))
|
|
|
|
(defun rod-capitalize (rod)
|
|
(warn "~S is not implemented." 'rod-capitalize)
|
|
rod)
|
|
|
|
(defsubst code-rune (x) x)
|
|
(defsubst rune-code (x) x)
|
|
|
|
(defsubst rune= (x y)
|
|
(= x y))
|
|
|
|
(defun rune-downcase (rune)
|
|
(cond ((<= #x0041 rune #x005a) (+ rune #x20))
|
|
((= rune #x00d7) rune)
|
|
((<= #x00c0 rune #x00de) (+ rune #x20))
|
|
(t rune)))
|
|
|
|
(defsubst rune-upcase (rune)
|
|
(cond ((<= #x0061 rune #x007a) (- rune #x20))
|
|
((= rune #x00f7) rune)
|
|
((<= #x00e0 rune #x00fe) (- rune #x20))
|
|
(t rune)))
|
|
|
|
(defun rune-upper-case-letter-p (rune)
|
|
(or (<= #x0041 rune #x005a) (<= #x00c0 rune #x00de)))
|
|
|
|
(defun rune-lower-case-letter-p (rune)
|
|
(or (<= #x0061 rune #x007a) (<= #x00e0 rune #x00fe)
|
|
(= rune #x00d7)))
|
|
|
|
|
|
(defun rune-equal (x y)
|
|
(rune= (rune-upcase x) (rune-upcase y)))
|
|
|
|
(defun rod-downcase (rod)
|
|
;; FIXME
|
|
(register-rod
|
|
(map '(simple-array (unsigned-byte 16) (*)) #'rune-downcase rod)))
|
|
|
|
(defun rod-upcase (rod)
|
|
;; FIXME
|
|
(register-rod
|
|
(map '(simple-array (unsigned-byte 16) (*)) #'rune-upcase rod)))
|
|
|
|
(defsubst white-space-rune-p (char)
|
|
(or (= char 9) ;TAB
|
|
(= char 10) ;Linefeed
|
|
(= char 13) ;Carriage Return
|
|
(= char 32))) ;Space
|
|
|
|
(defsubst digit-rune-p (char &optional (radix 10))
|
|
(cond ((<= #.(char-code #\0) char #.(char-code #\9))
|
|
(and (< (- char #.(char-code #\0)) radix)
|
|
(- char #.(char-code #\0))))
|
|
((<= #.(char-code #\A) char #.(char-code #\Z))
|
|
(and (< (- char #.(char-code #\A) -10) radix)
|
|
(- char #.(char-code #\A) -10)))
|
|
((<= #.(char-code #\a) char #.(char-code #\z))
|
|
(and (< (- char #.(char-code #\a) -10) radix)
|
|
(- char #.(char-code #\a) -10))) ))
|
|
|
|
(defun rod (x)
|
|
(cond ((stringp x) (register-rod (map 'rod #'char-code x)))
|
|
((symbolp x) (rod (string x)))
|
|
((characterp x) (rod (string x)))
|
|
((vectorp x) (register-rod (coerce x 'rod)))
|
|
((integerp x) (register-rod (map 'rod #'identity (list x))))
|
|
(t (error "Cannot convert ~S to a ~S" x 'rod))))
|
|
|
|
(defun runep (x)
|
|
(and (integerp x)
|
|
(<= 0 x #xFFFF)))
|
|
|
|
(defun sloopy-rod-p (x)
|
|
(and (not (stringp x))
|
|
(vectorp x)
|
|
(every #'runep x)))
|
|
|
|
(defun rod= (x y)
|
|
(and (= (length x) (length y))
|
|
(dotimes (i (length x) t)
|
|
(unless (rune= (rune x i) (rune y i))
|
|
(return nil)))))
|
|
|
|
(defun rod-equal (x y)
|
|
(and (= (length x) (length y))
|
|
(dotimes (i (length x) t)
|
|
(unless (rune-equal (rune x i) (rune y i))
|
|
(return nil)))))
|
|
|
|
(defsubst make-rod (size)
|
|
(let ((res (make-array size :element-type 'rune)))
|
|
(register-rod res)
|
|
res))
|
|
|
|
(defun char-rune (char)
|
|
(code-rune (char-code char)))
|
|
|
|
(defun rune-char (rune &optional (default #\?))
|
|
#+CMU
|
|
(if (< rune 256) (code-char rune) default)
|
|
#-CMU
|
|
(or (code-char rune) default))
|
|
|
|
(defun rod-string (rod &optional (default-char #\?))
|
|
(map 'string (lambda (x) (rune-char x default-char)) rod))
|
|
|
|
(defun string-rod (string)
|
|
(let* ((n (length string))
|
|
(res (make-rod n)))
|
|
(dotimes (i n)
|
|
(setf (%rune res i) (char-rune (char string i))))
|
|
res))
|
|
|
|
;;;;
|
|
|
|
(defun rune<= (rune &rest more-runes)
|
|
(apply #'<= rune more-runes))
|
|
|
|
(defun rune>= (rune &rest more-runes)
|
|
(apply #'>= rune more-runes))
|
|
|
|
(defun rodp (object)
|
|
(typep object 'rod))
|
|
|
|
(defun really-rod-p (object)
|
|
(and (typep object 'rod)
|
|
(really-really-rod-p object)))
|
|
|
|
(defun rod-subseq (source start &optional (end (length source)))
|
|
(unless (rodp source)
|
|
(error "~S is not of type ~S." source 'rod))
|
|
(unless (and (typep start 'fixnum) (>= start 0))
|
|
(error "~S is not a non-negative fixnum." start))
|
|
(unless (and (typep end 'fixnum) (>= end start))
|
|
(error "END argument, ~S, is not a fixnum no less than START, ~S." end start))
|
|
(when (> start (length source))
|
|
(error "START argument, ~S, should be no greater than length of rod." start))
|
|
(when (> end (length source))
|
|
(error "END argument, ~S, should be no greater than length of rod." end))
|
|
(locally
|
|
(declare (type rod source)
|
|
(type fixnum start end))
|
|
(let ((res (make-rod (- end start))))
|
|
(declare (type rod res))
|
|
(do ((i (- (- end start) 1) (the fixnum (- i 1))))
|
|
((< i 0) res)
|
|
(declare (type fixnum i))
|
|
(setf (%rune res i) (%rune source (the fixnum (+ i start))))))))
|
|
|
|
(defun rod-subseq* (source start &optional (end (length source)))
|
|
(unless (and (typep start 'fixnum) (>= start 0))
|
|
(error "~S is not a non-negative fixnum." start))
|
|
(unless (and (typep end 'fixnum) (>= end start))
|
|
(error "END argument, ~S, is not a fixnum no less than START, ~S." end start))
|
|
(when (> start (length source))
|
|
(error "START argument, ~S, should be no greater than length of rod." start))
|
|
(when (> end (length source))
|
|
(error "END argument, ~S, should be no greater than length of rod." end))
|
|
(locally
|
|
(declare (type fixnum start end))
|
|
(let ((res (make-rod (- end start))))
|
|
(declare (type rod res))
|
|
(do ((i (- (- end start) 1) (the fixnum (- i 1))))
|
|
((< i 0) res)
|
|
(declare (type fixnum i))
|
|
(setf (%rune res i) (aref source (the fixnum (+ i start))))))))
|
|
|
|
;;; Support for telling ROD and arrays apart:
|
|
|
|
#+CMU
|
|
(progn
|
|
(defvar *rod-hash-table*
|
|
(make-array 5003 :initial-element nil)))
|
|
|
|
(defun register-rod (rod)
|
|
#+CMU
|
|
(unless (really-really-rod-p rod)
|
|
(push (ext:make-weak-pointer rod)
|
|
(aref *rod-hash-table* (mod (cl::pointer-hash rod)
|
|
(length *rod-hash-table*)))))
|
|
rod)
|
|
|
|
(defun really-really-rod-p (rod)
|
|
#+CMU
|
|
(find rod (aref *rod-hash-table* (mod (cl::pointer-hash rod)
|
|
(length *rod-hash-table*)))
|
|
:key #'ext:weak-pointer-value))
|
|
|
|
#+CMU
|
|
(progn
|
|
(defun rod-hash-table-rehash ()
|
|
(let* ((n 5003)
|
|
(new (make-array n :initial-element nil)))
|
|
(loop for bucket across *rod-hash-table* do
|
|
(loop for item in bucket do
|
|
(let ((v (ext:weak-pointer-value item)))
|
|
(when v
|
|
(push item (aref new (mod (cl::pointer-hash v) n)))))))
|
|
(setf *rod-hash-table* new)))
|
|
|
|
(defun rod-hash-after-gc-hook ()
|
|
;; hmm interesting question: should we rehash?
|
|
(rod-hash-table-rehash))
|
|
|
|
(pushnew 'rod-hash-after-gc-hook extensions:*after-gc-hooks*) )
|
|
|
|
(defun rod< (rod1 rod2)
|
|
(do ((i 0 (+ i 1)))
|
|
(nil)
|
|
(cond ((= i (length rod1))
|
|
(return t))
|
|
((= i (length rod2))
|
|
(return nil))
|
|
((< (aref rod1 i) (aref rod2 i))
|
|
(return t))
|
|
((> (aref rod1 i) (aref rod2 i))
|
|
(return nil)))))
|