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

Reorganize cruft.lisp.

parent fbf58a90
......@@ -6,43 +6,100 @@
(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)))
(declaim (inline ,name))
(defun ,name ,lambda-list ,docstring ,(first alternatives))))
(eval-when (:compile-toplevel :execute)
#+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE"
(find-package "SB-IMPL"))
(push :sbcl+safe-standard-readtable *features*)))
;;;;; Implementation-dependent cruft
;;; 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))
;;;; Mapping between a readtable object and its readtable-name.
(defvar *readtable-names* (make-hash-table :test 'eq))
(define-inline-function %register-readtable-name (name read-table)
(setf (gethash read-table *readtable-names*) name))
(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-inline-function %unregister-readtable-name (read-table)
(remhash read-table *readtable-names*))
(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 %readtable-name (read-table)
(values (gethash read-table *readtable-names*)))
(define-cruft %readtable-name (readtable)
"Return the name associated with READTABLE."
#+ :common-lisp (values (gethash readtable *readtable-names*)))
(define-inline-function %list-all-readtable-names ()
(list* :standard :current
(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)))
;;;; Implementation-dependent cruft
(eval-when (:compile-toplevel :execute)
(when (find-package "SB-READER")
(push :sbcl+sb-reader *features*)))
;;;; Mapping between a readtable-name and the actual readtable object.
(define-inline-function %standard-readtable ()
#+sbcl+sb-reader sb-reader:*standard-readtable*
#-sbcl+sb-reader (copy-readtable nil))
;;; On Allegro we reuse their named-readtable support so we work
;;; nicely on their infrastructure.
(defmacro %with-readtable-iterator ((name readtable) &body body)
`(sb-reader:with-readtable-iterator (,name ,readtable) ,@body))
(defvar *named-readtables* (make-hash-table :test 'eq))
#+(and sbcl (not sbcl+sb-reader))
(defun make-readtable-iterator (readtable)
(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))
(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
(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))
......@@ -74,14 +131,8 @@
(values t disp-ch disp-fn t sub-char-alist)))))
(defmacro %with-readtable-iterator ((name readtable) &body body)
(let ((it (gensym)))
`(let ((,it (make-readtable-iterator ,readtable)))
(macrolet ((,name () `(funcall ,',it)))
(defun make-readtable-iterator (readtable)
(defun %make-readtable-iterator (readtable)
(let ((char-macro-alist (ccl::rdtab.alist readtable)))
(lambda ()
(if char-macro-alist
......@@ -91,38 +142,9 @@
(values t char defn nil nil)))
(values nil nil nil nil nil)))))
(defmacro %with-readtable-iterator ((name readtable) &body body)
(defmacro with-readtable-iterator ((name readtable) &body body)
(let ((it (gensym)))
`(let ((,it (make-readtable-iterator ,readtable)))
`(let ((,it (%make-readtable-iterator ,readtable)))
(macrolet ((,name () `(funcall ,',it)))
(defvar *named-readtables* (make-hash-table :test 'eq))
(define-inline-function %register-readtable (name read-table)
(setf (gethash name *named-readtables*) read-table))
(define-inline-function %unregister-readtable (name)
(remhash name *named-readtables*))
(define-inline-function %find-readtable-from-name (name)
(values (gethash name *named-readtables* nil))))
(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)))))
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