Author: rklochkov
Date: Thu Sep 20 00:50:22 2012
New Revision: 1
Log:
Initial
Added:
advanced-readtable.asd (contents, props changed)
package.lisp (contents, props changed)
src.lisp (contents, props changed)
Added: advanced-readtable.asd
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ advanced-readtable.asd Thu Sep 20 00:50:22 2012 (r1)
@@ -0,0 +1,5 @@
+(asdf:defsystem #:advanced-readtable
+ :serial t
+ :components
+ ((:file "package")
+ (:file "src")))
Added: package.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ package.lisp Thu Sep 20 00:50:22 2012 (r1)
@@ -0,0 +1,17 @@
+(defpackage #:advanced-readtable
+ (:use #:cl)
+ (:shadow
+ #:find-package
+ #:find-symbol)
+ (:export
+ #:def-symbol-readmacro
+ #:activate
+ #:!
+ #:package-finders
+ #:symbol-finders
+ #:*package-finders*
+ #:*symbol-finders*
+ #:*advanced-readtable*
+ #:*disable-symbol-readmacro*
+ #:push-import-prefix
+ #:push-local-nickname))
Added: src.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ src.lisp Thu Sep 20 00:50:22 2012 (r1)
@@ -0,0 +1,231 @@
+(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 ,@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 symbol stream) 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
