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
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
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.
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
30 ;; ----------------------------------------------------------------------------
31 ;; 1999-08-15 GB - ROD=, ROD-EQUAL
33 ;; MAKE-ROD, ROD-SUBSEQ
34 ;; CHAR-RUNE, RUNE-CHAR, ROD-STRING, STRING-ROD
36 ;; - Added rune reader
45 ;; Portable implementation of WHITE-SPACE-P with regard to the current
46 ;; read table -- this is bit tricky.
48 (defun rt-white-space-p (char)
49 (let ((stream (make-string-input-stream (string char
))))
50 (eq :eof
(peek-char t stream nil
:eof
))))
52 (defun read-rune-name (input)
53 ;; the first char is unconditionally read
54 (let ((char0 (read-char input t nil t
)))
55 (when (char= char0
#\\)
56 (setf char0
(read-char input t nil t
)))
57 (with-output-to-string (res)
58 (write-char char0 res
)
59 (do ((ch (peek-char nil input nil
:eof t
) (peek-char nil input nil
:eof t
)))
62 (multiple-value-bind (function non-terminating-p
) (get-macro-character ch
)
63 (and function
(not non-terminating-p
)))))
65 (read-char input
))))) ;consume this character
67 (defun iso-10646-char-code (char)
70 (defvar *rune-names
* (make-hash-table :test
#'equal
)
71 "Hashtable, which maps all known rune names to rune codes;
72 Names are stored in uppercase.")
74 (defun define-rune-name (name code
)
75 (setf (gethash (string-upcase name
) *rune-names
*) code
)
78 (defun lookup-rune-name (name)
79 (gethash (string-upcase name
) *rune-names
*))
81 (define-rune-name "null" #x0000
)
82 (define-rune-name "space" #x0020
)
83 (define-rune-name "newline" #x000A
)
84 (define-rune-name "return" #x000D
)
85 (define-rune-name "tab" #x0009
)
86 (define-rune-name "page" #x000C
)
89 (define-rune-name "euro" #x20AC
)
91 ;; ASCII control characters
92 (define-rune-name "nul" #x0000
) ;null
93 (define-rune-name "soh" #x0001
) ;start of header
94 (define-rune-name "stx" #x0002
) ;start of text
95 (define-rune-name "etx" #x0003
) ;end of text
96 (define-rune-name "eot" #x0004
) ;end of transmission
97 (define-rune-name "enq" #x0005
) ;
98 (define-rune-name "ack" #x0006
) ;acknowledge
99 (define-rune-name "bel" #x0007
) ;bell
100 (define-rune-name "bs" #x0008
) ;backspace
101 (define-rune-name "ht" #x0009
) ;horizontal tab
102 (define-rune-name "lf" #X000A
) ;line feed, new line
103 (define-rune-name "vt" #X000B
) ;vertical tab
104 (define-rune-name "ff" #x000C
) ;form feed
105 (define-rune-name "cr" #x000D
) ;carriage return
106 (define-rune-name "so" #x000E
) ;shift out
107 (define-rune-name "si" #x000F
) ;shift in
108 (define-rune-name "dle" #x0010
) ;device latch enable ?
109 (define-rune-name "dc1" #x0011
) ;device control 1
110 (define-rune-name "dc2" #x0012
) ;device control 2
111 (define-rune-name "dc3" #x0013
) ;device control 3
112 (define-rune-name "dc4" #x0014
) ;device control 4
113 (define-rune-name "nak" #x0015
) ;negative acknowledge
114 (define-rune-name "syn" #x0016
) ;
115 (define-rune-name "etb" #x0017
) ;
116 (define-rune-name "can" #x0018
) ;
117 (define-rune-name "em" #x0019
) ;end of message
118 (define-rune-name "sub" #x001A
) ;
119 (define-rune-name "esc" #x001B
) ;escape
120 (define-rune-name "fs" #x001C
) ;field separator ?
121 (define-rune-name "gs" #x001D
) ;group separator
122 (define-rune-name "rs" #x001E
) ;
123 (define-rune-name "us" #x001F
) ;
125 (define-rune-name "del" #x007F
) ;delete
128 (define-rune-name "nbsp" #x00A0
) ;non breakable space
129 (define-rune-name "shy" #x00AD
) ;soft hyphen
131 (defun rune-from-read-name (name)
133 (cond ((= (length name
) 1)
134 (iso-10646-char-code (char name
0)))
135 ((and (= (length name
) 2)
136 (char= (char name
0) #\\))
137 (iso-10646-char-code (char name
1)))
138 ((and (>= (length name
) 3)
139 (char-equal (char name
0) #\u
)
140 (char-equal (char name
1) #\
+)
141 (every (lambda (x) (digit-char-p x
16)) (subseq name
2)))
142 (parse-integer name
:start
2 :radix
16))
143 ((lookup-rune-name name
))
145 (error "Meaningless rune name ~S." name
)))))
147 (defun rune-reader (stream subchar arg
)
149 (values (rune-from-read-name (read-rune-name stream
))))
151 (set-dispatch-macro-character #\
# #\
/ 'rune-reader
)
155 (defun rod-reader (stream subchar arg
)
156 (declare (ignore arg
))
158 (with-output-to-string (bag)
159 (do ((c (read-char stream t nil t
)
160 (read-char stream t nil t
)))
163 (setf c
(read-char stream t nil t
))))
167 (defun rod-printer (stream rod
)
170 (loop for x across rod do
171 (cond ((or (rune= x
#.
(char-rune #\\))
172 (rune= x
#.
(char-rune #\")))
174 (princ (code-char x
) stream
))
175 ((< x char-code-limit
)
176 (princ (code-char x
) stream
))
178 (format stream
"\\u~4,'0X" x
))))
181 (set-dispatch-macro-character #\
# #\" 'rod-reader
)