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