/[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 11 by rklochkov, Sun Dec 30 14:35:37 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)    (declare (type stream stream)
164               (type fixnum colons))
165      (when (= colons 0) ; no colon: this is a symbol or an atom
166      (return-from read-after-colon      (return-from read-after-colon
167        (if (symbolp maybe-package)        (if (symbolp maybe-package)
168            (let ((name (symbol-name maybe-package)))            (prog1
169              (or (find-symbol name)(intern name)))                (let ((name (symbol-name maybe-package)))
170                    (or (find-symbol name) (intern name)))
171                (unintern maybe-package))
172            maybe-package)))            maybe-package)))
173    
174    (let ((package (find-package maybe-package)))    (let ((package (find-package maybe-package)))
# Line 231  RETURN: number of the colons" Line 248  RETURN: number of the colons"
248  (defun extra-finders (symbol)  (defun extra-finders (symbol)
249    (gethash symbol *extra-finders*))    (gethash symbol *extra-finders*))
250    
251    (defmacro set-handler (handler-list key function)
252      "This is middle-level public API for changing handlers for
253    find-symbol and find-package. There are five lists:
254      *package-finders* -- global for find-package
255      *symbol-finders* -- global for find-symbol
256      (package-finders package) -- per-package for find-package
257      (symbol-finders package) -- per-package for find-symbol
258      (extra-finders symbol) -- per-symbol for (symbol ....) package substitution
259    
260    Key should be uniq in the sense of EQUAL in the list. SET-HANDLER adds
261    new handler if it is not already there.
262    "
263      (let ((key-var (gensym "key")))
264        `(let ((,key-var ,key))
265           (unless (assoc ,key-var ,handler-list :test #'equal)
266             (push (cons ,key-var ,function)
267                   ,handler-list)))))
268    
269    (defmacro %set-handler (handler-list key name &body handler-body)
270      "Local macros for push-* functions. No gensyms intended."
271      `(set-handler ,handler-list ,key
272                    (lambda (,name package)
273                      (declare (ignore package)) . ,handler-body)))
274    
275  (defun push-import-prefix (prefix &optional (package *package*))  (defun push-import-prefix (prefix &optional (package *package*))
276    "Enables using package name omitting prefix.    "Enables using package name omitting prefix.
277  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 289  So, if you make
289    
290  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.
291  "  "
292    (push (lambda (name package)    (%set-handler (package-finders package) `(:prefix ,prefix) name
293            (declare (ignore package))      (cl:find-package (concatenate 'string (string prefix) "." name))))
           (or (cl:find-package name)  
               (cl:find-package (concatenate 'string prefix "." name))))  
         (package-finders package)))  
294    
295  (defun push-local-nickname (long-package nick  (defun push-local-nickname (long-package nick
296                              &optional (current-package *package*))                              &optional (current-package *package*))
# Line 267  You may do it right: Line 305  You may do it right:
305    
306  Local-nicknames are local, so you may use it freely.  Local-nicknames are local, so you may use it freely.
307    
308  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
309  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
310  rename LIB version 1 to LIB1 and make  version 2 to LIB2 and make
311   (push-local-nickname :lib1 :lib :a)   (push-local-nickname :lib1 :lib :a)
312     (push-local-nickname :lib2 :lib :b)
313  "  "
314    (let ((dpackage (find-package long-package)))    (let ((dpackage (find-package long-package)))
315      (push (lambda (name package)      (%set-handler (package-finders current-package) `(:nick ,long-package ,nick) name
316              (declare (ignore package))        (when (string= name (string nick)) dpackage))))
             (when (string= name (string nick)) dpackage))  
         (package-finders current-package))))  
317    
318  (defun push-local-package (symbol local-package)  (defun push-local-package (symbol local-package)
319    "Sets local-package for a symbol. Many macroses use the own clauses.    "Sets local-package for a symbol. Many macroses use there own clauses.
320  For example, ITERATE uses FOR, COLLECT and so on.  For example, ITERATE uses FOR, COLLECT and so on.
321  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.
322   (push-local-package 'iter:iter :iterate)   (push-local-package 'iter:iter :iterate)
# Line 292  For example, this will be error: Line 329  For example, this will be error:
329  , because first for is in ITERATE package, but second -- is not.  , because first for is in ITERATE package, but second -- is not.
330  "  "
331    (let ((dpackage (find-package local-package)))    (let ((dpackage (find-package local-package)))
332      (push (lambda (name package)      (%set-handler (extra-finders symbol) `(:local ,symbol ,local-package) name
333              (declare (ignore package))        (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
334              (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)          (when (eq status :external) symbol)))))
               (when (eq status :external) symbol)))  
         (extra-finders symbol))))  
335    
336  ;;;  ;;;
337  ;;; Readtable analysis and change  ;;; Readtable analysis and change
# Line 377  For example, this will be error: Line 412  For example, this will be error:
412                                       t *advanced-readtable*))))))                                       t *advanced-readtable*))))))
413    
414        (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)        (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
415        (set-macro-character #\( #'open-paren-reader))        (set-macro-character #\( #'open-paren-reader nil *advanced-readtable*))
416      (setf *readtable* *advanced-readtable*)))      (setf *readtable* *advanced-readtable*)))
417    
418  (defun ! () (activate))  (defun ! () (activate))

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

  ViewVC Help
Powered by ViewVC 1.1.5