cruft.lisp 4.42 KB
Newer Older
1 2 3

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

4
#-(or sbcl clozure)
5 6 7 8
(eval-when (:compile-toplevel)
  (warn "~A hasn't been ported to ~A; you're likely to get a compiler error" 
	(package-name *package*) (lisp-implementation-type)))

9 10 11 12
(defmacro define-inline-function (name lambda-list &body body)
  `(progn (declaim (inline ,name))
	  (defun ,name ,lambda-list ,@body)))

13 14
(defvar *readtable-names* (make-hash-table :test 'eq))

15
(define-inline-function %register-readtable-name (name read-table)
16
  (setf (gethash read-table *readtable-names*) name))
17

18
(define-inline-function %unregister-readtable-name (read-table)
19 20
  (remhash read-table *readtable-names*))

21
(define-inline-function %readtable-name (read-table)
22 23
  (values (gethash read-table *readtable-names*)))

24
(define-inline-function %list-all-readtable-names ()
25
  (list* :standard :current
26 27 28
	 (loop for name being each hash-value of *readtable-names*
	       collect name)))

29 30 31 32 33 34
;;;; Implementation-dependent cruft

(eval-when (:compile-toplevel :execute)
  (when (find-package "SB-READER")
    (push :sbcl+sb-reader *features*)))

35
(define-inline-function %standard-readtable ()
Stephen Compall's avatar
Stephen Compall committed
36
  #+sbcl+sb-reader sb-reader:*standard-readtable*
37
  #-sbcl+sb-reader (copy-readtable nil))
38

39
#+sbcl+sb-reader
40 41 42
(defmacro %with-readtable-iterator ((name readtable) &body body)
  `(sb-reader:with-readtable-iterator (,name ,readtable) ,@body))

43
#+(and sbcl (not sbcl+sb-reader))
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
(progn
  (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))))

77 78 79 80 81 82 83
  (defmacro %with-readtable-iterator ((name readtable) &body body)
    (let ((it (gensym)))
      `(let ((,it (make-readtable-iterator ,readtable)))
	 (macrolet ((,name () `(funcall ,',it)))
	   ,@body)))))
#+clozure
(progn
Stephen Compall's avatar
Stephen Compall committed
84 85 86 87 88 89 90 91 92 93
  (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)))))

94 95 96 97 98 99
  (defmacro %with-readtable-iterator ((name readtable) &body body)
    (let ((it (gensym)))
      `(let ((,it (make-readtable-iterator ,readtable)))
	 (macrolet ((,name () `(funcall ,',it)))
	   ,@body)))))

100

101 102
#-allegro
(progn
103
  (defvar *named-readtables* (make-hash-table :test 'eq))
104

105
  (define-inline-function %register-readtable (name read-table)
106
    (setf (gethash name *named-readtables*) read-table))
107

108
  (define-inline-function %unregister-readtable (name)
109
    (remhash name *named-readtables*))
110

111
  (define-inline-function %find-readtable-from-name (name)
112
    (values (gethash name *named-readtables* nil))))
113 114


115
;; FIXME: Adapt from STRING-DESIGNATOR to SYMBOL.
116 117 118 119 120 121 122 123 124 125 126 127 128
#+allegro
(progn
  (defun %register-readtable (string-designator read-table)
    (let ((name (intern (string string-designator) :keyword)))
      (setf (named-readtable name) read-table)))

  (defun %unregister-readtable (string-designator)
    (let ((name (intern (string string-designator) :keyword)))
      (setf (named-readtable name) nil)))

  (defun %find-readtable-from-name (string-designator)
    (let ((name (find-symbol (string string-designator) :keyword)))
      (and name (named-readtable name)))))