Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Raymond Toy
named-readtables
Commits
7ef8cd59
Commit
7ef8cd59
authored
Sep 25, 2009
by
Tobias C. Rittweiler
Browse files
Getting close to release.
darcs-hash:20090925165623-f5546-f99949f1d5060f60f8e7725f3d9f389a3e916f87.gz
parent
ea1f1295
Changes
5
Hide whitespace changes
Inline
Side-by-side
named-readtables/cruft.lisp
View file @
7ef8cd59
...
...
@@ -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
))
...
...
@@ -98,20 +87,39 @@
"Return the readtable named NAME."
#+
: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 has
n'
t been ported to ~A. ~
"~
&~@< ~@;
~A has
no
t 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 come
s
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,11 +261,18 @@
(
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
)
when
disp-fn
(
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
))
(
return
(
values
t
char
fn
disp?
alist
)))))))))
...
...
@@ -265,35 +280,53 @@
(
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
)
(
loop
(
multiple-value-bind
(
,
more?
,
char
,@
(
when
reader-fn
(
list
reader-fn
))
,@
(
when
disp?
(
list
disp?
))
,@
(
when
table
(
list
table
)))
(
,
iter
)
(
unless
,
more?
(
return
,
result
))
,@
body
))))))
(
more?
(
gensym
"MORE?+"
))
(
rt
(
gensym
"READTABLE+"
)))
`
(
let
((
,
rt
,
readtable
))
(
with-readtable-iterator
(
,
iter
,
rt
)
(
loop
(
multiple-value-bind
(
,
more?
,
char
,@
(
when
reader-fn
(
list
reader-fn
))
,@
(
when
disp?
(
list
disp?
))
,@
(
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
(
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."
(
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
)
#+
:common-lisp
(
progn
(
do-readtable
(
char
readtable
)
(
set-syntax-from-char
char
#\A
readtable
*standard-readtable*
))
#+
sbcl
(
setf
(
sb-impl::dispatch-tables
readtable
)
nil
)
readtable
)
)
;;;; Specialized PRINT-OBJECT for named readtables.
...
...
named-readtables/named-readtables.asd
View file @
7ef8cd59
;;; -*- Mode:Lisp -*-
(
defpackage
:named-readtables-system
(
:use
:cl
:asdf
))
(
in-package
:cl-user
)
(
in-package
:named-readtables-s
ystem
)
(
defclass
asdf:
:named-readtables-s
ource-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
named-readtables/named-readtables.lisp
View file @
7ef8cd59
...
...
@@ -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,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
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
))))
(
check-reader-macro-conflict
from
to
char
)
(
cond
((
not
disp?
)
(
set-macro-character
char
reader-fn
non-terminating-p
to
))
(
t
(
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
))))))
(
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
))
(
t
(
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
)))))
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
))
...
...
named-readtables/package.lisp
View file @
7ef8cd59
...
...
@@ -15,6 +15,7 @@
#:readtable-name
#:register-readtable
#:unregister-readtable
#:copy-named-readtable
#:list-all-named-readtables
;; Types
#:named-readtable-designator
...
...
named-readtables/utils.lisp
View file @
7ef8cd59
...
...
@@ -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
`
(
ext:without-package-lock
(
,@
package-names
)
,@
body
))
#+
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
)
...
...
@@ -57,4 +67,15 @@ corresponding values in the CDR of VALUE."
"Signals an error for a missing argument of NAME. Intended for
use as an initialization form for structure and class-slots, and
a default value for required keyword arguments."
(
error
"Required argument ~@[~S ~]missing."
name
))
\ No newline at end of file
(
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
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment