Commit 2a786e71 authored by Tobias C. Rittweiler's avatar Tobias C. Rittweiler

Introduce DEFINE-API macro.

darcs-hash:20090925212555-f5546-38a5138a7c57bf85dc2148b811ee448a022f563b.gz
parent ea624e40
......@@ -287,7 +287,6 @@
(let ((iter (gensym "ITER+"))
(more? (gensym "MORE?+"))
(rt (gensym "READTABLE+")))
`(let ((,rt ,readtable))
(with-readtable-iterator (,iter ,rt)
(loop
......
(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
......@@ -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))))
......
......@@ -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))
(setf result-table (ensure-readtable result-table))
(dolist (table (mapcar #'ensure-readtable named-readtable-designators))
(merge-into result-table table))
result-table))
(let ((result-table (ensure-readtable result-readtable)))
(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)))
(defun list-all-named-readtables ()
(define-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)
......
......@@ -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
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