191 lines
6.9 KiB
Common Lisp
191 lines
6.9 KiB
Common Lisp
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP; -*-
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Title: Unicode strings (called RODs)
|
|
;;; Created: 1999-05-25 22:29
|
|
;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
|
|
;;; License: GPL (See file COPYING for details).
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; (c) copyright 1998,1999 by Gilbert Baumann
|
|
|
|
;;; This program is free software; you can redistribute it and/or modify
|
|
;;; it under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 2 of the License, or
|
|
;;; (at your option) any later version.
|
|
;;;
|
|
;;; This program 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 General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with this program; if not, 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 :glisp)
|
|
|
|
;;;;
|
|
;;;; RUNE Reader
|
|
;;;;
|
|
|
|
;; Portable implementation of WHITE-SPACE-P with regard to the current
|
|
;; read table -- this is bit tricky.
|
|
|
|
(defun rt-white-space-p (char)
|
|
(let ((stream (make-string-input-stream (string char))))
|
|
(eq :eof (peek-char t stream nil :eof))))
|
|
|
|
(defun read-rune-name (input)
|
|
;; the first char is unconditionally read
|
|
(let ((char0 (read-char input t nil t)))
|
|
(when (char= char0 #\\)
|
|
(setf char0 (read-char input t nil t)))
|
|
(with-output-to-string (res)
|
|
(write-char char0 res)
|
|
(do ((ch (peek-char nil input nil :eof t) (peek-char nil input nil :eof t)))
|
|
((or (eq ch :eof)
|
|
(rt-white-space-p ch)
|
|
(multiple-value-bind (function non-terminating-p) (get-macro-character ch)
|
|
(and function (not non-terminating-p)))))
|
|
(write-char ch res)
|
|
(read-char input))))) ;consume this character
|
|
|
|
(defun iso-10646-char-code (char)
|
|
(char-code char))
|
|
|
|
(defvar *rune-names* (make-hash-table :test #'equal)
|
|
"Hashtable, which maps all known rune names to rune codes;
|
|
Names are stored in uppercase.")
|
|
|
|
(defun define-rune-name (name code)
|
|
(setf (gethash (string-upcase name) *rune-names*) code)
|
|
name)
|
|
|
|
(defun lookup-rune-name (name)
|
|
(gethash (string-upcase name) *rune-names*))
|
|
|
|
(define-rune-name "null" #x0000)
|
|
(define-rune-name "space" #x0020)
|
|
(define-rune-name "newline" #x000A)
|
|
(define-rune-name "return" #x000D)
|
|
(define-rune-name "tab" #x0009)
|
|
(define-rune-name "page" #x000C)
|
|
|
|
;; and just for fun:
|
|
(define-rune-name "euro" #x20AC)
|
|
|
|
;; ASCII control characters
|
|
(define-rune-name "nul" #x0000) ;null
|
|
(define-rune-name "soh" #x0001) ;start of header
|
|
(define-rune-name "stx" #x0002) ;start of text
|
|
(define-rune-name "etx" #x0003) ;end of text
|
|
(define-rune-name "eot" #x0004) ;end of transmission
|
|
(define-rune-name "enq" #x0005) ;
|
|
(define-rune-name "ack" #x0006) ;acknowledge
|
|
(define-rune-name "bel" #x0007) ;bell
|
|
(define-rune-name "bs" #x0008) ;backspace
|
|
(define-rune-name "ht" #x0009) ;horizontal tab
|
|
(define-rune-name "lf" #X000A) ;line feed, new line
|
|
(define-rune-name "vt" #X000B) ;vertical tab
|
|
(define-rune-name "ff" #x000C) ;form feed
|
|
(define-rune-name "cr" #x000D) ;carriage return
|
|
(define-rune-name "so" #x000E) ;shift out
|
|
(define-rune-name "si" #x000F) ;shift in
|
|
(define-rune-name "dle" #x0010) ;device latch enable ?
|
|
(define-rune-name "dc1" #x0011) ;device control 1
|
|
(define-rune-name "dc2" #x0012) ;device control 2
|
|
(define-rune-name "dc3" #x0013) ;device control 3
|
|
(define-rune-name "dc4" #x0014) ;device control 4
|
|
(define-rune-name "nak" #x0015) ;negative acknowledge
|
|
(define-rune-name "syn" #x0016) ;
|
|
(define-rune-name "etb" #x0017) ;
|
|
(define-rune-name "can" #x0018) ;
|
|
(define-rune-name "em" #x0019) ;end of message
|
|
(define-rune-name "sub" #x001A) ;
|
|
(define-rune-name "esc" #x001B) ;escape
|
|
(define-rune-name "fs" #x001C) ;field separator ?
|
|
(define-rune-name "gs" #x001D) ;group separator
|
|
(define-rune-name "rs" #x001E) ;
|
|
(define-rune-name "us" #x001F) ;
|
|
|
|
(define-rune-name "del" #x007F) ;delete
|
|
|
|
;; iso-latin
|
|
(define-rune-name "nbsp" #x00A0) ;non breakable space
|
|
(define-rune-name "shy" #x00AD) ;soft hyphen
|
|
|
|
(defun rune-from-read-name (name)
|
|
(cond ((= (length name) 1)
|
|
(iso-10646-char-code (char name 0)))
|
|
((and (= (length name) 2)
|
|
(char= (char name 0) #\\))
|
|
(iso-10646-char-code (char name 1)))
|
|
((and (>= (length name) 3)
|
|
(char-equal (char name 0) #\u)
|
|
(char-equal (char name 1) #\+)
|
|
(every (lambda (x) (digit-char-p x 16)) (subseq name 2)))
|
|
(parse-integer name :start 2 :radix 16))
|
|
((lookup-rune-name name))
|
|
(t
|
|
(error "Meaningless rune name ~S." name))))
|
|
|
|
(defun rune-reader (stream subchar arg)
|
|
subchar arg
|
|
(values (rune-from-read-name (read-rune-name stream))))
|
|
|
|
(set-dispatch-macro-character #\# #\/ 'rune-reader)
|
|
|
|
;;; ROD ext syntax
|
|
|
|
(defun rod-reader (stream subchar arg)
|
|
(declare (ignore arg))
|
|
(rod
|
|
(with-output-to-string (bag)
|
|
(do ((c (read-char stream t nil t)
|
|
(read-char stream t nil t)))
|
|
((char= c subchar))
|
|
(cond ((char= c #\\)
|
|
(setf c (read-char stream t nil t))))
|
|
(princ c bag)))))
|
|
|
|
(defun rod-printer (stream rod)
|
|
(princ #\# stream)
|
|
(princ #\" stream)
|
|
(loop for x across rod do
|
|
(cond ((or (rune= x #.(char-code #\\))
|
|
(rune= x #.(char-code #\")))
|
|
(princ #\\ stream)
|
|
(princ (code-char x) stream))
|
|
((< x char-code-limit)
|
|
(princ (code-char x) stream))
|
|
(t
|
|
(format stream "\\u~4,'0X" x))))
|
|
(princ #\" stream))
|
|
|
|
(set-pprint-dispatch '(satisfies really-rod-p) #'rod-printer)
|
|
|
|
(set-dispatch-macro-character #\# #\" 'rod-reader)
|
|
|
|
#||
|
|
(defun longish-array-p (arr)
|
|
(and (arrayp arr)
|
|
(> (array-total-size arr) 10)))
|
|
|
|
(set-pprint-dispatch '(satisfies longish-array-p)
|
|
#'(lambda (stream object)
|
|
(let ((*print-array* nil)
|
|
(*print-pretty* nil))
|
|
(prin1 object stream))))
|
|
||#
|