From rklochkov at common-lisp.net  Sat Nov 10 03:49:04 2012
From: rklochkov at common-lisp.net (rklochkov at common-lisp.net)
Date: Fri, 09 Nov 2012 19:49:04 -0800
Subject: [Advanced-readtable-cvs] r3 -
Message-ID: <E1TX248-0002UG-Fm@common-lisp.net>

Author: rklochkov
Date: Fri Nov  9 19:49:04 2012
New Revision: 3

Log:
Added documentation
Added local package for clauses (macro-symbol ...)

Modified:
   package.lisp
   src.lisp

Modified: package.lisp
==============================================================================
--- package.lisp	Thu Sep 20 05:54:30 2012	(r2)
+++ package.lisp	Fri Nov  9 19:49:04 2012	(r3)
@@ -4,14 +4,17 @@
    #:find-package
    #:find-symbol)
   (:export
-   #:def-symbol-readmacro
+   #:set-macro-symbol
+   #:get-macro-symbol
    #:activate
    #:!
    #:package-finders
    #:symbol-finders
    #:*package-finders*
    #:*symbol-finders*
+   #:*extra-finders*
    #:*advanced-readtable*
    #:*disable-symbol-readmacro*
    #:push-import-prefix
-   #:push-local-nickname))
+   #:push-local-nickname
+   #:push-local-package))

Modified: src.lisp
==============================================================================
--- src.lisp	Thu Sep 20 05:54:30 2012	(r2)
+++ src.lisp	Fri Nov  9 19:49:04 2012	(r3)
@@ -1,231 +1,316 @@
-(in-package #:advanced-readtable)
-
-;;;
-;;; study virgin readtable
-;;;
-
-(defmacro with-case (case &body body)
-  (let ((save (gensym)))
-    `(let ((,save (readtable-case *readtable*)))
-       (setf (readtable-case *readtable*) ,case)
-       (unwind-protect
-            (progn , at body)
-         (setf (readtable-case *readtable*) ,save)))))
-
-(defun does-not-terminate-token-p (c) 
-  (ignore-errors
-    (let ((str (format nil "a~Ab" c)))
-      (string= str (symbol-name 
-                    (with-case :preserve 
-                      (read-from-string (format nil "#:~A" str))))))))
-
-
-(defun whitespace[2]-p (c)
-  (ignore-errors 
-    (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
-
-(defun multiple-escape-p (c)
-  (ignore-errors 
-    (string= "qQ" (symbol-name
-                   (with-case :upcase
-                     (read-from-string (format nil "#:~AqQ~A" c c)))))))
-
-(defun single-escape-p (c)
-  (ignore-errors 
-    (string= (symbol-name '#:\') (symbol-name
-                                  (read-from-string (format nil "#:~A'" c))))))
-
-
-
-(defun macro-char-p (c)
-  "If C is macro-char, return GET-MACRO-CHARACTER"
-  #+allegro (unless 
-                (eql (get-macro-character c) #'excl::read-token)
-              (get-macro-character c))
-  #-allegro (get-macro-character c))
-
-(defun fill-char-table ()
-  "Returns simple-vector with character syntax classes"
-  (let ((*readtable* (copy-readtable nil))
-        (char-table (make-array 127)))
-    (dotimes (i (length char-table))
-      (let ((c (code-char i)))
-        (setf 
-         (svref char-table i)
-         (cond
-           ((eql c #\:) :colon)
-           ((macro-char-p c) :macro)
-           ((does-not-terminate-token-p c) :does-not-terminate-token)
-           ((whitespace[2]-p c) :whitespace[2])
-           ((multiple-escape-p c) :multiple-escape)
-           ((single-escape-p c) :single-escape)))))
-    char-table))
-
-(defvar *advanced-readtable* (copy-readtable nil))
-(defvar *colon-readtable* (copy-readtable nil) 
-  "Support readtable with colon as whitespace")
-
-;;;
-;;; Readtable handlers
-;;; 
-
-(defpackage #:advanced-readtable.junk)
-
-(defun read-token (stream)
-  "
-DO: Reads from STREAM a symbol or number up to whitespace or colon
-RETURN: symbols name or numbers value"
-  (let ((*readtable* *colon-readtable*)
-        (*package* (cl:find-package '#:advanced-readtable.junk)))
-    (let ((sym (read-preserving-whitespace stream nil)))
-      (if (symbolp sym)
-          (prog1
-              (symbol-name sym)
-            (unintern sym))
-          sym))))
-
-(defun count-colons (stream)
-  "
-DO: Reads colons from STREAM
-RETURN: number of the colons"
-  (let ((c (read-char stream nil)))
-    (if (eql c #\:) 
-        (+ 1 (count-colons stream))
-        (progn (unread-char c stream) 0))))
-
-(defvar *per-package-finders* (make-hash-table :test 'eq)
-  "Hash package -> list of handlers")
-(defvar *package-finders* nil
-  "List of handlers (lambda (name package) ...) -> package")
-
-(defun try-funcall (handlers-list name package)
-  (declare (type list handlers-list)
-           (type string name)
-           (type (or null package) package))
-  (when handlers-list
-    (or (funcall (car handlers-list) name package)
-        (try-funcall (cdr handlers-list) name package))))
-
-(defun find-package (name &optional (current-package *package*))
-  (declare (type (or null package) current-package))
-  (if (typep name 'package) name
-      (let ((sname (string name)))
-        (or (cl:find-package name)
-            (when current-package
-              (try-funcall (package-finders current-package) sname
-                           current-package))
-            (try-funcall *package-finders* sname current-package)))))
-
-(defvar *package-symbol-finders* (make-hash-table :test 'eq)
-  "Hash package -> list of handlers")
-(defvar *symbol-finders* nil
-  "List of handlers (lambda (name package) ...) -> symbol")
-
-(defun find-symbol (name &optional dpackage)
-  (declare (type string name))
-  (let ((package (find-package dpackage)))
-    (macrolet ((mv-or (&rest clauses)
-                 (if clauses
-                     `(multiple-value-bind (symbol status) ,(car clauses)
-                        (if symbol (values symbol status)
-                            (mv-or ,@(cdr clauses))))
-                     `(values nil nil))))
-                        
-    (mv-or (if package
-            (cl:find-symbol name package)
-            (cl:find-symbol name))
-        (when package
-          (try-funcall (symbol-finders package) name package))
-        (try-funcall *symbol-finders* name package)))))
-
-(defvar *symbol-readmacros* (make-hash-table :test 'eq))
-(defvar *disable-symbol-readmacro* nil 
-  "Disables processing of symbol-readmacro.")
-
-(defun def-symbol-readmacro (symbol func)
-  (setf (gethash symbol *symbol-readmacros*) func))
-
-(defun process-symbol-readmacro (symbol stream)
-  (let ((func (gethash symbol *symbol-readmacros*)))
-    (if func (funcall func stream symbol) symbol)))
-
-(defun read-token-with-colons (stream char)
-  "Reads token, then analize package part if needed"
-  (unread-char char stream)
-  (if *read-suppress* (let ((*readtable* (copy-readtable nil)))
-                        (read stream))
-      (let* ((tok (read-token stream))
-             ;; We have read something. 
-             ;; It may represent either symbol or package designator. 
-             ;; Looking after it: do we have a colon?
-             (cnt (count-colons stream))
-             (sym (if (= cnt 0)
-                      (if (stringp tok) (intern tok) tok)
-                      (let ((package (find-package tok *package*)))
-                        (assert package (package) "No package ~a" tok)
-                        (multiple-value-bind (symbol status) 
-                            (find-symbol (read-token stream) package)
-                          (when (and (= cnt 1) (not (eq status :external))) 
-                            (cerror "Use anyway" 
-                                    "Symbol ~A not external" symbol))
-                          symbol)))))
-        
-        (if (or *disable-symbol-readmacro* 
-                (not (symbolp sym)) (eql char #\|)) 
-            sym
-            (process-symbol-readmacro sym stream)))))
-
-
-;;;
-;;; Prepare readtables
-;;;
-
-(let (initialized)
-  (defun activate (&optional force)
-    "Inits *advanced-readtable* and *colon-readtable*."
-    (when (or force (not initialized))
-      (setq initialized t)
-      (let ((char-table (fill-char-table)))
-        (dotimes (i (length char-table))
-          (let ((b (svref char-table i))
-                (c (code-char i)))
-            (unless (char= #\# c)
-              (when (member b '(:does-not-terminate-token 
-                                :multiple-escape :single-escape))
-                ;; will make it non-terminating macro character
-                ;;    = potentially beginning of the package-name
-                (set-macro-character c #'read-token-with-colons 
-                                     t *advanced-readtable*))))))
-  
-      (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*))
-    (setf *readtable* *advanced-readtable*)))
-
-(defun ! () (activate))
-
-(defun (setf package-finders) (value &optional (package *package*))
-  (setf (gethash package *per-package-finders*) value))
-
-(defun package-finders (&optional (package *package*))
-  (gethash package *per-package-finders*))
-
-(defun (setf symbol-finders) (value &optional (package *package*))
-  (setf (gethash package *package-symbol-finders*) value))
-
-(defun symbol-finders (&optional (package *package*))
-  (gethash package *package-symbol-finders*))
-
-
-(defun push-import-prefix (package prefix)
-  (push (lambda (name package)
-          (declare (ignore package))
-          (cl:find-package (concatenate 'string prefix "." name)))
-        (package-finders package)))
-
-(defun push-local-nickname (long-package nick 
-                            &optional (current-package *package*))
-  (let ((long-name (package-name (find-package long-package))))
-    (push (lambda (name package)
-            (declare (ignore package))
-            (when (string= name (string nick)) long-name))
-        (package-finders current-package))))
-  
\ No newline at end of file
+(in-package #:advanced-readtable)
+
+;;;
+;;; study virgin readtable
+;;;
+
+(defmacro with-case (case &body body)
+  (let ((save (gensym)))
+    `(let ((,save (readtable-case *readtable*)))
+       (setf (readtable-case *readtable*) ,case)
+       (unwind-protect
+            (progn , at body)
+         (setf (readtable-case *readtable*) ,save)))))
+
+(defun does-not-terminate-token-p (c) 
+  (ignore-errors
+    (let ((str (format nil "a~Ab" c)))
+      (string= str (symbol-name 
+                    (with-case :preserve 
+                      (read-from-string (format nil "#:~A" str))))))))
+
+
+(defun whitespace[2]-p (c)
+  (ignore-errors 
+    (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
+
+(defun multiple-escape-p (c)
+  (ignore-errors 
+    (string= "qQ" (symbol-name
+                   (with-case :upcase
+                     (read-from-string (format nil "#:~AqQ~A" c c)))))))
+
+(defun single-escape-p (c)
+  (ignore-errors 
+    (string= (symbol-name '#:\ ) (symbol-name
+                                  (read-from-string (format nil "#:~A'" c))))))
+
+
+
+(defun macro-char-p (c)
+  "If C is macro-char, return GET-MACRO-CHARACTER"
+  #+allegro (unless 
+                (eql (get-macro-character c) #'excl::read-token)
+              (get-macro-character c))
+  #-allegro (get-macro-character c))
+
+(defun fill-char-table ()
+  "Returns simple-vector with character syntax classes"
+  (let ((*readtable* (copy-readtable nil))
+        (char-table (make-array 127)))
+    (dotimes (i (length char-table))
+      (let ((c (code-char i)))
+        (setf 
+         (svref char-table i)
+         (cond
+           ((eql c #\:) :colon)
+           ((macro-char-p c) :macro)
+           ((does-not-terminate-token-p c) :does-not-terminate-token)
+           ((whitespace[2]-p c) :whitespace[2])
+           ((multiple-escape-p c) :multiple-escape)
+           ((single-escape-p c) :single-escape)))))
+    char-table))
+
+(defvar *advanced-readtable* (copy-readtable nil))
+(defvar *colon-readtable* (copy-readtable nil) 
+  "Support readtable with colon as whitespace")
+
+;;;
+;;; Readtable handlers
+;;; 
+
+(defpackage #:advanced-readtable.junk)
+
+(defun read-token (stream)
+  "
+DO: Reads from STREAM a symbol or number up to whitespace or colon
+RETURN: symbols name or numbers value"
+  (let ((*readtable* *colon-readtable*)
+        (*package* (cl:find-package '#:advanced-readtable.junk)))
+    (let ((sym (read-preserving-whitespace stream nil)))
+      (if (symbolp sym)
+          (prog1
+              (symbol-name sym)
+            (unintern sym))
+          sym))))
+
+(defun count-colons (stream)
+  "
+DO: Reads colons from STREAM
+RETURN: number of the colons"
+  (let ((c (read-char stream nil)))
+    (if (eql c #\:) 
+        (+ 1 (count-colons stream))
+        (progn (unread-char c stream) 0))))
+
+(defvar *per-package-finders* (make-hash-table :test 'eq)
+  "Hash package -> list of handlers")
+(defvar *package-finders* nil
+  "List of handlers (lambda (name package) ...) -> package")
+
+(defun try-funcall (handlers-list name package)
+  (declare (type list handlers-list)
+           (type string name)
+           (type (or null package) package))
+  (when handlers-list
+    (or (funcall (car handlers-list) name package)
+        (try-funcall (cdr handlers-list) name package))))
+
+(defun find-package (name &optional (current-package *package*))
+  (declare (type (or null package) current-package))
+  (if (typep name 'package) name
+      (let ((sname (string name)))
+        (or 
+         (when current-package
+           (try-funcall (package-finders current-package) sname current-package))
+         (try-funcall *package-finders* sname current-package)
+         (cl:find-package name)))))
+
+(defvar *package-symbol-finders* (make-hash-table :test 'eq)
+  "Hash package -> list of handlers")
+(defvar *symbol-finders* nil
+  "List of handlers (lambda (name package) ...) -> symbol")
+(defvar *extra-finders* (make-hash-table :test 'eq)
+  "Hash symbol -> list of handlers (lambda (name package) ...) -> symbol
+These will be used before CL:FIND-SYMBOL")
+
+(defvar *symbol-readmacros* (make-hash-table :test 'eq))
+(defvar *disable-symbol-readmacro* nil 
+  "Disables processing of symbol-readmacro.")
+
+(defun def-symbol-readmacro (symbol func)
+  (setf (gethash symbol *symbol-readmacros*) func))
+
+(defun set-macro-symbol (symbol func)
+  "Syntax is like set-macro-character, 
+except that FUNC is binded to SYMBOL, not character"
+  (setf (gethash symbol *symbol-readmacros*) func))
+
+(defun get-macro-symbol (symbol)
+  "Syntax is like get-macro-character.
+Returns function, assigned by set-macro-symbol"
+  (gethash symbol *symbol-readmacros*))
+
+(defun process-symbol-readmacro (symbol stream)
+  (let ((func (gethash symbol *symbol-readmacros*)))
+    (if func (funcall func stream symbol) symbol)))
+
+(defvar %*extra-symbol-finders* nil "List of handlers: handlers for symbol, car of list")
+(defvar %*car-list* nil "Boolean: iff reader in list and car is not read")
+
+(defun find-symbol (name &optional dpackage)
+  (declare (type string name))
+  (let ((package (find-package dpackage)))
+    (macrolet ((mv-or (&rest clauses)
+                 (if clauses
+                     `(multiple-value-bind (symbol status) ,(car clauses)
+                        (if symbol (values symbol status)
+                            (mv-or ,@(cdr clauses))))
+                     `(values nil nil))))
+      
+      (mv-or
+       (try-funcall %*extra-symbol-finders* name package)
+       (when package (try-funcall (symbol-finders package) name package))
+       (try-funcall *symbol-finders* name package)
+       (when package (cl:find-symbol name package))
+       (cl:find-symbol name)))))
+
+
+(defun read-token-with-colons (stream char)
+  "Reads token, then analize package part if needed"
+  (unread-char char stream)
+  (if *read-suppress* (let ((*readtable* (copy-readtable nil)))
+                        (read stream))
+      (let* ((tok (read-token stream))
+             ;; We have read something. 
+             ;; It may represent either symbol or package designator. 
+             ;; Looking after it: do we have a colon?
+             (cnt (count-colons stream))
+             (sym (if (= cnt 0)
+                      (if (stringp tok) (or (find-symbol tok) (intern tok)) tok)
+                      (let ((package (find-package tok *package*)))
+                        (assert package (package) "No package ~a" tok)
+                        (multiple-value-bind (symbol status) 
+                            (find-symbol (read-token stream) package)
+                          (when (and (= cnt 1) (not (eq status :external))) 
+                            (cerror "Use anyway" 
+                                    "Symbol ~A not external" symbol))
+                          symbol)))))
+        
+        (let ((res (if (or *disable-symbol-readmacro* 
+                           (not (symbolp sym)) (eql char #\|)) 
+                       sym
+                       (process-symbol-readmacro sym stream))))
+          (when %*car-list*
+            (setf %*car-list* nil)
+            (when (and (symbolp res) (not (eql char #\|)))
+              (setf %*extra-symbol-finders* 
+                    (append (extra-finders res) %*extra-symbol-finders*))))
+          res))))
+
+(let ((default-open-paren-reader (get-macro-character #\( (copy-readtable nil))))
+  (defun open-paren-reader (stream char)
+    (let ((%*car-list* t) (%*extra-symbol-finders* %*extra-symbol-finders*))
+      (funcall default-open-paren-reader stream char))))
+      
+      
+;;;
+;;; Prepare readtables
+;;;
+
+(let (initialized)
+  (defun activate (&optional force)
+    "Inits *advanced-readtable* and *colon-readtable*."
+    (when (or force (not initialized))
+      (setq initialized t)
+      (let ((char-table (fill-char-table)))
+        (dotimes (i (length char-table))
+          (let ((b (svref char-table i))
+                (c (code-char i)))
+            (unless (char= #\# c)
+              (when (member b '(:does-not-terminate-token 
+                                :multiple-escape :single-escape))
+                ;; will make it non-terminating macro character
+                ;;    = potentially beginning of the package-name
+                (set-macro-character c #'read-token-with-colons 
+                                     t *advanced-readtable*))))))
+  
+      (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
+      (set-macro-character #\( #'open-paren-reader))
+    (setf *readtable* *advanced-readtable*)))
+
+(defun ! () (activate))
+
+(defun (setf package-finders) (value &optional (package *package*))
+  (setf (gethash (find-package package) *per-package-finders*) value))
+
+(defun package-finders (&optional (package *package*))
+  (gethash (find-package package) *per-package-finders*))
+
+(defun (setf symbol-finders) (value &optional (package *package*))
+  (setf (gethash (find-package package) *package-symbol-finders*) value))
+
+(defun symbol-finders (&optional (package *package*))
+  (gethash (find-package package) *package-symbol-finders*))
+
+(defun (setf extra-finders) (value symbol)
+  (setf (gethash symbol *extra-finders*) value))
+
+(defun extra-finders (symbol)
+  (gethash symbol *extra-finders*))
+
+(defun push-import-prefix (prefix &optional (package *package*))
+  "Enables using package name omitting prefix.
+For example, you have packages com.clearly-useful.iterator-protocol, com.clearly-useful.reducers, ...
+You may use them as
+ (push-import-prefix :com.clearly-useful)
+ (iterator-protocol:do-iterator ...)
+ (reducers:r/map #'1+ data)
+and so on.
+Package prefix is enabled per package so it is safe to use it in your package.
+
+If there is package, which name coincides with shortcut, package name has priority.
+
+So, if you make
+ (defpackage :reducers ...)
+
+after that reducers:... will refer to new package, not com.clearly-useful.reducers.
+"
+  (push (lambda (name package)
+          (declare (ignore package))
+          (or (cl:find-package name)
+              (cl:find-package (concatenate 'string prefix "." name))))
+        (package-finders package)))
+
+(defun push-local-nickname (long-package nick 
+                            &optional (current-package *package*))
+  "Enables package nickname in CURRENT-PACKAGE.
+For example, you found COM.INFORMATIMAGO.COMMON-LISP.CESARUM.LIST package and want to use
+it. But don't want to USE-PACKAGE them, because some exported symbols from it are clashing 
+with yours.
+
+You may do it right:
+ (push-local-nickname :com.informatimago.common-lisp.cesarum.list :ilist)
+ (ilist:circular-length l)
+
+Local-nicknames are local, so you may use it freely.
+
+Local-nickname shadows any package, which name is NICK, so if package A wants 
+package LIB version 1, and package B wants package LIB version 2, one can simply 
+rename LIB version 1 to LIB1 and make
+ (push-local-nickname :lib1 :lib :a)
+"
+  (let ((dpackage (find-package long-package)))
+    (push (lambda (name package)
+            (declare (ignore package))
+            (when (string= name (string nick)) dpackage))
+        (package-finders current-package))))
+
+(defun push-local-package (symbol local-package)
+  "Sets local-package for a symbol. Many macroses use the own clauses. 
+For example, ITERATE uses FOR, COLLECT and so on. 
+If you don't want to USE-PACKAGE iterate, this function will help.
+ (push-local-package 'iter:iter :iterate)
+ (iter:iter (for i from 1 to 10) (collect i))
+
+Caution: this function enables package substitution in all cases, 
+where SYMBOL is the car of a list.
+For example, this will be error: 
+ (let (iter:iter for) (list iter:iter for))
+, because first for is in ITERATE package, but second -- is not.
+"
+  (let ((dpackage (find-package local-package)))
+    (push (lambda (name package)
+            (declare (ignore package))
+            (cl:find-symbol name dpackage))
+        (extra-finders symbol))))
\ No newline at end of file