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
2a786e71
Commit
2a786e71
authored
Sep 25, 2009
by
Tobias C. Rittweiler
Browse files
Introduce DEFINE-API macro.
darcs-hash:20090925212555-f5546-38a5138a7c57bf85dc2148b811ee448a022f563b.gz
parent
ea624e40
Changes
5
Hide whitespace changes
Inline
Side-by-side
named-readtables/cruft.lisp
View file @
2a786e71
...
...
@@ -287,7 +287,6 @@
(
let
((
iter
(
gensym
"ITER+"
))
(
more?
(
gensym
"MORE?+"
))
(
rt
(
gensym
"READTABLE+"
)))
`
(
let
((
,
rt
,
readtable
))
(
with-readtable-iterator
(
,
iter
,
rt
)
(
loop
...
...
named-readtables/define-api.lisp
0 → 100644
View file @
2a786e71
(
in-package
:named-readtables
)
(
defmacro
define-api
(
name
lambda-list
type-list
&body
body
)
(
flet
((
parse-type-list
(
type-list
)
(
let
((
pos
(
position
'=>
type-list
)))
(
assert
pos
()
"You forgot to specify return type (`=>' missing.)"
)
(
values
(
subseq
type-list
0
pos
)
`
(
values
,@
(
nthcdr
(
1+
pos
)
type-list
)
&optional
)))))
(
multiple-value-bind
(
body
decls
docstring
)
(
parse-body
body
:documentation
t
:whole
`
(
define-api
,
name
))
(
multiple-value-bind
(
arg-typespec
value-typespec
)
(
parse-type-list
type-list
)
(
multiple-value-bind
(
reqs
opts
rest
keys
)
(
parse-ordinary-lambda-list
lambda-list
)
(
declare
(
ignorable
reqs
opts
rest
keys
))
`
(
progn
(
declaim
(
ftype
(
function
,
arg-typespec
,
value-typespec
)
,
name
))
(
defun
,
name
,
lambda-list
,
docstring
,@
decls
;; SBCL will interpret the ftype declaration as
;; assertion and will insert type checks for us.
#-
sbcl
(
progn
;; CHECK-TYPE required parameters
,@
(
loop
for
req-arg
in
reqs
for
req-type
=
(
pop
type-list
)
do
(
assert
req-type
)
collect
`
(
check-type
,
req-arg
,
req-type
))
;; CHECK-TYPE optional parameters
,@
(
loop
initially
(
assert
(
or
(
null
opts
)
(
eq
(
pop
type-list
)
'&optional
)))
for
(
opt-arg
.
nil
)
in
opts
for
opt-type
=
(
pop
type-list
)
do
(
assert
opt-type
)
collect
`
(
check-type
,
opt-arg
,
opt-type
))
;; CHECK-TYPE rest parameter
,@
(
when
rest
(
assert
(
eq
(
pop
type-list
)
'&rest
))
(
let
((
rest-type
(
pop
type-list
)))
(
assert
rest-type
)
`
((
dolist
(
x
,
rest
)
(
check-type
x
,
rest-type
)))))
;; CHECK-TYPE key parameters
,@
(
loop
initially
(
assert
(
or
(
null
keys
)
(
eq
(
pop
type-list
)
'&key
)))
for
((
keyword
key-arg
)
.
nil
)
in
keys
for
(
nil
key-type
)
=
(
find
keyword
type-list
:key
#'
car
)
collect
`
(
check-type
,
key-arg
,
key-type
)))
,@
body
)))))))
\ No newline at end of file
named-readtables/named-readtables.asd
View file @
2a786e71
...
...
@@ -20,8 +20,9 @@
:components
((
:file
"package"
)
(
:file
"utils"
:depends-on
(
"package"
))
(
:file
"define-api"
:depends-on
(
"package"
"utils"
))
(
:file
"cruft"
:depends-on
(
"package"
"utils"
))
(
:file
"named-readtables"
:depends-on
(
"package"
"utils"
"cruft"
))))
(
:file
"named-readtables"
:depends-on
(
"package"
"utils"
"cruft"
"define-api"
))))
(
defmethod
asdf:perform
((
o
asdf:test-op
)
(
c
(
eql
(
asdf:find-system
:named-readtables
))))
...
...
named-readtables/named-readtables.lisp
View file @
2a786e71
...
...
@@ -180,11 +180,20 @@ Notes:
(
destructuring-bind
(
pkg-name2
.
rt2
)
entry2
(
and
(
string=
pkg-name1
pkg-name2
)
(
eq
rt1
rt2
)))))))))
(
deftype
readtable-designator
()
`
(
or
null
readtable
))
(
deftype
named-readtable-designator
()
"Either a symbol or a readtable itself."
`
(
or
readtable-designator
symbol
))
(
declaim
(
special
*standard-readtable*
*empty-readtable*
))
(
defun
make-readtable
(
name
&key
merge
)
(
define-api
make-readtable
(
name
&key
merge
)
(
named-readtable-designator
&key
(
:merge
list
)
=>
readtable
)
"Creates and returns a new readtable under the specified `name'.
`merge' takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
...
...
@@ -195,36 +204,34 @@ used instead.
An empty readtable is a readtable where the character syntax of each
character is like in the /standard readtable/ except that each
standard macro character has been made a constituent."
(
let
((
merge-list
merge
))
(
check-type
merge-list
list
)
(
cond
((
reserved-readtable-name-p
name
)
(
error
"~A is the designator for a predefined readtable. ~
(
cond
((
reserved-readtable-name-p
name
)
(
error
"~A is the designator for a predefined readtable. ~
Not acceptable as a user-specified readtable name."
name
))
((
let
((
rt
(
find-readtable
name
)))
(
and
rt
(
prog1
nil
(
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.
(
unregister-readtable
rt
)))))
(
t
(
let
((
result
(
apply
#'
merge-readtables-into
;; The first readtable specified in the :merge list is
;; taken as the basis for all subsequent (destructive!)
;; modifications (and hence it's copied.)
(
copy-readtable
(
if
merge
(
ensure-readtable
(
first
merge
-list
))
*empty-readtable*
))
(
rest
merge
-list
))))
((
let
((
rt
(
find-readtable
name
)))
(
and
rt
(
prog1
nil
(
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.
(
unregister-readtable
rt
)))))
(
t
(
let
((
result
(
apply
#'
merge-readtables-into
;; The first readtable specified in the :merge list is
;; taken as the basis for all subsequent (destructive!)
;; modifications (and hence it's copied.)
(
copy-readtable
(
if
merge
(
ensure-readtable
(
first
merge
))
*empty-readtable*
))
(
rest
merge
))))
(
register-readtable
name
result
)))))
)
(
register-readtable
name
result
)))))
(
defun
rename-readtable
(
named-readtable-designator
new-name
)
(
define-api
rename-readtable
(
named-readtable-designator
new-name
)
(
named-readtable-designator
symbol
=>
readtable
)
"Replaces the associated name of the readtable designated by
`named-readtable-designator' with `new-name'. If a readtable is already
registered under `new-name', an error of type READTABLE-DOES-ALREADY-EXIST
is signaled."
(
check-type
named-readtable-designator
named-readtable-designator
)
(
check-type
new-name
symbol
)
(
when
(
find-readtable
new-name
)
(
cerror
"Overwrite existing entry."
'readtable-does-already-exist
:readtable-name
new-name
))
...
...
@@ -238,7 +245,9 @@ is signaled."
(
%associate-readtable-with-name
new-name
readtable
)
readtable
))
(
defun
merge-readtables-into
(
result-table
&rest
named-readtable-designators
)
(
define-api
merge-readtables-into
(
result-readtable
&rest
named-readtable-designators
)
(
named-readtable-designator
&rest
named-readtable-designator
=>
readtable
)
"Copy the contents of each readtable in `named-readtable-designators'
into `result-table'.
...
...
@@ -256,34 +265,28 @@ READER-MACRO-CONFLICT is signaled."
(
check-reader-macro-conflict
from
to
char
subchar
)
(
set-dispatch-macro-character
char
subchar
subfn
to
)))))
to
))
(
s
et
f
result-table
(
ensure-readtable
result-table
))
(
dolist
(
table
(
mapcar
#'
ensure-readtable
named-readtable-designators
))
(
merge-into
result-table
table
))
result-table
))
(
l
et
((
result-table
(
ensure-readtable
result-
read
table
))
)
(
dolist
(
table
(
mapcar
#'
ensure-readtable
named-readtable-designators
))
(
merge-into
result-table
table
))
result-table
))
)
(
defun
ensure-dispatch-macro-character
(
char
&optional
non-terminating-p
(
readtable
*readtable*
))
(
unless
(
dispatch-macro-char-p
char
readtable
)
(
make-dispatch-macro-character
char
non-terminating-p
readtable
)))
(
defun
copy-named-readtable
(
named-readtable-designator
)
(
define-api
copy-named-readtable
(
named-readtable-designator
)
(
named-readtable-designator
=>
readtable
)
"Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument."
(
copy-readtable
(
ensure-readtable
named-readtable-designator
)))
(
def
un
list-all-named-readtables
()
(
def
ine-api
list-all-named-readtables
()
(
=>
list
)
"Returns a list of all registered readtables. The returned list is
guaranteed to be fresh, but may contain duplicates."
(
mapcar
#'
ensure-readtable
(
%list-all-readtable-names
)))
(
deftype
readtable-designator
()
`
(
or
null
readtable
))
(
deftype
named-readtable-designator
()
"Either a symbol or a readtable itself."
`
(
or
readtable-designator
symbol
))
(
define-condition
readtable-error
(
error
)
())
(
define-condition
readtable-does-not-exist
(
readtable-error
)
...
...
@@ -416,10 +419,11 @@ per EQ.)"))
((
eq
reserved-name
:current
)
*readtable*
)
(
t
(
error
"Bug: no such reserved readtable: ~S"
reserved-name
))))
(
defun
find-readtable
(
named-readtable-designator
)
(
define-api
find-readtable
(
named-readtable-designator
)
(
named-readtable-designator
=>
(
or
readtable
null
))
"Looks for the readtable specified by `named-readtable-designator' and
returns it if it is found. Returns NIL otherwise."
(
check-type
named-readtable-designator
named-readtable-designator
)
(
symbol-macrolet
((
designator
named-readtable-designator
))
(
cond
((
readtablep
designator
)
designator
)
((
reserved-readtable-name-p
designator
)
...
...
@@ -431,7 +435,10 @@ returns it if it is found. Returns NIL otherwise."
;;; macros below.)
(
defsetf
find-readtable
register-readtable
)
(
defun
ensure-readtable
(
named-readtable-designator
&optional
(
default
nil
default-p
))
(
define-api
ensure-readtable
(
named-readtable-designator
&optional
(
default
nil
default-p
))
(
named-readtable-designator
&optional
(
or
named-readtable-designator
null
)
=>
readtable
)
"Looks up the readtable specified by `named-readtable-designator' and
returns it if it is found. If it is not found, it registers the readtable
designated by `default' under the name represented by
...
...
@@ -444,16 +451,18 @@ signals an error of type READTABLE-DOES-NOT-EXIST instead."
(
t
(
setf
(
find-readtable
designator
)
(
ensure-readtable
default
))))))
(
defun
register-readtable
(
name
readtable
)
(
define-api
register-readtable
(
name
readtable
)
(
symbol
readtable
=>
readtable
)
"Associate `readtable' with `name'. Returns the readtable."
(
check-type
name
symbol
)
(
check-type
readtable
readtable
)
(
check-type
name
(
not
(
satisfies
reserved-readtable-name-p
)))
(
assert
(
typep
name
'
(
not
(
satisfies
reserved-readtable-name-p
))))
(
%associate-readtable-with-name
name
readtable
)
(
%associate-name-with-readtable
name
readtable
)
readtable
)
(
defun
unregister-readtable
(
named-readtable-designator
)
(
define-api
unregister-readtable
(
named-readtable-designator
)
(
named-readtable-designator
=>
boolean
)
"Remove the association of `named-readtable-designator'. Returns T if
successfull, NIL otherwise."
(
let*
((
readtable
(
find-readtable
named-readtable-designator
))
...
...
@@ -465,11 +474,12 @@ successfull, NIL otherwise."
(
%unassociate-readtable-from-name
readtable-name
readtable
)
(
%unassociate-name-from-readtable
readtable-name
readtable
)))))
(
defun
readtable-name
(
named-readtable-designator
)
(
define-api
readtable-name
(
named-readtable-designator
)
(
named-readtable-designator
=>
symbol
)
"Returns the name of the readtable designated by
`named-readtable-designator', or NIL."
(
check-type
named-readtable-designator
named-readtable-designator
)
(
let
((
readtable
(
ensure-readtable
named-readtable-designator
)))
(
let
((
readtable
(
ensure-readtable
named-readtable-designator
)))
(
cond
((
%readtable-name
readtable
))
((
eq
readtable
*readtable*
)
:current
)
((
eq
readtable
*standard-readtable*
)
:common-lisp
)
...
...
named-readtables/utils.lisp
View file @
2a786e71
...
...
@@ -8,14 +8,6 @@
(
in-package
:editor-hints.named-readtables
)
(
define-condition
simple-style-warning
(
simple-warning
style-warning
)
())
(
defun
simple-style-warn
(
format-control
&rest
format-args
)
(
warn
'simple-style-warning
:format-control
format-control
:format-arguments
format-args
))
(
defmacro
without-package-lock
((
&rest
package-names
)
&body
body
)
(
declare
(
ignorable
package-names
))
#+
clisp
...
...
@@ -63,12 +55,35 @@ corresponding values in the CDR of VALUE."
;;; Taken from Alexandria (which is Public Domain, or BSD.)
(
define-condition
simple-style-warning
(
simple-warning
style-warning
)
())
(
defun
simple-style-warn
(
format-control
&rest
format-args
)
(
warn
'simple-style-warning
:format-control
format-control
:format-arguments
format-args
))
(
define-condition
simple-program-error
(
simple-error
program-error
)
())
(
defun
simple-program-error
(
message
&rest
args
)
(
error
'simple-program-error
:format-control
message
:format-arguments
args
))
(
defun
required-argument
(
&optional
name
)
"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
))
(
defun
ensure-list
(
list
)
"If LIST is a list, it is returned. Otherwise returns the list
designated by LIST."
(
if
(
listp
list
)
list
(
list
list
)))
(
declaim
(
inline
ensure-function
))
; to propagate return type.
(
declaim
(
ftype
(
function
(
t
)
(
values
function
&optional
))
ensure-function
))
...
...
@@ -78,4 +93,153 @@ 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
(
fdefinition
function-designator
)))
(
defun
parse-body
(
body
&key
documentation
whole
)
"Parses BODY into (values remaining-forms declarations doc-string).
Documentation strings are recognized only if DOCUMENTATION is true.
Syntax errors in body are signalled and WHOLE is used in the signal
arguments when given."
(
let
((
doc
nil
)
(
decls
nil
)
(
current
nil
))
(
tagbody
:declarations
(
setf
current
(
car
body
))
(
when
(
and
documentation
(
stringp
current
)
(
cdr
body
))
(
if
doc
(
error
"Too many documentation strings in ~S."
(
or
whole
body
))
(
setf
doc
(
pop
body
)))
(
go
:declarations
))
(
when
(
and
(
listp
current
)
(
eql
(
first
current
)
'declare
))
(
push
(
pop
body
)
decls
)
(
go
:declarations
)))
(
values
body
(
nreverse
decls
)
doc
)))
(
defun
parse-ordinary-lambda-list
(
lambda-list
)
"Parses an ordinary lambda-list, returning as multiple values:
1. Required parameters.
2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP)
where SUPPLIEDP is NIL if not present.
3. Name of the rest parameter, or NIL.
4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP)
where SUPPLIEDP is NIL if not present.
5. Boolean indicating &ALLOW-OTHER-KEYS presence.
6. &AUX parameter specifications, normalized into form (NAME INIT).
Signals a PROGRAM-ERROR is the lambda-list is malformed."
(
let
((
state
:required
)
(
allow-other-keys
nil
)
(
auxp
nil
)
(
required
nil
)
(
optional
nil
)
(
rest
nil
)
(
keys
nil
)
(
aux
nil
))
(
labels
((
simple-program-error
(
format-string
&rest
format-args
)
(
error
'simple-program-error
:format-control
format-string
:format-arguments
format-args
))
(
fail
(
elt
)
(
simple-program-error
"Misplaced ~S in ordinary lambda-list:~% ~S"
elt
lambda-list
))
(
check-variable
(
elt
what
)
(
unless
(
and
(
symbolp
elt
)
(
not
(
constantp
elt
)))
(
simple-program-error
"Invalid ~A ~S in ordinary lambda-list:~% ~S"
what
elt
lambda-list
)))
(
check-spec
(
spec
what
)
(
destructuring-bind
(
init
suppliedp
)
spec
(
declare
(
ignore
init
))
(
check-variable
suppliedp
what
)))
(
make-keyword
(
name
)
"Interns the string designated by NAME in the KEYWORD package."
(
intern
(
string
name
)
:keyword
)))
(
dolist
(
elt
lambda-list
)
(
case
elt
(
&optional
(
if
(
eq
state
:required
)
(
setf
state
elt
)
(
fail
elt
)))
(
&rest
(
if
(
member
state
'
(
:required
&optional
))
(
setf
state
elt
)
(
progn
(
break
"state=~S"
state
)
(
fail
elt
))))
(
&key
(
if
(
member
state
'
(
:required
&optional
:after-rest
))
(
setf
state
elt
)
(
fail
elt
)))
(
&allow-other-keys
(
if
(
eq
state
'&key
)
(
setf
allow-other-keys
t
state
elt
)
(
fail
elt
)))
(
&aux
(
cond
((
eq
state
'&rest
)
(
fail
elt
))
(
auxp
(
simple-program-error
"Multiple ~S in ordinary lambda-list:~% ~S"
elt
lambda-list
))
(
t
(
setf
auxp
t
state
elt
))
))
(
otherwise
(
when
(
member
elt
'#.
(
set-difference
lambda-list-keywords
'
(
&optional
&rest
&key
&allow-other-keys
&aux
)))
(
simple-program-error
"Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"
elt
lambda-list
))
(
case
state
(
:required
(
check-variable
elt
"required parameter"
)
(
push
elt
required
))
(
&optional
(
cond
((
consp
elt
)
(
destructuring-bind
(
name
&rest
tail
)
elt
(
check-variable
name
"optional parameter"
)
(
if
(
cdr
tail
)
(
check-spec
tail
"optional-supplied-p parameter"
)
(
setf
elt
(
append
elt
'
(
nil
))))))
(
t
(
check-variable
elt
"optional parameter"
)
(
setf
elt
(
cons
elt
'
(
nil
nil
)))))
(
push
elt
optional
))
(
&rest
(
check-variable
elt
"rest parameter"
)
(
setf
rest
elt
state
:after-rest
))
(
&key
(
cond
((
consp
elt
)
(
destructuring-bind
(
var-or-kv
&rest
tail
)
elt
(
cond
((
consp
var-or-kv
)
(
destructuring-bind
(
keyword
var
)
var-or-kv
(
unless
(
symbolp
keyword
)
(
simple-program-error
"Invalid keyword name ~S in ordinary ~
lambda-list:~% ~S"
keyword
lambda-list
))
(
check-variable
var
"keyword parameter"
)))
(
t
(
check-variable
var-or-kv
"keyword parameter"
)
(
setf
var-or-kv
(
list
(
make-keyword
var-or-kv
)
var-or-kv
))))
(
if
(
cdr
tail
)
(
check-spec
tail
"keyword-supplied-p parameter"
)
(
setf
tail
(
append
tail
'
(
nil
))))
(
setf
elt
(
cons
var-or-kv
tail
))))
(
t
(
check-variable
elt
"keyword parameter"
)
(
setf
elt
(
list
(
list
(
make-keyword
elt
)
elt
)
nil
nil
))))
(
push
elt
keys
))
(
&aux
(
if
(
consp
elt
)
(
destructuring-bind
(
var
&optional
init
)
elt
(
declare
(
ignore
init
))
(
check-variable
var
"&aux parameter"
))
(
check-variable
elt
"&aux parameter"
))
(
push
elt
aux
))
(
t
(
simple-program-error
"Invalid ordinary lambda-list:~% ~S"
lambda-list
)))))))
(
values
(
nreverse
required
)
(
nreverse
optional
)
rest
(
nreverse
keys
)
allow-other-keys
(
nreverse
aux
))))
\ 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