Commit 7ef8cd59 authored by Tobias C. Rittweiler's avatar Tobias C. Rittweiler

Getting close to release.

darcs-hash:20090925165623-f5546-f99949f1d5060f60f8e7725f3d9f389a3e916f87.gz
parent ea1f1295
......@@ -23,17 +23,6 @@
;;;;; 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))
......@@ -99,19 +88,38 @@
#+ :allegro (excl:named-readtable (readtable-name-for-allegro name))
#+ :common-lisp (values (gethash name *named-readtables* nil)))
;;;; Reader-macro related predicates
;;; CLISP creates new function objects for standard reader macros on
;;; each readtable copy.
(define-cruft function= (fn1 fn2)
"Are reader-macro function-designators FN1 and FN2 the same?"
#+ :clisp
(let* ((fn1 (ensure-function fn1))
(fn2 (ensure-function fn2))
(n1 (system::function-name fn1))
(n2 (system::function-name fn2)))
(if (and (eq n1 :lambda) (eq n2 :lambda))
(eq fn1 fn2)
(equal n1 n2)))
#+ :common-lisp
(eq (ensure-function fn1) (ensure-function fn2)))
;;; CCL has a bug that prevents the portable form below from working
;;; (Ticket 601). CLISP will incorrectly fold the call to G-D-M-C away
;;; if not declared inline..
(define-cruft dispatch-macro-char-p (char rt)
"Is CHAR a dispatch macro character in RT?"
;; CCL has a bug that prevents the portable form below from
;; working. Patch has been sent upstream. (2009-09-19.)
#+ :ccl
(let ((def (cdr (nth-value 1 (ccl::%get-readtable-char char rt)))))
(or (consp (cdr def))
(eq (car def) #'ccl::read-dispatch)))
#+ :common-lisp
(handler-case (prog1 t
(get-dispatch-macro-character char #\x rt))
(handler-case (locally
#+clisp (declare (notinline get-dispatch-macro-character))
(get-dispatch-macro-character char #\x rt)
t)
(error () nil)))
;; (defun macro-char-p (char rt)
......@@ -233,11 +241,11 @@
(eval-when (:compile-toplevel)
(let ((*print-pretty* t))
(simple-style-warn
"~@<~A hasn't been ported to ~A. ~
"~&~@< ~@;~A has not 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))))
On Unicode-aware implementations this may come with some costs.~@:>"
(package-name '#.*package*) (lisp-implementation-type))))
#-(or sbcl clozure allegro)
(defun %make-readtable-iterator (readtable)
......@@ -253,10 +261,17 @@
(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)
(values t
;; Only grovel upper case characters to
;; avoid duplicates.
(loop for code from 0 below char-code-limit
for subchar = (let ((ch (code-char code)))
(when (or (not (alpha-char-p ch))
(upper-case-p ch))
ch))
for disp-fn = (and subchar
(get-dispatch-macro-character
char subchar readtable))
when disp-fn
collect (cons subchar disp-fn)))
(error () nil))
......@@ -265,13 +280,16 @@
(defmacro do-readtable ((entry-designator readtable &optional result)
&body body)
"Iterate through a readtable's macro characters, and dispatch macro characters."
(destructuring-bind (char &optional reader-fn disp? table)
(destructuring-bind (char &optional reader-fn non-terminating-p disp? table)
(if (symbolp entry-designator)
(list entry-designator)
entry-designator)
(let ((iter (gensym "ITER+"))
(more? (gensym "MORE?+")))
`(with-readtable-iterator (,iter ,readtable)
(more? (gensym "MORE?+"))
(rt (gensym "READTABLE+")))
`(let ((,rt ,readtable))
(with-readtable-iterator (,iter ,rt)
(loop
(multiple-value-bind (,more?
,char
......@@ -280,20 +298,35 @@
,@(when table (list table)))
(,iter)
(unless ,more? (return ,result))
,@body))))))
(let ,(when non-terminating-p
;; FIXME: N-T-P should be incorporated in iterators.
`((,non-terminating-p
(nth-value 1 (get-macro-character ,char ,rt)))))
,@body))))))))
;;;; Misc
(declaim (special *standard-readtable*))
(defun %clear-readtable (readtable)
;;; 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))
;;; FIXME: Alas, on SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
;;; readtable's dispatch table properly.
(define-cruft %clear-readtable (readtable)
"Make all macro characters in READTABLE be consituents."
#+ :common-lisp
(progn
(do-readtable (char readtable)
(set-syntax-from-char char #\A readtable *standard-readtable*))
;; FIXME: Alas, on SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
;; readtable's dispatch table properly.
#+sbcl (setf (sb-impl::dispatch-tables readtable) nil)
readtable)
readtable))
;;;; Specialized PRINT-OBJECT for named readtables.
......
;;; -*- Mode:Lisp -*-
(defpackage :named-readtables-system
(:use :cl :asdf))
(in-package :cl-user)
(in-package :named-readtables-system)
(defclass asdf::named-readtables-source-file (asdf:cl-source-file) ())
(defclass named-readtables-source-file (cl-source-file) ())
(defsystem :named-readtables
(asdf:defsystem :named-readtables
:description "Library that creates a namespace for named readtable akin to the namespace of packages."
:author "Tobias C. Rittweiler <trittweiler@common-lisp.net>"
:version "1.0 (unpublished so far)"
:licence "BSD"
:serial t
:default-component-class named-readtables-source-file
:default-component-class asdf::named-readtables-source-file
:components
((:file "package")
(:file "utils" :depends-on ("package"))
......@@ -21,7 +18,7 @@
#+sbcl
(defmethod perform :around ((operation compile-op)
(c named-readtables-source-file))
(defmethod asdf:perform :around
((operation asdf:compile-op) (component asdf::named-readtables-source-file))
(let ((sb-ext:*derive-function-types* t))
(call-next-method)))
\ No newline at end of file
......@@ -202,7 +202,7 @@ standard macro character has been made a constituent."
Not acceptable as a user-specified readtable name." name))
((let ((rt (find-readtable name)))
(and rt (prog1 nil
(cerror "Overwrite existing readtable."
(cerror "Overwrite existing entry."
'readtable-does-already-exist :readtable-name name)
;; Explicitly unregister to make sure that we do not hold on
;; of any reference to RT.
......@@ -226,17 +226,17 @@ is signaled."
(check-type named-readtable-designator named-readtable-designator)
(check-type new-name symbol)
(when (find-readtable new-name)
(cerror "Overwrite existing readtable."
(cerror "Overwrite existing entry."
'readtable-does-already-exist :readtable-name new-name))
(let* ((read-table (ensure-readtable named-readtable-designator))
(read-table-name (readtable-name read-table)))
(let* ((readtable (ensure-readtable named-readtable-designator))
(readtable-name (readtable-name readtable)))
;; We use the internal functions directly to omit repeated
;; type-checking.
(%unassociate-name-from-readtable read-table-name read-table)
(%unassociate-readtable-from-name read-table-name read-table)
(%associate-name-with-readtable new-name read-table)
(%associate-readtable-with-name new-name read-table)
read-table))
(%unassociate-name-from-readtable readtable-name readtable)
(%unassociate-readtable-from-name readtable-name readtable)
(%associate-name-with-readtable new-name readtable)
(%associate-readtable-with-name new-name readtable)
readtable))
(defun merge-readtables-into (result-table &rest named-readtable-designators)
"Copy the contents of each readtable in `named-readtable-designators'
......@@ -246,8 +246,7 @@ If a macro character appears in more than one of the readtables, i.e. if a
conflict is discovered during the merge, an error of type
READER-MACRO-CONFLICT is signaled."
(flet ((merge-into (to from)
(do-readtable ((char reader-fn disp? table) from)
(let ((non-terminating-p (nth-value 1 (get-macro-character char from))))
(do-readtable ((char reader-fn non-terminating-p disp? table) from)
(check-reader-macro-conflict from to char)
(cond ((not disp?)
(set-macro-character char reader-fn non-terminating-p to))
......@@ -255,7 +254,7 @@ READER-MACRO-CONFLICT is signaled."
(ensure-dispatch-macro-character char non-terminating-p to)
(loop for (subchar . subfn) in table do
(check-reader-macro-conflict from to char subchar)
(set-dispatch-macro-character char subchar subfn to))))))
(set-dispatch-macro-character char subchar subfn to)))))
to))
(setf result-table (ensure-readtable result-table))
(dolist (table (mapcar #'ensure-readtable named-readtable-designators))
......@@ -267,6 +266,10 @@ READER-MACRO-CONFLICT is signaled."
(unless (dispatch-macro-char-p char readtable)
(make-dispatch-macro-character char non-terminating-p readtable)))
(defun copy-named-readtable (named-readtable-designator)
"Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument."
(copy-readtable (ensure-readtable named-readtable-designator)))
(defun list-all-named-readtables ()
"Returns a list of all registered readtables. The returned list is
guaranteed to be fresh, but may contain duplicates."
......@@ -341,17 +344,15 @@ character\) is both present in the source as well as the target readtable,
and b) if and only if the two respective reader macro functions differ (as
per EQ.)"))
(defun check-reader-macro-conflict (from to char &optional subchar)
(flet ((conflictp (from-fn to-fn)
(and to-fn
(not (eq to-fn from-fn)))))
(and to-fn (not (function= to-fn from-fn)))))
(when (if subchar
(conflictp (get-dispatch-macro-character char subchar from)
(get-dispatch-macro-character char subchar to))
(conflictp (safe-get-dispatch-macro-character char subchar from)
(safe-get-dispatch-macro-character char subchar to))
(conflictp (get-macro-character char from)
(get-macro-character char to)))
(break "from = ~S, to = ~S, char = ~S, subchar = ~S"
from to char subchar)
(cerror (format nil "Overwrite ~@C in ~A." char to)
'reader-macro-conflict
:from-readtable from
......@@ -359,6 +360,13 @@ per EQ.)"))
:macro-char char
:sub-char subchar))))
;;; See Ticket 601. This is supposed to be removed at some point in
;;; the future.
(defun safe-get-dispatch-macro-character (char subchar rt)
#+ccl (ignore-errors
(get-dispatch-macro-character char subchar rt))
#-ccl (get-dispatch-macro-character char subchar rt))
;;; Although there is no way to get at the standard readtable in
;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make
......@@ -436,42 +444,42 @@ signals an error of type READTABLE-DOES-NOT-EXIST instead."
(t (setf (find-readtable designator) (ensure-readtable default))))))
(defun register-readtable (name read-table)
"Associate `read-table' with `name'."
(defun register-readtable (name readtable)
"Associate `readtable' with `name'. Returns the readtable."
(check-type name symbol)
(check-type read-table readtable)
(check-type readtable readtable)
(check-type name (not (satisfies reserved-readtable-name-p)))
(%associate-readtable-with-name name read-table)
(%associate-name-with-readtable name read-table)
read-table)
(%associate-readtable-with-name name readtable)
(%associate-name-with-readtable name readtable)
readtable)
(defun unregister-readtable (named-readtable-designator)
"Remove the association of `named-readtable-designator'. Returns T if
successfull, NIL otherwise."
(let* ((read-table (ensure-readtable named-readtable-designator))
(read-table-name (readtable-name read-table)))
(if (not read-table-name)
(let* ((readtable (find-readtable named-readtable-designator))
(readtable-name (and readtable (readtable-name readtable))))
(if (not readtable-name)
nil
(prog1 t
(check-type read-table-name (not (satisfies reserved-readtable-name-p)))
(%unassociate-readtable-from-name read-table-name read-table)
(%unassociate-name-from-readtable read-table-name read-table)))))
(check-type readtable-name (not (satisfies reserved-readtable-name-p)))
(%unassociate-readtable-from-name readtable-name readtable)
(%unassociate-name-from-readtable readtable-name readtable)))))
(defun readtable-name (named-readtable-designator)
"Returns the name of the readtable designated by
`named-readtable-designator', or NIL."
(check-type named-readtable-designator named-readtable-designator)
(let ((read-table (ensure-readtable named-readtable-designator)))
(cond ((%readtable-name read-table))
((eq read-table *readtable*) :current)
((eq read-table *standard-readtable*) :common-lisp)
((eq read-table *case-preserving-standard-readtable*) :modern)
(let ((readtable (ensure-readtable named-readtable-designator)))
(cond ((%readtable-name readtable))
((eq readtable *readtable*) :current)
((eq readtable *standard-readtable*) :common-lisp)
((eq readtable *case-preserving-standard-readtable*) :modern)
(t nil))))
;;;;; Compiler macros
;;; Since the :STANDARD read-table is interned, and we can't enforce
;;; Since the :STANDARD readtable is interned, and we can't enforce
;;; its immutability, we signal a style-warning for suspicious uses
;;; that may result in strange behaviour:
......@@ -490,14 +498,14 @@ successfull, NIL otherwise."
(ensure-readtable :standard))))
(t nil)))
(defun signal-suspicious-registration-warning (name-expr read-table-expr)
(defun signal-suspicious-registration-warning (name-expr readtable-expr)
(simple-style-warn
"Caution: ~<You're trying to register the :STANDARD readtable ~
under a new name ~S. As modification of the :STANDARD readtable ~
is not permitted, subsequent modification of ~S won't be ~
permitted either. You probably want to wrap COPY-READTABLE ~
around~@:>~% ~S"
(list name-expr name-expr) read-table-expr))
(list name-expr name-expr) readtable-expr))
(let ()
;; Defer to runtime because compiler-macros are made available already
......@@ -507,9 +515,9 @@ successfull, NIL otherwise."
;; (This does not use EVAL-WHEN because of Fig 3.7, CLHS 3.2.3.1;
;; cf. last example in CLHS "EVAL-WHEN" entry.)
(define-compiler-macro register-readtable (&whole form name read-table)
(when (constant-standard-readtable-expression-p read-table)
(signal-suspicious-registration-warning name read-table))
(define-compiler-macro register-readtable (&whole form name readtable)
(when (constant-standard-readtable-expression-p readtable)
(signal-suspicious-registration-warning name readtable))
form)
(define-compiler-macro ensure-readtable (&whole form name &optional (default nil default-p))
......
......@@ -15,6 +15,7 @@
#:readtable-name
#:register-readtable
#:unregister-readtable
#:copy-named-readtable
#:list-all-named-readtables
;; Types
#:named-readtable-designator
......
......@@ -16,14 +16,24 @@
:format-control format-control
:format-arguments format-args))
(defmacro without-package-lock ((&rest package-names) &body body)
(declare (ignorable package-names))
#+clisp (return-from without-package-lock
#+clisp
(return-from without-package-lock
`(ext:without-package-lock (,@package-names) ,@body))
#+lispworks
(return-from without-package-lock
`(let ((hcl:*packages-for-warn-on-redefinition*
(set-difference hcl:*packages-for-warn-on-redefinition*
'(,@package-names)
:key (lambda (package-designator)
(if (packagep package-designator)
(package-name package-designator)
package-designator))
:test #'string=)))
,@body))
`(progn ,@body))
;;; Taken from SWANK (which is Public Domain.)
(defmacro destructure-case (value &rest patterns)
......@@ -58,3 +68,14 @@ corresponding values in the CDR of VALUE."
use as an initialization form for structure and class-slots, and
a default value for required keyword arguments."
(error "Required argument ~@[~S ~]missing." name))
(declaim (inline ensure-function)) ; to propagate return type.
(declaim (ftype (function (t) (values function &optional))
ensure-function))
(defun ensure-function (function-designator)
"Returns the function designated by FUNCTION-DESIGNATOR:
if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
it must be a function name and its FDEFINITION is returned."
(if (functionp function-designator)
function-designator
(fdefinition function-designator)))
\ No newline at end of file
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