/usr/share/common-lisp/source/closure-common/syntax.lisp is in cl-closure-common 20101107-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | ;;; -*- 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: Lisp-LGPL (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)
;;;;
;;;; 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)
(code-rune
(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)))))
#-rune-is-character
(defun rod-printer (stream rod)
(princ #\# stream)
(princ #\" stream)
(loop for x across rod do
(cond ((or (rune= x #.(char-rune #\\))
(rune= x #.(char-rune #\")))
(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-dispatch-macro-character #\# #\" 'rod-reader)
|