syntax.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 ;;;;
  42 ;;;; RUNE Reader
  43 ;;;;
  44
  45 ;; Portable implementation of WHITE-SPACE-P with regard to the current
  46 ;; read table -- this is bit tricky.
  47
  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))))
  51
  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)))
  60           ((or (eq ch :eof)
  61                (rt-white-space-p ch)
  62                (multiple-value-bind (function non-terminating-p) (get-macro-character ch)
  63                  (and function (not non-terminating-p)))))
  64         (write-char ch res)
  65         (read-char input)))))           ;consume this character
  66
  67 (defun iso-10646-char-code (char)
  68   (char-code char))
  69
  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.")
  73
  74 (defun define-rune-name (name code)
  75   (setf (gethash (string-upcase name) *rune-names*) code)
  76   name)
  77
  78 (defun lookup-rune-name (name)
  79   (gethash (string-upcase name) *rune-names*))
  80
  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)
  87
  88 ;; and just for fun:
  89 (define-rune-name "euro"        #x20AC)
  90
  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)        ;
 124
 125 (define-rune-name "del"  #x007F)        ;delete
 126
 127 ;; iso-latin
 128 (define-rune-name "nbsp" #x00A0)        ;non breakable space
 129 (define-rune-name "shy"  #x00AD)        ;soft hyphen
 130
 131 (defun rune-from-read-name (name)
 132   (code-rune
 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))
 144      (t
 145        (error "Meaningless rune name ~S." name)))))
 146
 147 (defun rune-reader (stream subchar arg)
 148   subchar arg
 149   (values (rune-from-read-name (read-rune-name stream))))
 150
 151 (set-dispatch-macro-character #\# #\/ 'rune-reader)
 152
 153 ;;; ROD ext syntax
 154
 155 (defun rod-reader (stream subchar arg)
 156   (declare (ignore arg))
 157   (rod
 158    (with-output-to-string (bag)
 159      (do ((c (read-char stream t nil t)
 160              (read-char stream t nil t)))
 161          ((char= c subchar))
 162        (cond ((char= c #\\)
 163               (setf c (read-char stream t nil t))))
 164        (princ c bag)))))
 165
 166 #-rune-is-character
 167 (defun rod-printer (stream rod)
 168   (princ #\# stream)
 169   (princ #\" stream)
 170   (loop for x across rod do
 171         (cond ((or (rune= x #.(char-rune #\\))
 172                    (rune= x #.(char-rune #\")))
 173                (princ #\\ stream)
 174                (princ (code-char x) stream))
 175               ((< x char-code-limit)
 176                (princ (code-char x) stream))
 177               (t
 178                (format stream "\\u~4,'0X" x))))
 179   (princ #\" stream))
 180
 181 (set-dispatch-macro-character #\# #\" 'rod-reader)