Commit fef979a4 authored by Tobias C. Rittweiler's avatar Tobias C. Rittweiler

Reorganize cruft.lisp.

darcs-hash:20090426153244-f5546-6855125028cdb2b5d88f1a9a6bba25c51a1957a5.gz
parent fbf58a90
......@@ -6,123 +6,145 @@
(warn "~A hasn't been ported to ~A; you're likely to get a compiler error"
(package-name *package*) (lisp-implementation-type)))
(defmacro define-inline-function (name lambda-list &body body)
`(progn (declaim (inline ,name))
(defun ,name ,lambda-list ,@body)))
(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))))
(defvar *readtable-names* (make-hash-table :test 'eq))
(eval-when (:compile-toplevel :execute)
#+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE"
(find-package "SB-IMPL"))
(push :sbcl+safe-standard-readtable *features*)))
(define-inline-function %register-readtable-name (name read-table)
(setf (gethash read-table *readtable-names*) name))
(define-inline-function %unregister-readtable-name (read-table)
(remhash read-table *readtable-names*))
;;;;; Implementation-dependent cruft
(define-inline-function %readtable-name (read-table)
(values (gethash read-table *readtable-names*)))
(define-inline-function %list-all-readtable-names ()
(list* :standard :current
(loop for name being each hash-value of *readtable-names*
collect name)))
;;; 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))
;;;; Implementation-dependent cruft
(eval-when (:compile-toplevel :execute)
(when (find-package "SB-READER")
(push :sbcl+sb-reader *features*)))
(define-inline-function %standard-readtable ()
#+sbcl+sb-reader sb-reader:*standard-readtable*
#-sbcl+sb-reader (copy-readtable nil))
#+sbcl+sb-reader
(defmacro %with-readtable-iterator ((name readtable) &body body)
`(sb-reader:with-readtable-iterator (,name ,readtable) ,@body))
#+(and sbcl (not sbcl+sb-reader))
(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))))
(defmacro %with-readtable-iterator ((name readtable) &body body)
(let ((it (gensym)))
`(let ((,it (make-readtable-iterator ,readtable)))
(macrolet ((,name () `(funcall ,',it)))
,@body)))))
#+clozure
(progn
(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)))))
(defmacro %with-readtable-iterator ((name readtable) &body body)
(let ((it (gensym)))
`(let ((,it (make-readtable-iterator ,readtable)))
(macrolet ((,name () `(funcall ,',it)))
,@body)))))
;;;; Mapping between a readtable object and its readtable-name.
(defvar *readtable-names* (make-hash-table :test 'eq))
#-allegro
(progn
(defvar *named-readtables* (make-hash-table :test 'eq))
(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*)))
(define-inline-function %register-readtable (name read-table)
(setf (gethash name *named-readtables*) read-table))
(define-cruft %readtable-name (readtable)
"Return the name associated with READTABLE."
#+ :common-lisp (values (gethash readtable *readtable-names*)))
(define-inline-function %unregister-readtable (name)
(remhash name *named-readtables*))
(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)))
(define-inline-function %find-readtable-from-name (name)
(values (gethash name *named-readtables* nil))))
;;;; 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))
;; FIXME: Adapt from STRING-DESIGNATOR to SYMBOL.
#+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)))))
(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"
(package-name (symbol-package name))
(symbol-name name))
: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."
#+ :allegro (setf (named-readtable (readtable-name-for-allegro name)) readtable)
#+ :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)))
(assert (eq readtable (named-readtable n)))
(setf (named-readtable n) nil))
#+ :common-lisp (progn (assert (eq readtable (gethash name *named-readtables*)))
(remhash name *named-readtables*)))
(define-cruft %find-readtable (name)
"Return the readtable named NAME."
#+ :allegro (named-readtable (readtable-name-for-allegro name))
#+ :common-lisp (values (gethash name *named-readtables* nil)))
;;;; Readtables Iterators
#+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)))))
(defmacro with-readtable-iterator ((name readtable) &body body)
(let ((it (gensym)))
`(let ((,it (%make-readtable-iterator ,readtable)))
(macrolet ((,name () `(funcall ,',it)))
,@body))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment