[Advanced-readtable-cvs] r4 -
rklochkov at common-lisp.net
rklochkov at common-lisp.net
Sat Dec 8 06:20:09 UTC 2012
Author: rklochkov
Date: Fri Dec 7 22:20:09 2012
New Revision: 4
Log:
Added package:(...) abd package::(...) clauses
Modified:
advanced-readtable.asd
package.lisp
src.lisp
Modified: advanced-readtable.asd
==============================================================================
--- advanced-readtable.asd Fri Nov 9 19:49:04 2012 (r3)
+++ advanced-readtable.asd Fri Dec 7 22:20:09 2012 (r4)
@@ -1,5 +1,5 @@
-(asdf:defsystem #:advanced-readtable
- :serial t
- :components
- ((:file "package")
- (:file "src")))
+(asdf:defsystem #:advanced-readtable
+ :serial t
+ :components
+ ((:file "package")
+ (:file "src")))
Modified: package.lisp
==============================================================================
--- package.lisp Fri Nov 9 19:49:04 2012 (r3)
+++ package.lisp Fri Dec 7 22:20:09 2012 (r4)
@@ -1,20 +1,20 @@
-(defpackage #:advanced-readtable
- (:use #:cl)
- (:shadow
- #:find-package
- #:find-symbol)
- (:export
- #: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-package))
+(defpackage #:advanced-readtable
+ (:use #:cl)
+ (:shadow
+ #:find-package
+ #:find-symbol)
+ (:export
+ #: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-package))
Modified: src.lisp
==============================================================================
--- src.lisp Fri Nov 9 19:49:04 2012 (r3)
+++ src.lisp Fri Dec 7 22:20:09 2012 (r4)
@@ -1,65 +1,27 @@
(in-package #:advanced-readtable)
-;;;
-;;; study virgin readtable
-;;;
+;;; Advanced-readtable
+;;;
+;;; per-package aliases for packages
+;;; per-package shortcuts for package hierarchies
+;;; extendable find-package and find-symbol
+;;; local use pcakage in form package:(here form where package used)
+;;; local intern package like in SBCL: package::(symbol1 symbol2) will intern
+;;; package::symbol1 and package::symbol2
-(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)))))
+(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 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))))))
+;;;
+;;; Prepare readtables
+;;;
-(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)
@@ -71,32 +33,7 @@
(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)
@@ -145,8 +82,32 @@
(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")
+;;; Internal special variables. Do not export
+
+(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")
+(defvar *local-packages* nil "List of packages: for pack:( ... pack2:(...))")
+
+(defun try-local-packages (packages name)
+ (when packages
+ (multiple-value-bind (symbol status) (cl:find-symbol name (car packages))
+ (if symbol
+ (values symbol status)
+ (try-local-packages (cdr packages) name)))))
+
+(defun try-mv-funcall (handlers-list name package)
+ "Returns symbol, status"
+ (declare (type list handlers-list)
+ (type string name)
+ (type (or null package) package))
+ (when handlers-list
+ (multiple-value-bind (symbol status)
+ (funcall (car handlers-list) name package)
+ (if symbol
+ (values symbol status)
+ (try-funcall (cdr handlers-list) name package)))))
+
(defun find-symbol (name &optional dpackage)
(declare (type string name))
@@ -155,81 +116,101 @@
(if clauses
`(multiple-value-bind (symbol status) ,(car clauses)
(if symbol (values symbol status)
- (mv-or ,@(cdr clauses))))
+ (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)))))
+ (try-mv-funcall *extra-symbol-finders* name package)
+ (unless package (try-local-packages *local-packages* name))
+ (when package (try-mv-funcall (symbol-finders package) name package))
+ (try-mv-funcall *symbol-finders* name package)
+ (if package
+ (cl:find-symbol name package)
+ (cl:find-symbol name))))))
+
+(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)))
+ (read-preserving-whitespace stream nil)))
+
+(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))))
+
+(defun read-after-colon (stream maybe-package colons)
+ "Read symbol package:sym or list package:(...)"
+ (when (= colons 0)
+ (return-from read-after-colon
+ (if (symbolp maybe-package)
+ (let ((name (symbol-name maybe-package)))
+ (or (find-symbol name)(intern name)))
+ maybe-package)))
+
+ (let ((package (find-package maybe-package)))
+ (assert package (package) "No package ~a" maybe-package)
+ (unintern maybe-package)
+ (when (eql (peek-char t stream) #\()
+ ;; package:(...) or package::(...)
+ (ecase colons
+ (1 (let ((*local-packages* (cons package *local-packages*)))
+ (return-from read-after-colon
+ (read stream nil))))
+ (2 (let ((*package* package))
+ (return-from read-after-colon
+ (read stream nil))))))
+
+ (let ((token (read-token stream)))
+ (multiple-value-bind (symbol status)
+ (find-symbol token package)
+ (unintern token)
+ (when (and (= colons 1) (not (eq status :external)))
+ (cerror "Use anyway"
+ "Symbol ~A not external" 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) (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)))))
+ (when *read-suppress*
+ (let ((*readtable* (copy-readtable nil)))
+ (read stream))
+ (return-from read-token-with-colons))
+ (let* ((token (read-token stream))
+ ;; We have read something.
+ ;; It may represent either symbol or package designator.
+ ;; Looking after it: do we have a colon?
+ (colons (count-colons stream))
+ (object (read-after-colon stream token colons)))
+
+ (when (or *disable-symbol-readmacro*
+ (not (symbolp object))
+ (eql char #\|))
+ (return-from read-token-with-colons object))
- (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))))
+ (let ((object (process-symbol-readmacro object stream)))
+ (when *car-list*
+ (setf *car-list* nil
+ *extra-symbol-finders*
+ (append (extra-finders object) *extra-symbol-finders*)))
+ object)))
+
+(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*))
+ (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))
@@ -312,5 +293,90 @@
(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
+ (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
+ (when (eq status :external) symbol)))
+ (extra-finders symbol))))
+
+;;;
+;;; Readtable analysis and change
+;;;
+
+(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-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-p c) :whitespace)
+ ((multiple-escape-p c) :multiple-escape)
+ ((single-escape-p c) :single-escape)))))
+ char-table))
+
+(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))
More information about the Advanced-readtable-cvs
mailing list