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

Diff of /src.lisp

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

revision 8 by rklochkov, Sun Dec 9 09:12:39 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. Each handler is a cons (key . function)")    "Hash package -> list of handlers. Each handler is a cons (key . function)")
# Line 15  Line 15 
15    "List of handlers. Each handler is a cons (key . function)    "List of handlers. Each handler is a cons (key . function)
16  function = (lambda (name package) ...) -> package")  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 34  function = (lambda (name package) ...) - Line 29  function = (lambda (name package) ...) -
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)
# Line 55  function = (lambda (name package) ...) - Line 48  function = (lambda (name package) ...) -
48          (or          (or
49           (cl:find-package name)           (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                            sname current-package))
53           (try-funcall *package-finders* sname current-package)))))           (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)
# Line 118  Returns function, assigned by set-macro- Line 112  Returns function, assigned by set-macro-
112    
113  (defun find-symbol (name &optional dpackage)  (defun find-symbol (name &optional dpackage)
114    "We try to find symbol    "We try to find symbol
115  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
116  2. By CL-FIND-SYMBOL  2. By CL-FIND-SYMBOL, when package explicitly given
117  3. By packages added with package:(...)  3. By packages added with package:(...)
118  4. By per-package finders  4. By per-package finders
119  5. By global finders"  5. By global finders
120    6. By CL-FIND-SYMBOL"
121    (declare (type string name))    (declare (type string name))
122    (let ((package (if dpackage (find-package dpackage) *package*)))    (let ((package (if dpackage (find-package dpackage) *package*)))
123      (macrolet ((mv-or (&rest clauses)      (macrolet ((mv-or (&rest clauses)
# Line 134  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         (cl:find-symbol name package)         (when dpackage (cl:find-symbol name package))
133         (unless dpackage (try-local-packages *local-packages* name))         (unless dpackage (try-local-packages *local-packages* name))
134         (try-mv-funcall (symbol-finders package) name package)         (try-mv-funcall (symbol-finders package) name package)
135         (try-mv-funcall *symbol-finders* name package)))))         (try-mv-funcall *symbol-finders* name package)
136           (unless dpackage (cl:find-symbol name package))))))
137    
138  (defun read-token (stream)  (defun read-token (stream)
139    "    "
# Line 158  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 182  RETURN: number of the colons" Line 183  RETURN: number of the colons"
183        (check-type token symbol)        (check-type token symbol)
184        (multiple-value-bind (symbol status)        (multiple-value-bind (symbol status)
185            (find-symbol (symbol-name 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 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 :test #'equal)         (unless (assoc ,key-var ,handler-list :test #'equal)
# Line 273  So, if you make Line 290  So, if you make
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) `(: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) `(:nick ,long-package ,nick) name      (%set-handler (package-finders current-package) `(:nick ,long-package ,nick) name
# 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.8  
changed lines
  Added in v.12

  ViewVC Help
Powered by ViewVC 1.1.5