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

Diff of /src.lisp

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

revision 9 by rklochkov, Sun Dec 23 10:43:24 2012 UTC revision 12 by rklochkov, Mon Dec 31 13:39:29 2012 UTC
# 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 160  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      (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    (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 184  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 286  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 408  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.9  
changed lines
  Added in v.12

  ViewVC Help
Powered by ViewVC 1.1.5