cruft.lisp 7.52 KB
Newer Older
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
1
2
3
4
5
6
7
;;;;
;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler <tcr@freebits.de>
;;;;
;;;; All rights reserved.
;;;;
;;;; See LICENSE for details.
;;;;
8
9
10

(in-package :editor-hints.named-readtables)

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
11
12
13
14
15
16
(defmacro define-cruft (name lambda-list &body (docstring . alternatives))
  (assert (typep docstring 'string) (docstring) "Docstring missing!")
  (assert (not (null alternatives)))
  `(progn
     (declaim (inline ,name))
     (defun ,name ,lambda-list ,docstring ,(first alternatives))))
17

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
18
19
20
(eval-when (:compile-toplevel :execute)
  #+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE"
                            (find-package "SB-IMPL"))
21
           (pushnew :sbcl+safe-standard-readtable *features*)))
22
23


Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
24
;;;;; Implementation-dependent cruft
25
26


Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
27
28
29
30
31
32
33
34
;;; This should return an implementation's actual standard readtable
;;; object only if the implementation makes the effort to guard against
;;; modification of that object. Otherwise it should better return a
;;; copy.
(define-cruft %standard-readtable ()
  "Return the standard readtable."
  #+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable*
  #+ :common-lisp                  (copy-readtable nil))
35

36

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
37
;;;; Mapping between a readtable object and its readtable-name.
38

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
39
(defvar *readtable-names* (make-hash-table :test 'eq))
40

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
41
42
43
44
45
46
47
48
(define-cruft %associate-readtable-with-name (name readtable)
  "Associate READTABLE with NAME for READTABLE-NAME to work."
  #+ :common-lisp (setf (gethash readtable *readtable-names*) name))

(define-cruft %unassociate-readtable-from-name (name readtable)
  "Remove the association between READTABLE and NAME."
  #+ :common-lisp (progn (assert (eq name (gethash readtable *readtable-names*)))
                         (remhash readtable *readtable-names*)))
49

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
50
51
52
(define-cruft %readtable-name (readtable)
  "Return the name associated with READTABLE."
  #+ :common-lisp (values (gethash readtable *readtable-names*)))
53

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
54
55
56
57
58
(define-cruft %list-all-readtable-names ()
  "Return a list of all available readtable names."
  #+ :common-lisp (list* :standard :current
                         (loop for name being each hash-value of *readtable-names*
                               collect name)))
59
60


Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
61
62
63
64
65
66
67
;;;; Mapping between a readtable-name and the actual readtable object.

;;; On Allegro we reuse their named-readtable support so we work
;;; nicely on their infrastructure.

#-allegro
(defvar *named-readtables* (make-hash-table :test 'eq))
68
69

#+allegro
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
70
71
72
73
74
(defun readtable-name-for-allegro (symbol)
  (multiple-value-bind (kwd status)
        ;; Kludge: ACL uses keywords to name readtables, we allow
        ;; arbitrary symbols.
        (intern (format nil "~A.~A"
David Lichteblau's avatar
David Lichteblau committed
75
76
                        (package-name (symbol-package symbol))
                        (symbol-name symbol))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
77
78
79
80
81
82
83
                :keyword)
    (prog1 kwd
      (assert (or (not status) (get kwd 'named-readtable-designator)))
      (setf (get kwd 'named-readtable-designator) t))))

(define-cruft %associate-name-with-readtable (name readtable)
  "Associate NAME with READTABLE for FIND-READTABLE to work."
David Lichteblau's avatar
David Lichteblau committed
84
  #+ :allegro     (setf (excl:named-readtable (readtable-name-for-allegro name)) readtable)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
85
86
87
88
89
  #+ :common-lisp (setf (gethash name *named-readtables*) readtable))

(define-cruft %unassociate-name-from-readtable (name readtable)
  "Remove the association between NAME and READTABLE"
  #+ :allegro     (let ((n (readtable-name-for-allegro name)))
David Lichteblau's avatar
David Lichteblau committed
90
91
                    (assert (eq readtable (excl:named-readtable n)))
                    (setf (excl:named-readtable n) nil))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
92
93
94
95
96
  #+ :common-lisp (progn (assert (eq readtable (gethash name *named-readtables*)))
                         (remhash name *named-readtables*)))

(define-cruft %find-readtable (name)
  "Return the readtable named NAME."
David Lichteblau's avatar
David Lichteblau committed
97
  #+ :allegro     (excl:named-readtable (readtable-name-for-allegro name))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
98
99
100
101
102
  #+ :common-lisp (values (gethash name *named-readtables* nil)))


;;;; Readtables Iterators

103
104
105
106
107
108
(defmacro with-readtable-iterator ((name readtable) &body body)
  (let ((it (gensym)))
    `(let ((,it (%make-readtable-iterator ,readtable)))
       (macrolet ((,name () `(funcall ,',it)))
         ,@body))))

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
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
#+sbcl
(defun %make-readtable-iterator (readtable)
  (let ((char-macro-array (sb-impl::character-macro-array readtable))
        (char-macro-ht    (sb-impl::character-macro-hash-table readtable))
        (dispatch-tables  (sb-impl::dispatch-tables readtable))
        (char-code 0))
    (with-hash-table-iterator (ht-iterator char-macro-ht)
      (labels ((grovel1 ()		; grovel base macro characters
                 (declare (optimize sb-c::merge-tail-calls))
                 (if (>= char-code sb-int:base-char-code-limit)
                     (grovel2)
                     (let ((entry (svref char-macro-array char-code)))
                       (setq char-code (1+ char-code))
                       (if entry
                           (values t (code-char (1- char-code)) entry nil nil)
                           (grovel1)))))
               (grovel2 ()	     ; grovel unicode macro characters
                 (multiple-value-bind (more? char reader-fn) (ht-iterator)
                   (if (not more?)
                       (grovel3)
                       (values t char reader-fn nil nil))))
               (grovel3 ()	    ; grovel dispatch macro characters
                 (if (null dispatch-tables)
                     (values nil nil nil nil nil)
                     (let* ((disp-ch (caar dispatch-tables))
                            (disp-ht (cdar dispatch-tables))
                            (disp-fn (get-macro-character disp-ch readtable))
                            (sub-char-alist))
                       (setq dispatch-tables (cdr dispatch-tables))
                       (maphash (lambda (k v) (push (cons k v) sub-char-alist)) disp-ht)
                       (values t disp-ch disp-fn t sub-char-alist)))))
        #'grovel1))))

#+clozure
(defun %make-readtable-iterator (readtable)
  (let ((char-macro-alist (ccl::rdtab.alist readtable)))
    (lambda ()
      (if char-macro-alist
          (destructuring-bind (char . defn) (pop char-macro-alist)
            (if (consp defn)
                (values t char (car defn) t (cdr defn))
                (values t char defn nil nil)))
          (values nil nil nil nil nil)))))

153
154
155
156
157
158
159
160
#-(or sbcl clozure)
(eval-when (:compile-toplevel)
  (simple-style-warn
   "~A hasn't been ported to ~A. ~
    We fall back to a portable implementation of readtable iterators. ~
    This implementation has to grovel through all available characters. ~
    On Unicode-aware implementations this comes with some costs." 
   (package-name *package*) (lisp-implementation-type)))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
161

162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
#-(or sbcl clozure)
(defun %make-readtable-iterator (readtable)
  (check-type readtable readtable)
  (let ((char-code 0))
    #'(lambda ()
        (prog ()
           :GROVEL
           (when (< char-code char-code-limit)
             (let* ((char (code-char char-code))
                    (fn   (get-macro-character char readtable)))
               (incf char-code)
               (when (not fn) (go :GROVEL))
               (multiple-value-bind (disp? alist)
                   (handler-case ; grovel dispatch macro characters.
                       (values t (loop for code from 0 below char-code-limit
                                       for subchar = (code-char code)
                                       for disp-fn = (get-dispatch-macro-character
                                                      char subchar readtable)
                                       when disp-fn
                                       collect (cons subchar disp-fn)))
                     (error () nil))
                 (return (values t char fn disp? alist)))))))))