/[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 12 by rklochkov, Mon Dec 31 13:39:29 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  ;;; Prepare readtables  ;;; Prepare readtables
20  ;;;  ;;;
21    
   
   
22  (defvar *advanced-readtable* (copy-readtable nil))  (defvar *advanced-readtable* (copy-readtable nil))
23  (defvar *colon-readtable* (copy-readtable nil)  (defvar *colon-readtable* (copy-readtable nil)
24    "Support readtable with colon as whitespace")    "Support readtable with colon as whitespace")
# Line 33  Line 29 
29    
30  (defpackage #:advanced-readtable.junk)  (defpackage #:advanced-readtable.junk)
31    
   
   
32  (defun try-funcall (handlers-list name package)  (defun try-funcall (handlers-list name package)
33    (declare (type list handlers-list)    (declare (type list handlers-list)
34             (type string name)             (type string name)
35             (type (or null package) package))             (type (or null package) package))
36    (when handlers-list    (when handlers-list
37      (or (funcall (car handlers-list) name package)      (or (funcall (cdr (car handlers-list)) name package)
38          (try-funcall (cdr handlers-list) name package))))          (try-funcall (cdr handlers-list) name package))))
39    
40  (defun find-package (name &optional (current-package *package*))  (defun find-package (name &optional (current-package *package*))
41      "We try to find package.
42    1. By full name with CL:FIND-PACKAGE.
43    2. By per-package handlers. Here we wil try local-nicknames and so on.
44    3. By global handlers. Here we may use, for example, hierarchical packages."
45    (declare (type (or null package) current-package))    (declare (type (or null package) current-package))
46    (if (typep name 'package) name    (if (typep name 'package) name
47        (let ((sname (string name)))        (let ((sname (string name)))
48          (or          (or
49             (cl:find-package name)
50           (when current-package           (when current-package
51             (try-funcall (package-finders current-package) sname current-package))             (try-funcall (package-finders current-package)
52           (try-funcall *package-finders* sname current-package)                          sname current-package))
53           (cl:find-package name)))))           (try-funcall *package-finders* sname current-package)))))
54    
55  (defvar *package-symbol-finders* (make-hash-table :test 'eq)  (defvar *package-symbol-finders* (make-hash-table :test 'eq)
56    "Hash package -> list of handlers")    "Hash package -> list of handlers. Each handler is a cons (key . function)")
57  (defvar *symbol-finders* nil  (defvar *symbol-finders* nil
58    "List of handlers (lambda (name package) ...) -> symbol")    "List of handlers. Each handler is a cons (key . function)
59    function =  (lambda (name package) ...) -> symbol")
60  (defvar *extra-finders* (make-hash-table :test 'eq)  (defvar *extra-finders* (make-hash-table :test 'eq)
61    "Hash symbol -> list of handlers (lambda (name package) ...) -> symbol    "Hash symbol -> list of handlers. Each handler is a cons (key . function)
62    function = (lambda (name package) ...) -> symbol
63  These will be used before CL:FIND-SYMBOL")  These will be used before CL:FIND-SYMBOL")
64    
65  (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 104  Returns function, assigned by set-macro-
104             (type (or null package) package))             (type (or null package) package))
105    (when handlers-list    (when handlers-list
106      (multiple-value-bind (symbol status)      (multiple-value-bind (symbol status)
107          (funcall (car handlers-list) name package)          (funcall (cdr (car handlers-list)) name package)
108        (if symbol        (if symbol
109            (values symbol status)            (values symbol status)
110            (try-funcall (cdr handlers-list) name package)))))            (try-funcall (cdr handlers-list) name package)))))
111    
112    
113  (defun find-symbol (name &optional dpackage)  (defun find-symbol (name &optional dpackage)
114      "We try to find symbol
115    1. In package set with car of list, for example, PUSH-LOCAL-PACKAGE
116    2. By CL-FIND-SYMBOL, when package explicitly given
117    3. By packages added with package:(...)
118    4. By per-package finders
119    5. By global finders
120    6. By CL-FIND-SYMBOL"
121    (declare (type string name))    (declare (type string name))
122    (let ((package (find-package dpackage)))    (let ((package (if dpackage (find-package dpackage) *package*)))
123      (macrolet ((mv-or (&rest clauses)      (macrolet ((mv-or (&rest clauses)
124                   (if clauses                   (if clauses
125                       `(multiple-value-bind (symbol status) ,(car clauses)                       `(multiple-value-bind (symbol status) ,(car clauses)
# Line 121  Returns function, assigned by set-macro- Line 129  Returns function, assigned by set-macro-
129    
130        (mv-or        (mv-or
131         (try-mv-funcall *extra-symbol-finders* name package)         (try-mv-funcall *extra-symbol-finders* name package)
132         (unless package (try-local-packages *local-packages* name))         (when dpackage (cl:find-symbol name package))
133         (when package (try-mv-funcall (symbol-finders package) name package))         (unless dpackage (try-local-packages *local-packages* name))
134           (try-mv-funcall (symbol-finders package) name package)
135         (try-mv-funcall *symbol-finders* name package)         (try-mv-funcall *symbol-finders* name package)
136         (if package         (unless dpackage (cl:find-symbol name package))))))
            (cl:find-symbol name package)  
            (cl:find-symbol name))))))  
137    
138  (defun read-token (stream)  (defun read-token (stream)
139    "    "
# Line 147  RETURN: number of the colons" Line 154  RETURN: number of the colons"
154    
155  (defun read-after-colon (stream maybe-package colons)  (defun read-after-colon (stream maybe-package colons)
156    "Read symbol package:sym or list package:(...)"    "Read symbol package:sym or list package:(...)"
157    (when (= colons 0)    (declare (type stream stream)
158               (type (integer 0 2) colons))
159      (check-type colons (integer 0 2))
160      (when (= colons 0) ; no colon: this is a symbol or an atom
161      (return-from read-after-colon      (return-from read-after-colon
162        (if (symbolp maybe-package)        (if (symbolp maybe-package)
163            (let ((name (symbol-name maybe-package)))            (prog1
164              (or (find-symbol name)(intern name)))                (let ((name (symbol-name maybe-package)))
165                    (or (find-symbol name) (intern name)))
166                (unintern maybe-package))
167            maybe-package)))            maybe-package)))
168    
169    (let ((package (find-package maybe-package)))    (let ((package (find-package maybe-package)))
# Line 168  RETURN: number of the colons" Line 180  RETURN: number of the colons"
180                 (read stream nil))))))                 (read stream nil))))))
181    
182      (let ((token (read-token stream)))      (let ((token (read-token stream)))
183          (check-type token symbol)
184        (multiple-value-bind (symbol status)        (multiple-value-bind (symbol status)
185            (find-symbol token package)            (find-symbol (symbol-name token) package)
186            (unless status
187              (if (= colons 1) (error "No external symbol ~S in ~S"
188                                      (symbol-name token) package)
189                  (cerror "Intern ~S in ~S" "No such symbol ~S in package ~S"
190                          (symbol-name token) package)))
191          (unintern token)          (unintern token)
192          (when (and (= colons 1) (not (eq status :external)))          (when (and (= colons 1) (not (eq status :external)))
193            (cerror "Use anyway"            (cerror "Use anyway"
# Line 230  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 247  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 266  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 291  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 376  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.4  
changed lines
  Added in v.12

  ViewVC Help
Powered by ViewVC 1.1.5