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

Diff of /src.lisp

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

revision 7 by rklochkov, Sun Dec 9 05:48:36 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. Each handler is a cons (key . function)")    "Hash package -> list of handlers. Each handler is a cons (key . function)")
# Line 118  Returns function, assigned by set-macro- Line 118  Returns function, assigned by set-macro-
118    
119  (defun find-symbol (name &optional dpackage)  (defun find-symbol (name &optional dpackage)
120    "We try to find symbol    "We try to find symbol
121  1. In package set with car of list, for example, PUSh-LOCAL-PACKAGE  1. In package set with car of list, for example, PUSH-LOCAL-PACKAGE
122  2. By CL-FIND-SYMBOL  2. By CL-FIND-SYMBOL, when package explicitly given
123  3. By packages added with package:(...)  3. By packages added with package:(...)
124  4. By per-package finders  4. By per-package finders
125  5. By global finders"  5. By global finders
126    6. By CL-FIND-SYMBOL"
127    (declare (type string name))    (declare (type string name))
128    (let ((package (if dpackage (find-package dpackage) *package*)))    (let ((package (if dpackage (find-package dpackage) *package*)))
129      (macrolet ((mv-or (&rest clauses)      (macrolet ((mv-or (&rest clauses)
# Line 134  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         (cl:find-symbol name package)         (when dpackage (cl:find-symbol name package))
139         (unless dpackage (try-local-packages *local-packages* name))         (unless dpackage (try-local-packages *local-packages* name))
140         (try-mv-funcall (symbol-finders package) name package)         (try-mv-funcall (symbol-finders package) name package)
141         (try-mv-funcall *symbol-finders* name package)))))         (try-mv-funcall *symbol-finders* name package)
142           (unless dpackage (cl:find-symbol name package))))))
143    
144  (defun read-token (stream)  (defun read-token (stream)
145    "    "
# Line 158  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 243  RETURN: number of the colons" Line 249  RETURN: number of the colons"
249    (gethash symbol *extra-finders*))    (gethash symbol *extra-finders*))
250    
251  (defmacro set-handler (handler-list key function)  (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")))    (let ((key-var (gensym "key")))
264      `(let ((,key-var ,key))      `(let ((,key-var ,key))
265         (unless (assoc ,key-var ,handler-list)         (unless (assoc ,key-var ,handler-list :test #'equal)
266           (push (cons ,key-var ,function)           (push (cons ,key-var ,function)
267                 ,handler-list)))))                 ,handler-list)))))
268    
# Line 272  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    (%set-handler (package-finders package) (list :prefix prefix) name    (%set-handler (package-finders package) `(:prefix ,prefix) name
293      (cl:find-package (concatenate 'string prefix "." name))))      (cl:find-package (concatenate 'string (string prefix) "." name))))
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 288  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      (%set-handler (package-finders current-package) (list :nick long-package nick) name      (%set-handler (package-finders current-package) `(:nick ,long-package ,nick) name
316        (when (string= name (string nick)) dpackage))))        (when (string= name (string nick)) dpackage))))
317    
318  (defun push-local-package (symbol local-package)  (defun push-local-package (symbol local-package)
# Line 311  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      (%set-handler (extra-finders symbol) (list :nick long-package nick) name      (%set-handler (extra-finders symbol) `(:local ,symbol ,local-package) name
333        (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)        (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
334          (when (eq status :external) symbol)))))          (when (eq status :external) symbol)))))
335    
# Line 394  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.7  
changed lines
  Added in v.11

  ViewVC Help
Powered by ViewVC 1.1.5