/[advanced-readtable]/src.lisp
ViewVC logotype

Diff of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 4 by rklochkov, Sat Dec 8 06:20:09 2012 UTC revision 9 by rklochkov, Sun Dec 23 10:43:24 2012 UTC
# Line 1  Line 1 
1  (in-package #:advanced-readtable)  (in-package #:advanced-readtable)
2    
3  ;;; Advanced-readtable  ;;;; Advanced-readtable
4  ;;;  ;;;;
5  ;;; per-package aliases for packages  ;;;; per-package aliases for packages
6  ;;; per-package shortcuts for package hierarchies  ;;;; per-package shortcuts for package hierarchies
7  ;;; extendable find-package and find-symbol  ;;;; extendable find-package and find-symbol
8  ;;; local use pcakage in form package:(here form where package used)  ;;;; local use package in form package:(here form where package used)
9  ;;; local intern package like in SBCL: package::(symbol1 symbol2) will intern  ;;;; local intern package like in SBCL: package::(symbol1 symbol2) will intern
10  ;;;                                    package::symbol1 and package::symbol2  ;;;;                                    package::symbol1 and package::symbol2
11    
12  (defvar *per-package-finders* (make-hash-table :test 'eq)  (defvar *per-package-finders* (make-hash-table :test 'eq)
13    "Hash package -> list of handlers")    "Hash package -> list of handlers. Each handler is a cons (key . function)")
14  (defvar *package-finders* nil  (defvar *package-finders* nil
15    "List of handlers (lambda (name package) ...) -> package")    "List of handlers. Each handler is a cons (key . function)
16    function = (lambda (name package) ...) -> package")
17    
18    
19    
# Line 40  Line 41 
41             (type string name)             (type string name)
42             (type (or null package) package))             (type (or null package) package))
43    (when handlers-list    (when handlers-list
44      (or (funcall (car handlers-list) name package)      (or (funcall (cdr (car handlers-list)) name package)
45          (try-funcall (cdr handlers-list) name package))))          (try-funcall (cdr handlers-list) name package))))
46    
47  (defun find-package (name &optional (current-package *package*))  (defun find-package (name &optional (current-package *package*))
48      "We try to find package.
49    1. By full name with CL:FIND-PACKAGE.
50    2. By per-package handlers. Here we wil try local-nicknames and so on.
51    3. By global handlers. Here we may use, for example, hierarchical packages."
52    (declare (type (or null package) current-package))    (declare (type (or null package) current-package))
53    (if (typep name 'package) name    (if (typep name 'package) name
54        (let ((sname (string name)))        (let ((sname (string name)))
55          (or          (or
56             (cl:find-package name)
57           (when current-package           (when current-package
58             (try-funcall (package-finders current-package) sname current-package))             (try-funcall (package-finders current-package) sname current-package))
59           (try-funcall *package-finders* sname current-package)           (try-funcall *package-finders* sname current-package)))))
          (cl:find-package name)))))  
60    
61  (defvar *package-symbol-finders* (make-hash-table :test 'eq)  (defvar *package-symbol-finders* (make-hash-table :test 'eq)
62    "Hash package -> list of handlers")    "Hash package -> list of handlers. Each handler is a cons (key . function)")
63  (defvar *symbol-finders* nil  (defvar *symbol-finders* nil
64    "List of handlers (lambda (name package) ...) -> symbol")    "List of handlers. Each handler is a cons (key . function)
65    function =  (lambda (name package) ...) -> symbol")
66  (defvar *extra-finders* (make-hash-table :test 'eq)  (defvar *extra-finders* (make-hash-table :test 'eq)
67    "Hash symbol -> list of handlers (lambda (name package) ...) -> symbol    "Hash symbol -> list of handlers. Each handler is a cons (key . function)
68    function = (lambda (name package) ...) -> symbol
69  These will be used before CL:FIND-SYMBOL")  These will be used before CL:FIND-SYMBOL")
70    
71  (defvar *symbol-readmacros* (make-hash-table :test 'eq))  (defvar *symbol-readmacros* (make-hash-table :test 'eq))
# Line 103  Returns function, assigned by set-macro- Line 110  Returns function, assigned by set-macro-
110             (type (or null package) package))             (type (or null package) package))
111    (when handlers-list    (when handlers-list
112      (multiple-value-bind (symbol status)      (multiple-value-bind (symbol status)
113          (funcall (car handlers-list) name package)          (funcall (cdr (car handlers-list)) name package)
114        (if symbol        (if symbol
115            (values symbol status)            (values symbol status)
116            (try-funcall (cdr handlers-list) name package)))))            (try-funcall (cdr handlers-list) name package)))))
117    
118    
119  (defun find-symbol (name &optional dpackage)  (defun find-symbol (name &optional dpackage)
120      "We try to find symbol
121    1. In package set with car of list, for example, PUSH-LOCAL-PACKAGE
122    2. By CL-FIND-SYMBOL, when package explicitly given
123    3. By packages added with package:(...)
124    4. By per-package finders
125    5. By global finders
126    6. By CL-FIND-SYMBOL"
127    (declare (type string name))    (declare (type string name))
128    (let ((package (find-package dpackage)))    (let ((package (if dpackage (find-package dpackage) *package*)))
129      (macrolet ((mv-or (&rest clauses)      (macrolet ((mv-or (&rest clauses)
130                   (if clauses                   (if clauses
131                       `(multiple-value-bind (symbol status) ,(car clauses)                       `(multiple-value-bind (symbol status) ,(car clauses)
# Line 121  Returns function, assigned by set-macro- Line 135  Returns function, assigned by set-macro-
135    
136        (mv-or        (mv-or
137         (try-mv-funcall *extra-symbol-finders* name package)         (try-mv-funcall *extra-symbol-finders* name package)
138         (unless package (try-local-packages *local-packages* name))         (when dpackage (cl:find-symbol name package))
139         (when package (try-mv-funcall (symbol-finders package) name package))         (unless dpackage (try-local-packages *local-packages* name))
140           (try-mv-funcall (symbol-finders package) name package)
141         (try-mv-funcall *symbol-finders* name package)         (try-mv-funcall *symbol-finders* name package)
142         (if package         (unless dpackage (cl:find-symbol name package))))))
            (cl:find-symbol name package)  
            (cl:find-symbol name))))))  
143    
144  (defun read-token (stream)  (defun read-token (stream)
145    "    "
# Line 147  RETURN: number of the colons" Line 160  RETURN: number of the colons"
160    
161  (defun read-after-colon (stream maybe-package colons)  (defun read-after-colon (stream maybe-package colons)
162    "Read symbol package:sym or list package:(...)"    "Read symbol package:sym or list package:(...)"
163    (when (= colons 0)    (when (= colons 0) ; no colon: this is a symbol or an atom
164      (return-from read-after-colon      (return-from read-after-colon
165        (if (symbolp maybe-package)        (if (symbolp maybe-package)
166            (let ((name (symbol-name maybe-package)))            (let ((name (symbol-name maybe-package)))
167              (or (find-symbol name)(intern name)))              (or (find-symbol name) (intern name)))
168            maybe-package)))            maybe-package)))
169    
170    (let ((package (find-package maybe-package)))    (let ((package (find-package maybe-package)))
# Line 168  RETURN: number of the colons" Line 181  RETURN: number of the colons"
181                 (read stream nil))))))                 (read stream nil))))))
182    
183      (let ((token (read-token stream)))      (let ((token (read-token stream)))
184          (check-type token symbol)
185        (multiple-value-bind (symbol status)        (multiple-value-bind (symbol status)
186            (find-symbol token package)            (find-symbol (symbol-name token) package)
187          (unintern token)          (unintern token)
188          (when (and (= colons 1) (not (eq status :external)))          (when (and (= colons 1) (not (eq status :external)))
189            (cerror "Use anyway"            (cerror "Use anyway"
# Line 230  RETURN: number of the colons" Line 244  RETURN: number of the colons"
244  (defun extra-finders (symbol)  (defun extra-finders (symbol)
245    (gethash symbol *extra-finders*))    (gethash symbol *extra-finders*))
246    
247    (defmacro set-handler (handler-list key function)
248      "This is middle-level public API for changing handlers for
249    find-symbol and find-package. There are five lists:
250      *package-finders* -- global for find-package
251      *symbol-finders* -- global for find-symbol
252      (package-finders package) -- per-package for find-package
253      (symbol-finders package) -- per-package for find-symbol
254      (extra-finders symbol) -- per-symbol for (symbol ....) package substitution
255    
256    Key should be uniq in the sense of EQUAL in the list. SET-HANDLER adds
257    new handler if it is not already there.
258    "
259      (let ((key-var (gensym "key")))
260        `(let ((,key-var ,key))
261           (unless (assoc ,key-var ,handler-list :test #'equal)
262             (push (cons ,key-var ,function)
263                   ,handler-list)))))
264    
265    (defmacro %set-handler (handler-list key name &body handler-body)
266      "Local macros for push-* functions. No gensyms intended."
267      `(set-handler ,handler-list ,key
268                    (lambda (,name package)
269                      (declare (ignore package)) . ,handler-body)))
270    
271  (defun push-import-prefix (prefix &optional (package *package*))  (defun push-import-prefix (prefix &optional (package *package*))
272    "Enables using package name omitting prefix.    "Enables using package name omitting prefix.
273  For example, you have packages com.clearly-useful.iterator-protocol, com.clearly-useful.reducers, ...  For example, you have packages com.clearly-useful.iterator-protocol, com.clearly-useful.reducers, ...
# Line 247  So, if you make Line 285  So, if you make
285    
286  after that reducers:... will refer to new package, not com.clearly-useful.reducers.  after that reducers:... will refer to new package, not com.clearly-useful.reducers.
287  "  "
288    (push (lambda (name package)    (%set-handler (package-finders package) `(:prefix ,prefix) name
289            (declare (ignore package))      (cl:find-package (concatenate 'string prefix "." name))))
           (or (cl:find-package name)  
               (cl:find-package (concatenate 'string prefix "." name))))  
         (package-finders package)))  
290    
291  (defun push-local-nickname (long-package nick  (defun push-local-nickname (long-package nick
292                              &optional (current-package *package*))                              &optional (current-package *package*))
# Line 266  You may do it right: Line 301  You may do it right:
301    
302  Local-nicknames are local, so you may use it freely.  Local-nicknames are local, so you may use it freely.
303    
304  Local-nickname shadows any package, which name is NICK, so if package A wants  If package A wants  package LIB version 1, and package B wants package
305  package LIB version 1, and package B wants package LIB version 2, one can simply  LIB version 2, one can simply rename LIB version 1 to LIB1 and rename LIB
306  rename LIB version 1 to LIB1 and make  version 2 to LIB2 and make
307   (push-local-nickname :lib1 :lib :a)   (push-local-nickname :lib1 :lib :a)
308     (push-local-nickname :lib2 :lib :b)
309  "  "
310    (let ((dpackage (find-package long-package)))    (let ((dpackage (find-package long-package)))
311      (push (lambda (name package)      (%set-handler (package-finders current-package) `(:nick ,long-package ,nick) name
312              (declare (ignore package))        (when (string= name (string nick)) dpackage))))
             (when (string= name (string nick)) dpackage))  
         (package-finders current-package))))  
313    
314  (defun push-local-package (symbol local-package)  (defun push-local-package (symbol local-package)
315    "Sets local-package for a symbol. Many macroses use the own clauses.    "Sets local-package for a symbol. Many macroses use there own clauses.
316  For example, ITERATE uses FOR, COLLECT and so on.  For example, ITERATE uses FOR, COLLECT and so on.
317  If you don't want to USE-PACKAGE iterate, this function will help.  If you don't want to USE-PACKAGE iterate, this function will help.
318   (push-local-package 'iter:iter :iterate)   (push-local-package 'iter:iter :iterate)
# Line 291  For example, this will be error: Line 325  For example, this will be error:
325  , because first for is in ITERATE package, but second -- is not.  , because first for is in ITERATE package, but second -- is not.
326  "  "
327    (let ((dpackage (find-package local-package)))    (let ((dpackage (find-package local-package)))
328      (push (lambda (name package)      (%set-handler (extra-finders symbol) `(:local ,symbol ,local-package) name
329              (declare (ignore package))        (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
330              (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)          (when (eq status :external) symbol)))))
               (when (eq status :external) symbol)))  
         (extra-finders symbol))))  
331    
332  ;;;  ;;;
333  ;;; Readtable analysis and change  ;;; Readtable analysis and change

Legend:
Removed from v.4  
changed lines
  Added in v.9

  ViewVC Help
Powered by ViewVC 1.1.5