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

Diff of /src.lisp

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

revision 5 by rklochkov, Sat Dec 8 18:04:29 2012 UTC revision 6 by rklochkov, Sun Dec 9 05:47:35 2012 UTC
# Line 10  Line 10 
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
123    3. By packages added with package:(...)
124    4. By per-package finders
125    5. By global finders"
126    (declare (type string name))    (declare (type string name))
127    (let ((package (find-package dpackage)))    (let ((package (if dpackage (find-package dpackage) *package*)))
128      (macrolet ((mv-or (&rest clauses)      (macrolet ((mv-or (&rest clauses)
129                   (if clauses                   (if clauses
130                       `(multiple-value-bind (symbol status) ,(car clauses)                       `(multiple-value-bind (symbol status) ,(car clauses)
# Line 121  Returns function, assigned by set-macro- Line 134  Returns function, assigned by set-macro-
134    
135        (mv-or        (mv-or
136         (try-mv-funcall *extra-symbol-finders* name package)         (try-mv-funcall *extra-symbol-finders* name package)
137         (unless package (try-local-packages *local-packages* name))         (cl:find-symbol name package)
138         (when package (try-mv-funcall (symbol-finders package) name package))         (unless dpackage (try-local-packages *local-packages* name))
139         (try-mv-funcall *symbol-finders* name package)         (try-mv-funcall (symbol-finders package) name package)
140         (if package         (try-mv-funcall *symbol-finders* name package)))))
            (cl:find-symbol name package)  
            (cl:find-symbol name))))))  
141    
142  (defun read-token (stream)  (defun read-token (stream)
143    "    "
# Line 151  RETURN: number of the colons" Line 162  RETURN: number of the colons"
162      (return-from read-after-colon      (return-from read-after-colon
163        (if (symbolp maybe-package)        (if (symbolp maybe-package)
164            (let ((name (symbol-name maybe-package)))            (let ((name (symbol-name maybe-package)))
165              (or (find-symbol name)(intern name)))              (or (find-symbol name) (intern name)))
166            maybe-package)))            maybe-package)))
167    
168    (let ((package (find-package maybe-package)))    (let ((package (find-package maybe-package)))
# Line 231  RETURN: number of the colons" Line 242  RETURN: number of the colons"
242  (defun extra-finders (symbol)  (defun extra-finders (symbol)
243    (gethash symbol *extra-finders*))    (gethash symbol *extra-finders*))
244    
245    (defmacro set-handler (handler-list key function)
246      (let ((key-var (gensym "key")))
247        `(let ((,key-var ,key))
248           (unless (assoc ,key-var ,handler-list)
249             (push (cons ,key-var ,function)
250                   ,handler-list)))))
251    
252    (defmacro %set-handler (handler-list key name &body handler-body)
253      "Local macros for push-* functions. No gensyms intended."
254      (set-handler ,handler-list ,key
255                   (lambda (,name package)
256                     (declare (ignore package)) . ,handler-body)))
257    
258  (defun push-import-prefix (prefix &optional (package *package*))  (defun push-import-prefix (prefix &optional (package *package*))
259    "Enables using package name omitting prefix.    "Enables using package name omitting prefix.
260  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 248  So, if you make Line 272  So, if you make
272    
273  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.
274  "  "
275    (push (lambda (name package)    (%set-handler (package-finders package) (list :prefix prefix) name
276            (declare (ignore package))      (or (cl:find-package name)
277            (or (cl:find-package name)          (cl:find-package (concatenate 'string prefix "." name)))))
               (cl:find-package (concatenate 'string prefix "." name))))  
         (package-finders package)))  
278    
279  (defun push-local-nickname (long-package nick  (defun push-local-nickname (long-package nick
280                              &optional (current-package *package*))                              &optional (current-package *package*))
# Line 273  rename LIB version 1 to LIB1 and make Line 295  rename LIB version 1 to LIB1 and make
295   (push-local-nickname :lib1 :lib :a)   (push-local-nickname :lib1 :lib :a)
296  "  "
297    (let ((dpackage (find-package long-package)))    (let ((dpackage (find-package long-package)))
298      (push (lambda (name package)      (%set-handler (package-finders current-package) (list :nick long-package nick) name
299              (declare (ignore package))         (when (string= name (string nick)) dpackage))))
             (when (string= name (string nick)) dpackage))  
         (package-finders current-package))))  
300    
301  (defun push-local-package (symbol local-package)  (defun push-local-package (symbol local-package)
302    "Sets local-package for a symbol. Many macroses use the own clauses.    "Sets local-package for a symbol. Many macroses use there own clauses.
303  For example, ITERATE uses FOR, COLLECT and so on.  For example, ITERATE uses FOR, COLLECT and so on.
304  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.
305   (push-local-package 'iter:iter :iterate)   (push-local-package 'iter:iter :iterate)
# Line 292  For example, this will be error: Line 312  For example, this will be error:
312  , because first for is in ITERATE package, but second -- is not.  , because first for is in ITERATE package, but second -- is not.
313  "  "
314    (let ((dpackage (find-package local-package)))    (let ((dpackage (find-package local-package)))
315      (push (lambda (name package)      (%set-handler (extra-finders symbol) (list :nick long-package nick) name
316              (declare (ignore package))         (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
317              (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)           (when (eq status :external) symbol)))))
               (when (eq status :external) symbol)))  
         (extra-finders symbol))))  
318    
319  ;;;  ;;;
320  ;;; Readtable analysis and change  ;;; Readtable analysis and change

Legend:
Removed from v.5  
changed lines
  Added in v.6

  ViewVC Help
Powered by ViewVC 1.1.5