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 @@ ...@@ -23,17 +23,6 @@
;;;;; Implementation-dependent cruft ;;;;; 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. ;;;; Mapping between a readtable object and its readtable-name.
(defvar *readtable-names* (make-hash-table :test 'eq)) (defvar *readtable-names* (make-hash-table :test 'eq))
...@@ -98,20 +87,39 @@ ...@@ -98,20 +87,39 @@
"Return the readtable named NAME." "Return the readtable named NAME."
#+ :allegro (excl:named-readtable (readtable-name-for-allegro name)) #+ :allegro (excl:named-readtable (readtable-name-for-allegro name))
#+ :common-lisp (values (gethash name *named-readtables* nil))) #+ :common-lisp (values (gethash name *named-readtables* nil)))
;;;; Reader-macro related predicates ;;;; 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) (define-cruft dispatch-macro-char-p (char rt)
"Is CHAR a dispatch macro character in 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 #+ :ccl
(let ((def (cdr (nth-value 1 (ccl::%get-readtable-char char rt))))) (let ((def (cdr (nth-value 1 (ccl::%get-readtable-char char rt)))))
(or (consp (cdr def)) (or (consp (cdr def))
(eq (car def) #'ccl::read-dispatch))) (eq (car def) #'ccl::read-dispatch)))
#+ :common-lisp #+ :common-lisp
(handler-case (prog1 t (handler-case (locally
(get-dispatch-macro-character char #\x rt)) #+clisp (declare (notinline get-dispatch-macro-character))
(get-dispatch-macro-character char #\x rt)
t)
(error () nil))) (error () nil)))
;; (defun macro-char-p (char rt) ;; (defun macro-char-p (char rt)
...@@ -233,11 +241,11 @@ ...@@ -233,11 +241,11 @@
(eval-when (:compile-toplevel) (eval-when (:compile-toplevel)
(let ((*print-pretty* t)) (let ((*print-pretty* t))
(simple-style-warn (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. ~ We fall back to a portable implementation of readtable iterators. ~
This implementation has to grovel through all available characters. ~ This implementation has to grovel through all available characters. ~
On Unicode-aware implementations this comes with some costs.~@:>" On Unicode-aware implementations this may come with some costs.~@:>"
(package-name *package*) (lisp-implementation-type)))) (package-name '#.*package*) (lisp-implementation-type))))
#-(or sbcl clozure allegro) #-(or sbcl clozure allegro)
(defun %make-readtable-iterator (readtable) (defun %make-readtable-iterator (readtable)
...@@ -253,11 +261,18 @@ ...@@ -253,11 +261,18 @@
(when (not fn) (go :GROVEL)) (when (not fn) (go :GROVEL))
(multiple-value-bind (disp? alist) (multiple-value-bind (disp? alist)
(handler-case ; grovel dispatch macro characters. (handler-case ; grovel dispatch macro characters.
(values t (loop for code from 0 below char-code-limit (values t
for subchar = (code-char code) ;; Only grovel upper case characters to
for disp-fn = (get-dispatch-macro-character ;; avoid duplicates.
char subchar readtable) (loop for code from 0 below char-code-limit
when disp-fn 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))) collect (cons subchar disp-fn)))
(error () nil)) (error () nil))
(return (values t char fn disp? alist))))))))) (return (values t char fn disp? alist)))))))))
...@@ -265,35 +280,53 @@ ...@@ -265,35 +280,53 @@
(defmacro do-readtable ((entry-designator readtable &optional result) (defmacro do-readtable ((entry-designator readtable &optional result)
&body body) &body body)
"Iterate through a readtable's macro characters, and dispatch macro characters." "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) (if (symbolp entry-designator)
(list entry-designator) (list entry-designator)
entry-designator) entry-designator)
(let ((iter (gensym "ITER+")) (let ((iter (gensym "ITER+"))
(more? (gensym "MORE?+"))) (more? (gensym "MORE?+"))
`(with-readtable-iterator (,iter ,readtable) (rt (gensym "READTABLE+")))
(loop
(multiple-value-bind (,more? `(let ((,rt ,readtable))
,char (with-readtable-iterator (,iter ,rt)
,@(when reader-fn (list reader-fn)) (loop
,@(when disp? (list disp?)) (multiple-value-bind (,more?
,@(when table (list table))) ,char
(,iter) ,@(when reader-fn (list reader-fn))
(unless ,more? (return ,result)) ,@(when disp? (list disp?))
,@body)))))) ,@(when table (list table)))
(,iter)
(unless ,more? (return ,result))
(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 ;;;; Misc
(declaim (special *standard-readtable*)) (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." "Make all macro characters in READTABLE be consituents."
(do-readtable (char readtable) #+ :common-lisp
(set-syntax-from-char char #\A readtable *standard-readtable*)) (progn
;; FIXME: Alas, on SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a (do-readtable (char readtable)
;; readtable's dispatch table properly. (set-syntax-from-char char #\A readtable *standard-readtable*))
#+sbcl (setf (sb-impl::dispatch-tables readtable) nil) #+sbcl (setf (sb-impl::dispatch-tables readtable) nil)
readtable) readtable))
;;;; Specialized PRINT-OBJECT for named readtables. ;;;; Specialized PRINT-OBJECT for named readtables.
......
;;; -*- Mode:Lisp -*-
(defpackage :named-readtables-system (in-package :cl-user)
(:use :cl :asdf))
(in-package :named-readtables-system) (defclass asdf::named-readtables-source-file (asdf:cl-source-file) ())
(defclass named-readtables-source-file (cl-source-file) ()) (asdf:defsystem :named-readtables
(defsystem :named-readtables
:description "Library that creates a namespace for named readtable akin to the namespace of packages." :description "Library that creates a namespace for named readtable akin to the namespace of packages."
:author "Tobias C. Rittweiler <trittweiler@common-lisp.net>" :author "Tobias C. Rittweiler <trittweiler@common-lisp.net>"
:version "1.0 (unpublished so far)" :version "1.0 (unpublished so far)"
:licence "BSD" :licence "BSD"
:serial t :default-component-class asdf::named-readtables-source-file
:default-component-class named-readtables-source-file
:components :components
((:file "package") ((:file "package")
(:file "utils" :depends-on ("package")) (:file "utils" :depends-on ("package"))
...@@ -21,7 +18,7 @@ ...@@ -21,7 +18,7 @@
#+sbcl #+sbcl
(defmethod perform :around ((operation compile-op) (defmethod asdf:perform :around
(c named-readtables-source-file)) ((operation asdf:compile-op) (component asdf::named-readtables-source-file))
(let ((sb-ext:*derive-function-types* t)) (let ((sb-ext:*derive-function-types* t))
(call-next-method))) (call-next-method)))
\ No newline at end of file
...@@ -202,7 +202,7 @@ standard macro character has been made a constituent." ...@@ -202,7 +202,7 @@ standard macro character has been made a constituent."
Not acceptable as a user-specified readtable name." name)) Not acceptable as a user-specified readtable name." name))
((let ((rt (find-readtable name))) ((let ((rt (find-readtable name)))
(and rt (prog1 nil (and rt (prog1 nil
(cerror "Overwrite existing readtable." (cerror "Overwrite existing entry."
'readtable-does-already-exist :readtable-name name) 'readtable-does-already-exist :readtable-name name)
;; Explicitly unregister to make sure that we do not hold on ;; Explicitly unregister to make sure that we do not hold on
;; of any reference to RT. ;; of any reference to RT.
...@@ -226,17 +226,17 @@ is signaled." ...@@ -226,17 +226,17 @@ is signaled."
(check-type named-readtable-designator named-readtable-designator) (check-type named-readtable-designator named-readtable-designator)
(check-type new-name symbol) (check-type new-name symbol)
(when (find-readtable new-name) (when (find-readtable new-name)
(cerror "Overwrite existing readtable." (cerror "Overwrite existing entry."
'readtable-does-already-exist :readtable-name new-name)) 'readtable-does-already-exist :readtable-name new-name))
(let* ((read-table (ensure-readtable named-readtable-designator)) (let* ((readtable (ensure-readtable named-readtable-designator))
(read-table-name (readtable-name read-table))) (readtable-name (readtable-name readtable)))
;; We use the internal functions directly to omit repeated ;; We use the internal functions directly to omit repeated
;; type-checking. ;; type-checking.
(%unassociate-name-from-readtable read-table-name read-table) (%unassociate-name-from-readtable readtable-name readtable)
(%unassociate-readtable-from-name read-table-name read-table) (%unassociate-readtable-from-name readtable-name readtable)
(%associate-name-with-readtable new-name read-table) (%associate-name-with-readtable new-name readtable)
(%associate-readtable-with-name new-name read-table) (%associate-readtable-with-name new-name readtable)
read-table)) readtable))
(defun merge-readtables-into (result-table &rest named-readtable-designators) (defun merge-readtables-into (result-table &rest named-readtable-designators)
"Copy the contents of each readtable in `named-readtable-designators' "Copy the contents of each readtable in `named-readtable-designators'
...@@ -246,16 +246,15 @@ If a macro character appears in more than one of the readtables, i.e. if a ...@@ -246,16 +246,15 @@ 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 conflict is discovered during the merge, an error of type
READER-MACRO-CONFLICT is signaled." READER-MACRO-CONFLICT is signaled."
(flet ((merge-into (to from) (flet ((merge-into (to from)
(do-readtable ((char reader-fn disp? table) from) (do-readtable ((char reader-fn non-terminating-p disp? table) from)
(let ((non-terminating-p (nth-value 1 (get-macro-character char from)))) (check-reader-macro-conflict from to char)
(check-reader-macro-conflict from to char) (cond ((not disp?)
(cond ((not disp?) (set-macro-character char reader-fn non-terminating-p to))
(set-macro-character char reader-fn non-terminating-p to)) (t
(t (ensure-dispatch-macro-character char non-terminating-p to)
(ensure-dispatch-macro-character char non-terminating-p to) (loop for (subchar . subfn) in table do
(loop for (subchar . subfn) in table do (check-reader-macro-conflict from to char subchar)
(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)) to))
(setf result-table (ensure-readtable result-table)) (setf result-table (ensure-readtable result-table))
(dolist (table (mapcar #'ensure-readtable named-readtable-designators)) (dolist (table (mapcar #'ensure-readtable named-readtable-designators))
...@@ -267,6 +266,10 @@ READER-MACRO-CONFLICT is signaled." ...@@ -267,6 +266,10 @@ READER-MACRO-CONFLICT is signaled."
(unless (dispatch-macro-char-p char readtable) (unless (dispatch-macro-char-p char readtable)
(make-dispatch-macro-character char non-terminating-p 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 () (defun list-all-named-readtables ()
"Returns a list of all registered readtables. The returned list is "Returns a list of all registered readtables. The returned list is
guaranteed to be fresh, but may contain duplicates." 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, ...@@ -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 and b) if and only if the two respective reader macro functions differ (as
per EQ.)")) per EQ.)"))
(defun check-reader-macro-conflict (from to char &optional subchar) (defun check-reader-macro-conflict (from to char &optional subchar)
(flet ((conflictp (from-fn to-fn) (flet ((conflictp (from-fn to-fn)
(and to-fn (and to-fn (not (function= to-fn from-fn)))))
(not (eq to-fn from-fn)))))
(when (if subchar (when (if subchar
(conflictp (get-dispatch-macro-character char subchar from) (conflictp (safe-get-dispatch-macro-character char subchar from)
(get-dispatch-macro-character char subchar to)) (safe-get-dispatch-macro-character char subchar to))
(conflictp (get-macro-character char from) (conflictp (get-macro-character char from)
(get-macro-character char to))) (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) (cerror (format nil "Overwrite ~@C in ~A." char to)
'reader-macro-conflict 'reader-macro-conflict
:from-readtable from :from-readtable from
...@@ -359,6 +360,13 @@ per EQ.)")) ...@@ -359,6 +360,13 @@ per EQ.)"))
:macro-char char :macro-char char
:sub-char subchar)))) :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 ;;; Although there is no way to get at the standard readtable in
;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make ;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make
...@@ -436,42 +444,42 @@ signals an error of type READTABLE-DOES-NOT-EXIST instead." ...@@ -436,42 +444,42 @@ signals an error of type READTABLE-DOES-NOT-EXIST instead."
(t (setf (find-readtable designator) (ensure-readtable default)))))) (t (setf (find-readtable designator) (ensure-readtable default))))))
(defun register-readtable (name read-table) (defun register-readtable (name readtable)
"Associate `read-table' with `name'." "Associate `readtable' with `name'. Returns the readtable."
(check-type name symbol) (check-type name symbol)
(check-type read-table readtable) (check-type readtable readtable)
(check-type name (not (satisfies reserved-readtable-name-p))) (check-type name (not (satisfies reserved-readtable-name-p)))
(%associate-readtable-with-name name read-table) (%associate-readtable-with-name name readtable)
(%associate-name-with-readtable name read-table) (%associate-name-with-readtable name readtable)
read-table) readtable)
(defun unregister-readtable (named-readtable-designator) (defun unregister-readtable (named-readtable-designator)
"Remove the association of `named-readtable-designator'. Returns T if "Remove the association of `named-readtable-designator'. Returns T if
successfull, NIL otherwise." successfull, NIL otherwise."
(let* ((read-table (ensure-readtable named-readtable-designator)) (let* ((readtable (find-readtable named-readtable-designator))
(read-table-name (readtable-name read-table))) (readtable-name (and readtable (readtable-name readtable))))
(if (not read-table-name) (if (not readtable-name)
nil nil
(prog1 t (prog1 t
(check-type read-table-name (not (satisfies reserved-readtable-name-p))) (check-type readtable-name (not (satisfies reserved-readtable-name-p)))
(%unassociate-readtable-from-name read-table-name read-table) (%unassociate-readtable-from-name readtable-name readtable)
(%unassociate-name-from-readtable read-table-name read-table))))) (%unassociate-name-from-readtable readtable-name readtable)))))
(defun readtable-name (named-readtable-designator) (defun readtable-name (named-readtable-designator)
"Returns the name of the readtable designated by "Returns the name of the readtable designated by
`named-readtable-designator', or NIL." `named-readtable-designator', or NIL."
(check-type named-readtable-designator named-readtable-designator) (check-type named-readtable-designator named-readtable-designator)
(let ((read-table (ensure-readtable named-readtable-designator))) (let ((readtable (ensure-readtable named-readtable-designator)))
(cond ((%readtable-name read-table)) (cond ((%readtable-name readtable))
((eq read-table *readtable*) :current) ((eq readtable *readtable*) :current)
((eq read-table *standard-readtable*) :common-lisp) ((eq readtable *standard-readtable*) :common-lisp)
((eq read-table *case-preserving-standard-readtable*) :modern) ((eq readtable *case-preserving-standard-readtable*) :modern)
(t nil)))) (t nil))))
;;;;; Compiler macros ;;;;; 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 ;;; its immutability, we signal a style-warning for suspicious uses
;;; that may result in strange behaviour: ;;; that may result in strange behaviour:
...@@ -490,14 +498,14 @@ successfull, NIL otherwise." ...@@ -490,14 +498,14 @@ successfull, NIL otherwise."
(ensure-readtable :standard)))) (ensure-readtable :standard))))
(t nil))) (t nil)))
(defun signal-suspicious-registration-warning (name-expr read-table-expr) (defun signal-suspicious-registration-warning (name-expr readtable-expr)
(simple-style-warn (simple-style-warn
"Caution: ~<You're trying to register the :STANDARD readtable ~ "Caution: ~<You're trying to register the :STANDARD readtable ~
under a new name ~S. As modification of the :STANDARD readtable ~ under a new name ~S. As modification of the :STANDARD readtable ~
is not permitted, subsequent modification of ~S won't be ~ is not permitted, subsequent modification of ~S won't be ~
permitted either. You probably want to wrap COPY-READTABLE ~ permitted either. You probably want to wrap COPY-READTABLE ~
around~@:>~% ~S" around~@:>~% ~S"
(list name-expr name-expr) read-table-expr)) (list name-expr name-expr) readtable-expr))
(let () (let ()
;; Defer to runtime because compiler-macros are made available already ;; Defer to runtime because compiler-macros are made available already
...@@ -507,9 +515,9 @@ successfull, NIL otherwise." ...@@ -507,9 +515,9 @@ successfull, NIL otherwise."
;; (This does not use EVAL-WHEN because of Fig 3.7, CLHS 3.2.3.1; ;; (This does not use EVAL-WHEN because of Fig 3.7, CLHS 3.2.3.1;
;; cf. last example in CLHS "EVAL-WHEN" entry.) ;; cf. last example in CLHS "EVAL-WHEN" entry.)
(define-compiler-macro register-readtable (&whole form name read-table) (define-compiler-macro register-readtable (&whole form name readtable)
(when (constant-standard-readtable-expression-p read-table) (when (constant-standard-readtable-expression-p readtable)
(signal-suspicious-registration-warning name read-table)) (signal-suspicious-registration-warning name readtable))
form) form)
(define-compiler-macro ensure-readtable (&whole form name &optional (default nil default-p)) (define-compiler-macro ensure-readtable (&whole form name &optional (default nil default-p))
......
...@@ -15,6 +15,7 @@ ...@@ -15,6 +15,7 @@
#:readtable-name #:readtable-name
#:register-readtable #:register-readtable
#:unregister-readtable #:unregister-readtable
#:copy-named-readtable
#:list-all-named-readtables #:list-all-named-readtables
;; Types ;; Types
#:named-readtable-designator #:named-readtable-designator
......
...@@ -16,14 +16,24 @@ ...@@ -16,14 +16,24 @@
:format-control format-control :format-control format-control
:format-arguments format-args)) :format-arguments format-args))
(defmacro without-package-lock ((&rest package-names) &body body) (defmacro without-package-lock ((&rest package-names) &body body)
(declare (ignorable package-names)) (declare (ignorable package-names))
#+clisp (return-from without-package-lock #+clisp
`(ext:without-package-lock (,@package-names) ,@body)) (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)) `(progn ,@body))
;;; Taken from SWANK (which is Public Domain.) ;;; Taken from SWANK (which is Public Domain.)
(defmacro destructure-case (value &rest patterns) (defmacro destructure-case (value &rest patterns)
...@@ -57,4 +67,15 @@ corresponding values in the CDR of VALUE." ...@@ -57,4 +67,15 @@ corresponding values in the CDR of VALUE."
"Signals an error for a missing argument of NAME. Intended for "Signals an error for a missing argument of NAME. Intended for
use as an initialization form for structure and class-slots, and use as an initialization form for structure and class-slots, and
a default value for required keyword arguments." a default value for required keyword arguments."
(error "Required argument ~@[~S ~]missing." name)) (error "Required argument ~@[~S ~]missing." name))
\ No newline at end of file
(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