Commit f21fef0b authored by Tobias C. Rittweiler's avatar Tobias C. Rittweiler

Initial Revision. Taken from SVN repository.

darcs-hash:20080923101340-f5546-55f59107aa0318117e917007f997e27c8e1df7e4.gz
parents
(in-package :editor-hints.named-readtables)
(defvar *readtable-names* (make-hash-table :test 'eq))
(declaim (inline %register-readtable-name))
(defun %register-readtable-name (string-designator read-table)
(setf (gethash read-table *readtable-names*)
(string string-designator)))
(declaim (inline %unregister-readtable-name))
(defun %unregister-readtable-name (read-table)
(remhash read-table *readtable-names*))
(declaim (inline %readtable-name))
(defun %readtable-name (read-table)
(values (gethash read-table *readtable-names*)))
(declaim (inline %list-all-readtable-names))
(defun %list-all-readtable-names ()
(list* "STANDARD" "CURRENT"
(loop for name being each hash-value of *readtable-names*
collect name)))
#-allegro
(progn
(defvar *named-readtables* (make-package (gensym "READTABLES+")))
(declaim (inline %register-readtable))
(defun %register-readtable (string-designator read-table)
(let ((name (intern (string string-designator) *named-readtables*)))
(setf (symbol-value name) read-table)))
(declaim (inline %unregister-readtable))
(defun %unregister-readtable (string-designator)
(let ((name (find-symbol (string string-designator) *named-readtables*)))
(when name
(setf (symbol-value name) nil)
(unintern name *named-readtables*))))
(declaim (inline %find-readtable-from-name))
(defun %find-readtable-from-name (string-designator)
(let ((name (find-symbol (string string-designator) *named-readtables*)))
(and name (symbol-value name)))))
#+allegro
(progn
(defun %register-readtable (string-designator read-table)
(let ((name (intern (string string-designator) :keyword)))
(setf (named-readtable name) read-table)))
(defun %unregister-readtable (string-designator)
(let ((name (intern (string string-designator) :keyword)))
(setf (named-readtable name) nil)))
(defun %find-readtable-from-name (string-designator)
(let ((name (find-symbol (string string-designator) :keyword)))
(and name (named-readtable name)))))
(in-package :editor-hints.named-readtables)
;;; Taken from SWANK (which is Public Domain.)
(defmacro destructure-case (value &rest patterns)
"Dispatch VALUE to one of PATTERNS.
A cross between `case' and `destructuring-bind'.
The pattern syntax is:
((HEAD . ARGS) . BODY)
The list of patterns is searched for a HEAD `eq' to the car of
VALUE. If one is found, the BODY is executed with ARGS bound to the
corresponding values in the CDR of VALUE."
(let ((operator (gensym "op-"))
(operands (gensym "rand-"))
(tmp (gensym "tmp-")))
`(let* ((,tmp ,value)
(,operator (car ,tmp))
(,operands (cdr ,tmp)))
(case ,operator
,@(loop for (pattern . body) in patterns collect
(if (eq pattern t)
`(t ,@body)
(destructuring-bind (op &rest rands) pattern
`(,op (destructuring-bind ,rands ,operands
,@body)))))
,@(if (eq (caar (last patterns)) t)
'()
`((t (error "destructure-case failed: ~S" ,tmp))))))))
\ No newline at end of file
(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"
:licence "BSD"
:components
((:file "package")
(:file "destructure-case")
(:file "cruft")
(:file "named-readtables")))
\ No newline at end of file
This diff is collapsed.
(in-package "COMMON-LISP-USER")
(defpackage :editor-hints.named-readtables
(:use :common-lisp)
(:nicknames :named-readtables)
(:export
#:defreadtable
#:in-readtable
#:make-readtable
#:find-readtable
#:ensure-readtable
#:rename-readtable
#:readtable-name
#:register-readtable
#:unregister-readtable
#:list-all-named-readtables
#:named-readtable-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