[Advanced-readtable-cvs] r6 -
rklochkov at common-lisp.net
rklochkov at common-lisp.net
Sun Dec 9 05:47:35 UTC 2012
Author: rklochkov
Date: Sat Dec 8 21:47:35 2012
New Revision: 6
Log:
Fixed FIND-SYMBOL and FIND-PACKAGE
Modified:
package.lisp
src.lisp
Modified: package.lisp
==============================================================================
--- package.lisp Sat Dec 8 10:04:29 2012 (r5)
+++ package.lisp Sat Dec 8 21:47:35 2012 (r6)
@@ -17,4 +17,5 @@
#:*disable-symbol-readmacro*
#:push-import-prefix
#:push-local-nickname
- #:push-local-package))
+ #:push-local-package
+ #:set-handler))
Modified: src.lisp
==============================================================================
--- src.lisp Sat Dec 8 10:04:29 2012 (r5)
+++ src.lisp Sat Dec 8 21:47:35 2012 (r6)
@@ -10,9 +10,10 @@
;;; package::symbol1 and package::symbol2
(defvar *per-package-finders* (make-hash-table :test 'eq)
- "Hash package -> list of handlers")
+ "Hash package -> list of handlers. Each handler is a cons (key . function)")
(defvar *package-finders* nil
- "List of handlers (lambda (name package) ...) -> package")
+ "List of handlers. Each handler is a cons (key . function)
+function = (lambda (name package) ...) -> package")
@@ -40,25 +41,31 @@
(type string name)
(type (or null package) package))
(when handlers-list
- (or (funcall (car handlers-list) name package)
+ (or (funcall (cdr (car handlers-list)) name package)
(try-funcall (cdr handlers-list) name package))))
(defun find-package (name &optional (current-package *package*))
+ "We try to find package.
+1. By full name with CL:FIND-PACKAGE.
+2. By per-package handlers. Here we wil try local-nicknames and so on.
+3. By global handlers. Here we may use, for example, hierarchical packages."
(declare (type (or null package) current-package))
(if (typep name 'package) name
(let ((sname (string name)))
- (or
+ (or
+ (cl:find-package name)
(when current-package
(try-funcall (package-finders current-package) sname current-package))
- (try-funcall *package-finders* sname current-package)
- (cl:find-package name)))))
+ (try-funcall *package-finders* sname current-package)))))
(defvar *package-symbol-finders* (make-hash-table :test 'eq)
- "Hash package -> list of handlers")
+ "Hash package -> list of handlers. Each handler is a cons (key . function)")
(defvar *symbol-finders* nil
- "List of handlers (lambda (name package) ...) -> symbol")
+ "List of handlers. Each handler is a cons (key . function)
+function = (lambda (name package) ...) -> symbol")
(defvar *extra-finders* (make-hash-table :test 'eq)
- "Hash symbol -> list of handlers (lambda (name package) ...) -> symbol
+ "Hash symbol -> list of handlers. Each handler is a cons (key . function)
+function = (lambda (name package) ...) -> symbol
These will be used before CL:FIND-SYMBOL")
(defvar *symbol-readmacros* (make-hash-table :test 'eq))
@@ -103,15 +110,21 @@
(type (or null package) package))
(when handlers-list
(multiple-value-bind (symbol status)
- (funcall (car handlers-list) name package)
+ (funcall (cdr (car handlers-list)) name package)
(if symbol
(values symbol status)
(try-funcall (cdr handlers-list) name package)))))
(defun find-symbol (name &optional dpackage)
+ "We try to find symbol
+1. In package set with car of list, for example, PUSh-LOCAL-PACKAGE
+2. By CL-FIND-SYMBOL
+3. By packages added with package:(...)
+4. By per-package finders
+5. By global finders"
(declare (type string name))
- (let ((package (find-package dpackage)))
+ (let ((package (if dpackage (find-package dpackage) *package*)))
(macrolet ((mv-or (&rest clauses)
(if clauses
`(multiple-value-bind (symbol status) ,(car clauses)
@@ -121,12 +134,10 @@
(mv-or
(try-mv-funcall *extra-symbol-finders* name package)
- (unless package (try-local-packages *local-packages* name))
- (when package (try-mv-funcall (symbol-finders package) name package))
- (try-mv-funcall *symbol-finders* name package)
- (if package
- (cl:find-symbol name package)
- (cl:find-symbol name))))))
+ (cl:find-symbol name package)
+ (unless dpackage (try-local-packages *local-packages* name))
+ (try-mv-funcall (symbol-finders package) name package)
+ (try-mv-funcall *symbol-finders* name package)))))
(defun read-token (stream)
"
@@ -151,7 +162,7 @@
(return-from read-after-colon
(if (symbolp maybe-package)
(let ((name (symbol-name maybe-package)))
- (or (find-symbol name)(intern name)))
+ (or (find-symbol name) (intern name)))
maybe-package)))
(let ((package (find-package maybe-package)))
@@ -231,6 +242,19 @@
(defun extra-finders (symbol)
(gethash symbol *extra-finders*))
+(defmacro set-handler (handler-list key function)
+ (let ((key-var (gensym "key")))
+ `(let ((,key-var ,key))
+ (unless (assoc ,key-var ,handler-list)
+ (push (cons ,key-var ,function)
+ ,handler-list)))))
+
+(defmacro %set-handler (handler-list key name &body handler-body)
+ "Local macros for push-* functions. No gensyms intended."
+ (set-handler ,handler-list ,key
+ (lambda (,name package)
+ (declare (ignore package)) . ,handler-body)))
+
(defun push-import-prefix (prefix &optional (package *package*))
"Enables using package name omitting prefix.
For example, you have packages com.clearly-useful.iterator-protocol, com.clearly-useful.reducers, ...
@@ -248,11 +272,9 @@
after that reducers:... will refer to new package, not com.clearly-useful.reducers.
"
- (push (lambda (name package)
- (declare (ignore package))
- (or (cl:find-package name)
- (cl:find-package (concatenate 'string prefix "." name))))
- (package-finders package)))
+ (%set-handler (package-finders package) (list :prefix prefix) name
+ (or (cl:find-package name)
+ (cl:find-package (concatenate 'string prefix "." name)))))
(defun push-local-nickname (long-package nick
&optional (current-package *package*))
@@ -273,13 +295,11 @@
(push-local-nickname :lib1 :lib :a)
"
(let ((dpackage (find-package long-package)))
- (push (lambda (name package)
- (declare (ignore package))
- (when (string= name (string nick)) dpackage))
- (package-finders current-package))))
+ (%set-handler (package-finders current-package) (list :nick long-package nick) name
+ (when (string= name (string nick)) dpackage))))
(defun push-local-package (symbol local-package)
- "Sets local-package for a symbol. Many macroses use the own clauses.
+ "Sets local-package for a symbol. Many macroses use there own clauses.
For example, ITERATE uses FOR, COLLECT and so on.
If you don't want to USE-PACKAGE iterate, this function will help.
(push-local-package 'iter:iter :iterate)
@@ -292,11 +312,9 @@
, because first for is in ITERATE package, but second -- is not.
"
(let ((dpackage (find-package local-package)))
- (push (lambda (name package)
- (declare (ignore package))
- (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
- (when (eq status :external) symbol)))
- (extra-finders symbol))))
+ (%set-handler (extra-finders symbol) (list :nick long-package nick) name
+ (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
+ (when (eq status :external) symbol)))))
;;;
;;; Readtable analysis and change
More information about the Advanced-readtable-cvs
mailing list