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 ,@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 ,@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))