parent 53256660
Copyright (c) 2007 - 2009 Tobias C. Rittweiler <tcr@freebits.de>
Copyright (c) 2007, Robert P. Goldman <rpgoldman@sift.info> and SIFT, LLC
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the names of Tobias C. Rittweiler, Robert P. Goldman,
SIFT, LLC nor the names of its contributors may be used to
endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY Tobias C. Rittweiler, Robert
P. Goldman and SIFT, LLC ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL Tobias C. Rittweiler, Robert
P. Goldman or SIFT, LLC BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
;;;; -*- mode: Lisp -*-
(in-package :asdf)
(defclass named-readtables-source-file (cl-source-file) ())
#+sbcl
(defmethod perform :around ((o compile-op)
(c named-readtables-source-file))
(let ((sb-ext:*derive-function-types* t))
(call-next-method)))
(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>"
:maintainer "Gábor Melis"
:mailto "mega@retes.hu"
:version "0.9"
:licence "BSD, see LICENSE"
:default-component-class named-readtables-source-file
:pathname "src"
:serial t
:components ((:file "package")
(:file "utils")
(:file "define-api")
(:file "cruft")
(:file "named-readtables"))
:in-order-to ((test-op (test-op "named-readtables/test"))))
(defsystem "named-readtables/test"
:description "Test suite for the Named-Readtables library."
:author "Tobias C. Rittweiler <trittweiler@common-lisp.net>"
:maintainer "Gábor Melis"
:mailto "mega@retes.hu"
:depends-on ("named-readtables")
:pathname "test"
:serial t
:default-component-class named-readtables-source-file
:components
((:file "package")
(:file "rt")
(:file "tests"))
:perform (test-op (o c) (symbol-call :named-readtables-test '#:do-tests)))
;;; MGL-PAX depends on NAMED-READTABLES so we must put documentation
;;; in a separate system in order to be able to use MGL-PAX.
(defsystem "named-readtables/doc"
:depends-on ("named-readtables" "mgl-pax")
:pathname "src"
:components ((:file "doc")))
This diff is collapsed.
(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))
(locally
;;; Muffle the annoying "&OPTIONAL and &KEY found in
;;; the same lambda list" style-warning
#+sbcl (declare (sb-ext:muffle-conditions style-warning))
(defun ,name ,lambda-list
,docstring
#+sbcl (declare (sb-ext:unmuffle-conditions style-warning))
,@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))))))))
(in-package :named-readtables)
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :mgl-pax))
(defsection @named-readtables-manual (:title "Named Readtables Manual")
(named-readtables asdf:system)
(@named-readtables-introduction section)
(@named-readtables-overview section)
(@named-readtables-reference section))
(defsection @named-readtables-introduction (:title "Introduction")
"Named-Readtables is a library that provides a namespace for
readtables akin to the already-existing namespace of packages. In
particular:
* you can associate readtables with names, and retrieve
readtables by names;
* you can associate source files with readtable names, and be
sure that the right readtable is active when compiling/loading
the file;
* similiarly, your development environment now has a chance to
automatically determine what readtable should be active while
processing source forms on interactive commands. (E.g. think of
`C-c C-c` in Slime (yet to be done))
It follows that Named-Readtables is a facility for using readtables in
a localized way.
Additionally, it also attempts to become a facility for using
readtables in a _modular_ way. In particular:
* it provides a macro to specify the content of a readtable at a
glance;
* it makes it possible to use multiple inheritance between readtables."
(@named-readtables-links section)
(@named-readtables-acknowledgements section))
(defsection @named-readtables-links (:title "Links")
"Here is the [official repository][named-readtables-repo] and the
[HTML documentation][named-readtables-doc] for the latest version.
[named-readtables-repo]: https://github.com/melisgl/named-readtables
[named-readtables-doc]: http://melisgl.github.io/mgl-pax-world/named-readtables-manual.html")
(defsection @named-readtables-acknowledgements (:title "Acknowledgements")
"Thanks to Robert Goldman for making me want to write this library.
Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart
Botta, David Crawford, and Pascal Costanza for being early adopters,
providing comments and bugfixes.")
(defsection @named-readtables-overview (:title "Overview")
(@named-readtables-api-notes section)
(@named-readtables-api-idiosyncrasies section)
(@named-readtables-preregistered section)
(@named-readtables-examples section))
(defsection @named-readtables-api-notes (:title "Notes on the API" :export nil)
"The API heavily imitates the API of packages. This has the nice
property that any experienced Common Lisper will take it up without
effort.
DEFREADTABLE - DEFPACKAGE
IN-READTABLE - IN-PACKAGE
MERGE-READTABLES-INTO - USE-PACKAGE
MAKE-READTABLE - MAKE-PACKAGE
UNREGISTER-READTABLE - DELETE-PACKAGE
RENAME-READTABLE - RENAME-PACKAGE
FIND-READTABLE - FIND-PACKAGE
READTABLE-NAME - PACKAGE-NAME
LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES")
(defsection @named-readtables-api-idiosyncrasies
(:title "Important API idiosyncrasies" :export nil)
"There are three major differences between the API of Named-Readtables,
and the API of packages.
1. Readtable names are symbols not strings.
Time has shown that the fact that packages are named by strings
causes severe headache because of the potential of package names
colliding with each other.
Hence, readtables are named by symbols lest to make the
situation worse than it already is. Consequently, readtables
named `CL-ORACLE:SQL-SYNTAX` and `CL-MYSQL:SQL-SYNTAX` can
happily coexist next to each other. Or, taken to an extreme,
`SCHEME:SYNTAX` and `ELISP:SYNTAX`.
If, for example to duly signify the importance of your cool
readtable hack, you really think it deserves a global name, you
can always resort to keywords.
2. The inheritance is resolved statically, not dynamically.
A package that uses another package will have access to all the
other package's exported symbols, even to those that will be
added after its definition. I.e. the inheritance is resolved at
run-time, that is dynamically.
Unfortunately, we cannot do the same for readtables in a
portable manner.
Therefore, we do not talk about \"using\" another readtable but
about \"merging\" the other readtable's definition into the
readtable we are going to define. I.e. the inheritance is
resolved once at definition time, that is statically.
(Such merging can more or less be implemented portably albeit at
a certain cost. Most of the time, this cost manifests itself at
the time a readtable is defined, i.e. once at compile-time, so
it may not bother you. Nonetheless, we provide extra support for
Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your
implementation of choice are welcome, of course.)
3. DEFREADTABLE does not have compile-time effects.
If you define a package via DEFPACKAGE, you can make that
package the currently active package for the subsequent
compilation of the same file via IN-PACKAGE. The same is,
however, not true for DEFREADTABLE and IN-READTABLE for the
following reason:
It's unlikely that the need for special reader-macros arises for
a problem which can be solved in just one file. Most often,
you're going to define the reader macro functions, and set up
the corresponding readtable in an extra file.
If DEFREADTABLE had compile-time effects, you'd have to wrap
each definition of a reader-macro function in an EVAL-WHEN to
make its definition available at compile-time. Because that's
simply not the common case, DEFREADTABLE does not have a
compile-time effect.
If you want to use a readtable within the same file as its
definition, wrap the DEFREADTABLE and the reader-macro function
definitions in an explicit EVAL-WHEN.")
(defsection @named-readtables-preregistered (:title "Preregistered Readtables"
:export nil)
"- NIL, :STANDARD, and :COMMON-LISP designate the
_standard readtable_.
- :MODERN designates a _case-preserving_ _standard-readtable_.
- :CURRENT designates the _current readtable_.")
(defsection @named-readtables-examples (:title "Examples" :export nil)
"```commonlisp
(defreadtable elisp:syntax
(:merge :standard)
(:macro-char #\\? #'elisp::read-character-literal t)
(:macro-char #\\[ #'elisp::read-vector-literal t)
...
(:case :preserve))
(defreadtable scheme:syntax
(:merge :standard)
(:macro-char #\\[ #'(lambda (stream char)
(read-delimited-list #\\] stream)))
(:macro-char #\\# :dispatch)
(:dispatch-macro-char #\\# #\\t #'scheme::read-#t)
(:dispatch-macro-char #\\# #\\f #'scheme::read-#f)
...
(:case :preserve))
(in-readtable elisp:syntax)
...
(in-readtable scheme:syntax)
...
```")
(defsection @named-readtables-reference (:title "Reference")
(defreadtable macro)
(in-readtable macro)
(make-readtable function)
(merge-readtables-into function)
(find-readtable function)
(ensure-readtable function)
(rename-readtable function)
(readtable-name function)
(register-readtable function)
(unregister-readtable function)
(copy-named-readtable function)
(list-all-named-readtables function)
(named-readtable-designator type)
(reader-macro-conflict condition)
(readtable-does-already-exist condition)
(readtable-does-not-exist condition))
;;;; Generating own docs
(defun update-readmes ()
(with-open-file (stream (asdf:system-relative-pathname :named-readtables
"README.md")
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(document @named-readtables-manual :stream stream)
(print-markdown-footer stream))
(with-open-file (stream (asdf:system-relative-pathname :named-readtables
"README")
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(describe @named-readtables-manual stream)
(print-markdown-footer stream)))
(defun print-markdown-footer (stream)
(format stream "~%* * *~%")
(format stream "###### \\[generated by ~
[MGL-PAX](https://github.com/melisgl/mgl-pax)\\]~%"))
#|
(update-readmes)
|#
This diff is collapsed.
(in-package :common-lisp-user)
;;; This is is basically MGL-PAX:DEFINE-PACKAGE but we don't have it
;;; defined yet. The package variance stuff is because we export
;;; documentation from the NAMED-READTABLES-DOC system.
(eval-when (:compile-toplevel :load-toplevel :execute)
(locally
(declare #+sbcl
(sb-ext:muffle-conditions sb-kernel::package-at-variance))
(handler-bind
(#+sbcl (sb-kernel::package-at-variance #'muffle-warning))
(defpackage :editor-hints.named-readtables
(:use :common-lisp)
(:nicknames :named-readtables)
(:export
#:defreadtable
#:in-readtable
#:make-readtable
#:merge-readtables-into
#:find-readtable
#:ensure-readtable
#:rename-readtable
#:readtable-name
#:register-readtable
#:unregister-readtable
#:copy-named-readtable
#:list-all-named-readtables
;; Types
#:named-readtable-designator
;; Conditions
#:reader-macro-conflict
#:readtable-does-already-exist
#:readtable-does-not-exist)
(:documentation "See NAMED-READTABLES:@NAMED-READTABLES-MANUAL.")))))
(pushnew :named-readtables *features*)
This diff is collapsed.
Copyright (c) 2007 - 2009 Tobias C. Rittweiler <tcr@freebits.de>
Copyright (c) 2007, Robert P. Goldman <rpgoldman@sift.info> and SIFT, LLC
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the names of Tobias C. Rittweiler, Robert P. Goldman,
SIFT, LLC nor the names of its contributors may be used to
endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY Tobias C. Rittweiler, Robert
P. Goldman and SIFT, LLC ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL Tobias C. Rittweiler, Robert
P. Goldman or SIFT, LLC BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
;;;; -*- mode: Lisp -*-
(in-package :asdf)
(defclass named-readtables-source-file (cl-source-file) ())
#+sbcl
(defmethod perform :around ((o compile-op)
(c named-readtables-source-file))
(let ((sb-ext:*derive-function-types* t))
(call-next-method)))
(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>"
:maintainer "Gábor Melis"
:mailto "mega@retes.hu"
:version "0.9"
:licence "BSD, see LICENSE"
:default-component-class named-readtables-source-file
:pathname "src"
:serial t
:components ((:file "package")
(:file "utils")
(:file "define-api")
(:file "cruft")
(:file "named-readtables"))
:in-order-to ((test-op (test-op "named-readtables/test"))))
(defsystem "named-readtables/test"
:description "Test suite for the Named-Readtables library."
:author "Tobias C. Rittweiler <trittweiler@common-lisp.net>"
:maintainer "Gábor Melis"
:mailto "mega@retes.hu"
:depends-on ("named-readtables")
:pathname "test"
:serial t
:default-component-class named-readtables-source-file
:components
((:file "package")
(:file "rt")
(:file "tests"))
:perform (test-op (o c) (symbol-call :named-readtables-test '#:do-tests)))
;;; MGL-PAX depends on NAMED-READTABLES so we must put documentation
;;; in a separate system in order to be able to use MGL-PAX.
(defsystem "named-readtables/doc"
:depends-on ("named-readtables" "mgl-pax")
:pathname "src"
:components ((:file "doc")))
;;; -*- Mode:Lisp -*-
(in-package :cl-user)
(defpackage :named-readtables-test
(:use :cl :named-readtables)
(:import-from :named-readtables
#:dispatch-macro-char-p
#:do-readtable
#:ensure-function
#:ensure-dispatch-macro-character
#:function=))
\ No newline at end of file
#|----------------------------------------------------------------------------|
| Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
| |
| Permission to use, copy, modify, and distribute this software and its |
| documentation for any purpose and without fee is hereby granted, provided |
| that this copyright and permission notice appear in all copies and |
| supporting documentation, and that the name of M.I.T. not be used in |
| advertising or publicity pertaining to distribution of the software |
| without specific, written prior permission. M.I.T. makes no |
| representations about the suitability of this software for any purpose. |
| It is provided "as is" without express or implied warranty. |
| |
| M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
| ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
| M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
| ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
| WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
| ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
| SOFTWARE. |
|----------------------------------------------------------------------------|#
;; (defpackage :rt
;; (:use #:cl)
;; (:export #:*do-tests-when-defined* #:*test* #:continue-testing
;; #:deftest #:do-test #:do-tests #:get-test #:pending-tests
;; #:rem-all-tests #:rem-test)
;; (:documentation "The MIT regression tester"))
;; (in-package :rt)
(in-package :named-readtables-test)
(defvar *test* nil "Current test name")
(defvar *do-tests-when-defined* nil)
(defvar *entries* '(nil) "Test database")
(defvar *in-test* nil "Used by TEST")
(defvar *debug* nil "For debugging")
(defvar *catch-errors* t
"When true, causes errors in a test to be caught.")
(defvar *print-circle-on-failure* nil
"Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
(defvar *compile-tests* nil
"When true, compile the tests before running them.")
(defvar *optimization-settings* '((safety 3)))
(defvar *expected-failures* nil
"A list of test names that are expected to fail.")
(defstruct (entry (:conc-name nil)
(:type list))
pend name form)
(defmacro vals (entry) `(cdddr ,entry))
(defmacro defn (entry) `(cdr ,entry))
(defun pending-tests ()
(do ((l (cdr *entries*) (cdr l))
(r nil))
((null l) (nreverse r))
(when (pend (car l))
(push (name (car l)) r))))
(defun rem-all-tests ()
(setq *entries* (list nil))
nil)
(defun rem-test (&optional (name *test*))
(do ((l *entries* (cdr l)))
((null (cdr l)) nil)
(when (equal (name (cadr l)) name)
(setf (cdr l) (cddr l))
(return name))))
(defun get-test (&optional (name *test*))
(defn (get-entry name)))
(defun get-entry (name)
(let ((entry (find name (cdr *entries*)
:key #'name
:test #'equal)))
(when (null entry)
(report-error t
"~%No test with name ~:@(~S~)."
name))
entry))
(defmacro deftest (name form &rest values)
`(add-entry '(t ,name ,form .,values)))
(defun add-entry (entry)
(setq entry (copy-list entry))
(do ((l *entries* (cdr l))) (nil)
(when (null (cdr l))
(setf (cdr l) (list entry))
(return nil))
(when (equal (name (cadr l))
(name entry))
(setf (cadr l) entry)
(report-error nil
"Redefining test ~:@(~S~)"
(name entry))
(return nil)))
(when *do-tests-when-defined*
(do-entry entry))
(setq *test* (name entry)))
(defun report-error (error? &rest args)
(cond (*debug*
(apply #'format t args)
(if error? (throw '*debug* nil)))
(error? (apply #'error args))
(t (apply #'warn args))))
(defun do-test (&optional (name *test*))
(do-entry (get-entry name)))
(defun equalp-with-case (x y)
"Like EQUALP, but doesn't do case conversion of characters."
(cond
((eq x y) t)
((consp x)
(and (consp y)
(equalp-with-case (car x) (car y))
(equalp-with-case (cdr x) (cdr y))))
((and (typep x 'array)
(= (array-rank x) 0))
(equalp-with-case (aref x) (aref y)))
((typep x 'vector)
(and (typep y 'vector)
(let ((x-len (length x))
(y-len (length y)))
(and (eql x-len y-len)
(loop
for e1 across x
for e2 across y
always (equalp-with-case e1 e2))))))
((and (typep x 'array)
(typep y 'array)
(not (equal (array-dimensions x)
(array-dimensions y))))
nil)
((typep x 'array)
(and (typep y 'array)
(let ((size (array-total-size x)))
(loop for i from 0 below size
always (equalp-with-case (row-major-aref x i)
(row-major-aref y i))))))
(t (eql x y))))
(defun do-entry (entry &optional
(s *standard-output*))
(catch '*in-test*
(setq *test* (name entry))
(setf (pend entry) t)
(let* ((*in-test* t)
;; (*break-on-warnings* t)
(aborted nil)
r)
;; (declare (special *break-on-warnings*))
(block aborted
(setf r
(flet ((%do
()
(if *compile-tests*
(multiple-value-list
(funcall (compile
nil
`(lambda ()