[Advanced-readtable-cvs] r14 -
rklochkov at common-lisp.net
rklochkov at common-lisp.net
Fri Jan 25 14:09:35 UTC 2013
Author: rklochkov
Date: Fri Jan 25 06:09:35 2013
New Revision: 14
Log:
Version 0.2
Modified:
README.md
advanced-readtable.asd
package.lisp
src.lisp
Modified: README.md
==============================================================================
--- README.md Mon Dec 31 14:35:23 2012 (r13)
+++ README.md Fri Jan 25 06:09:35 2013 (r14)
@@ -9,6 +9,41 @@
- local intern package like in SBCL: package::(symbol1 symbol2) will intern
package::symbol1 and package::symbol2
+To start
+--------
+
+Either use named-readtables and write
+
+ (in-readtable :advanced)
+
+or simply add to advanced-readtable to current readtable
+
+ (advanced-readtable:!)
+
+Hierarchy packages
+------------------
+
+Advanced-readtable has fully functional built-in support of hierarchy-packages.
+
+ CL-USER> (defpackage .test (:use cl)))
+ #<PACKAGE "COMMON-LISP-USER.TEST">
+ CL-USER> (in-package .test)
+ TEST> (in-package ..)
+ CL-USER> (defpackage .test.a (:use cl))
+ #<PACKAGE "COMMON-LISP-USER.TEST.A">
+ CL-USER> (in-package .test.a)
+ A> '...::car
+ CAR
+ A> (eq '...::car 'cl:car)
+ T
+ A> (in-package ...test)
+ TEST> (in-package ..)
+ CL-USER>
+
+
+API
+===
+
_push-import-prefix_ -- enables import prefix on package name
--------------------------------------------
@@ -51,6 +86,10 @@
(push-local-nickname :lib1 :lib :a)
(push-local-nickname :lib2 :lib :b)
+This command also adds local subpackage alias. In the previous example a.lib
+and b.lib will be aliases to lib1 and lib2. If there is a real package with
+such name, alias will be shadowed, so don't worry too much about it.
+
_push-local-package_ -- sets local-package for a symbol
----------------------------------------------
@@ -69,10 +108,14 @@
, because first for is in ITERATE package, but second -- is not.
+Be careful: this change is not local to your package.
+
_set-macro-symbol_ - syntax is like set-macro-character,
------------------
-But FUNC is binded to SYMBOL, not character.
+But FUNC is binded to SYMBOL, not character. This symbol will be processed
+in all cases, where it is not bounded by ||.
+
Now you may make something like
html:[body [table (as-html sql:[select * from t1])]]
@@ -80,6 +123,19 @@
html:[ and sql:[ will have different handlers and you may mix them in
one expression.
+Also it allows to make simple symbol-aliases. For example:
+
+ (set-macro-symbol '|ALIAS| (lambda (stream symbol)
+ (declare (ignore stream symbol))
+ 'advanced-readtables:push-local-package))
+Now you may do
+
+ (alias 'iter:iter :iterate)
+
+Moreover, you may alias variables from other packages and set them through
+alias. But be careful: this change is not local to your package.
+
+
_get-macro-symbol_ - syntax is like get-macro-character,
------------------
Modified: advanced-readtable.asd
==============================================================================
--- advanced-readtable.asd Mon Dec 31 14:35:23 2012 (r13)
+++ advanced-readtable.asd Fri Jan 25 06:09:35 2013 (r14)
@@ -1,9 +1,9 @@
(asdf:defsystem #:advanced-readtable
:description "Advanced customizable readtable"
:author "Roman Klochkov <kalimehtar at mail.ru>"
- :version "0.1.0"
+ :version "0.2.0"
:license "BSD"
:serial t
- :components
- ((:file "package")
- (:file "src")))
+ :components ((:file "package")
+ (:file "src")))
+
Modified: package.lisp
==============================================================================
--- package.lisp Mon Dec 31 14:35:23 2012 (r13)
+++ package.lisp Fri Jan 25 06:09:35 2013 (r14)
@@ -1,8 +1,10 @@
-(defpackage #:advanced-readtable
+(cl:|DEFPACKAGE| #:advanced-readtable
(:use #:cl)
(:shadow
#:find-package
- #:find-symbol)
+ #:find-symbol
+ #:in-package
+ #:defpackage)
(:export
#:set-macro-symbol
#:get-macro-symbol
@@ -18,4 +20,6 @@
#:push-import-prefix
#:push-local-nickname
#:push-local-package
- #:set-handler))
+ #:set-handler
+ #:enable-global-nicknames
+ #:enable-hierarchy-packages))
Modified: src.lisp
==============================================================================
--- src.lisp Mon Dec 31 14:35:23 2012 (r13)
+++ src.lisp Fri Jan 25 06:09:35 2013 (r14)
@@ -10,24 +10,29 @@
;;;; package::symbol1 and package::symbol2
(defvar *per-package-finders* (make-hash-table :test 'eq)
- "Hash package -> list of handlers. Each handler is a cons (key . function)")
+ "Hash package -> list of handlers. Each handler is a cons (key . function)
+function = (lambda (name package) ...) -> package")
+
(defvar *package-finders* nil
"List of handlers. Each handler is a cons (key . function)
function = (lambda (name package) ...) -> package")
+(defvar *global-nicknames* nil
+ "Placeholder for global nicknames, when not null, it is an alias hash")
+
;;;
;;; Prepare readtables
;;;
-(defvar *advanced-readtable* (copy-readtable nil))
(defvar *colon-readtable* (copy-readtable nil)
"Support readtable with colon as whitespace")
+(set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
;;;
;;; Readtable handlers
;;;
-(defpackage #:advanced-readtable.junk)
+(|CL|:defpackage #:advanced-readtable.junk)
(defun try-funcall (handlers-list name package)
(declare (type list handlers-list)
@@ -42,27 +47,30 @@
1. By full name with CL:FIND-PACKAGE.
2. By per-package handlers. Here we wil try local-nicknames and so on.
3. By global handlers. Here we may use, for example, hierarchical packages."
- (declare (type (or null package) current-package))
+ (declare (type 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 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. Each handler is a cons (key . function)")
+ "Hash package -> list of handlers. Each handler is a cons (key . function)
+function = (lambda (name package) ...) -> symbol")
+
(defvar *symbol-finders* nil
"List of handlers. Each handler is a cons (key . function)
function = (lambda (name package) ...) -> symbol")
+
(defvar *extra-finders* (make-hash-table :test 'eq)
"Hash symbol -> list of handlers. Each handler is a cons (key . function)
function = (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.")
@@ -109,7 +117,6 @@
(values symbol status)
(try-funcall (cdr handlers-list) name package)))))
-
(defun find-symbol (name &optional dpackage)
"We try to find symbol
1. In package set with car of list, for example, PUSH-LOCAL-PACKAGE
@@ -119,14 +126,15 @@
5. By global finders
6. By CL-FIND-SYMBOL"
(declare (type string name))
+; (when (string= name "NIL")
+; (return-from find-symbol (cl:find-symbol name (or dpackage *package*))))
(let ((package (if dpackage (find-package dpackage) *package*)))
(macrolet ((mv-or (&rest clauses)
(if clauses
`(multiple-value-bind (symbol status) ,(car clauses)
- (if symbol (values symbol status)
+ (if status (values symbol status)
(mv-or . ,(cdr clauses))))
- `(values nil nil))))
-
+ `(values nil nil))))
(mv-or
(try-mv-funcall *extra-symbol-finders* name package)
(when dpackage (cl:find-symbol name package))
@@ -135,27 +143,38 @@
(try-mv-funcall *symbol-finders* name package)
(unless dpackage (cl:find-symbol name package))))))
+(defun collect-dots (stream)
+ (do ((n 0 (1+ n))
+ (c (read-char stream nil) (read-char stream nil)))
+ ((or (null c) (char/= c #\.))
+ (when c
+ (unread-char c stream))
+ (if (and (plusp n) (member c '(nil #\Space #\) #\( #\Tab #\Newline #\:)))
+ (intern (make-string n :initial-element #\.))
+ (dotimes (foo n) (unread-char #\. stream))))))
+
(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)))
+ (or (collect-dots stream)
+ (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))))
+ (do ((n 0 (1+ n))
+ (c (read-char stream nil) (read-char stream nil)))
+ ((or (null c) (char/= c #\:))
+ (when c (unread-char c stream)) n)))
(defun read-after-colon (stream maybe-package colons)
"Read symbol package:sym or list package:(...)"
(declare (type stream stream)
- (type (integer 0 2) colons))
+ (type integer colons))
(check-type colons (integer 0 2))
(when (= colons 0) ; no colon: this is a symbol or an atom
(return-from read-after-colon
@@ -186,16 +205,16 @@
(unless status
(if (= colons 1) (error "No external symbol ~S in ~S"
(symbol-name token) package)
- (cerror "Intern ~S in ~S" "No such symbol ~S in package ~S"
- (symbol-name token) package)))
+ (progn
+ (cerror "Intern ~S in ~S" "No such symbol ~S in package ~S"
+ (symbol-name token) package)
+ (setf symbol (intern (symbol-name 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)
@@ -227,8 +246,6 @@
(defun open-paren-reader (stream char)
(let ((*car-list* t) (*extra-symbol-finders* *extra-symbol-finders*))
(funcall default-open-paren-reader stream char))))
-
-
(defun (setf package-finders) (value &optional (package *package*))
(setf (gethash (find-package package) *per-package-finders*) value))
@@ -310,10 +327,23 @@
version 2 to LIB2 and make
(push-local-nickname :lib1 :lib :a)
(push-local-nickname :lib2 :lib :b)
+
+If enabled global-nicknames via enable-global-nicknames,
+then also created alias in current package.
+
+For example,
+ (push-local-nickname :lib1 :lib :a), states, that package A.LIB is eq to LIB1.
"
- (let ((dpackage (find-package long-package)))
- (%set-handler (package-finders current-package) `(:nick ,long-package ,nick) name
- (when (string= name (string nick)) dpackage))))
+ (let ((dpackage (find-package long-package))
+ (s-nick (string nick)))
+ (%set-handler (package-finders current-package)
+ `(:nick ,(string long-package) ,s-nick) name
+ (when (string= name s-nick) dpackage))
+ (when *global-nicknames*
+ (setf (gethash (concatenate 'string
+ (package-name current-package)
+ "." s-nick) *global-nicknames*)
+ dpackage))))
(defun push-local-package (symbol local-package)
"Sets local-package for a symbol. Many macroses use there own clauses.
@@ -333,86 +363,158 @@
(multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
(when (eq status :external) symbol)))))
+;;; TODO: process nicknames in hierarchy
+;;; ex: cl-user.test == common-lisp-user.test
+;;; cl-user.test.a == common-lisp-user.test.a
+
+(defun normalize-package (name)
+ "Returns nil if already normalized.
+Replace first section of hierarchy with proper name"
+ (let ((pos (position #\. name)))
+ (when pos
+ (if (= pos 0) ; .subpackage
+ (concatenate 'string (package-name *package*) name)
+ (let* ((base (subseq name 0 pos))
+ (p (find-package base)))
+ (when (and p (string/= (package-name p) base))
+ (concatenate 'string (package-name p) "."
+ (subseq name (1+ pos)))))))))
+
+(flet ((parent (name)
+ (let ((pos (position #\. name :from-end t)))
+ (if pos (subseq name 0 pos) "")))
+ (relative-to (parent name)
+ (cond
+ ((string= parent "") name)
+ ((string= name "") parent)
+ (t (concatenate 'string parent "." name)))))
+ (defun hierarchy-find-package (name package)
+ (if (char= (char name 0) #\.)
+ (do ((i 1 (1+ i))
+ (p (package-name package) (parent p)))
+ ((or (= i (length name)) (char/= (char name i) #\.))
+ (find-package (relative-to p (subseq name i)))))
+ (let ((normalized (normalize-package name)))
+ (when normalized
+ (find-package normalized package))))))
+
+(defun correct-package (designator)
+ (let ((p (find-package designator)))
+ (if p (package-name p) designator)))
+
+(defmacro in-package (designator)
+ `(|CL|:in-package ,(correct-package (string designator))))
+
+(defmacro defpackage (package &rest options)
+ (let ((normalized (normalize-package (string package)))
+ (options
+ (mapcar (lambda (option)
+ (cons (car option)
+ (case (car option)
+ (:use (mapcar #'correct-package (cdr option)))
+ ((:import-from :shadowing-import-from)
+ (cons (correct-package (second option))
+ (cddr option)))
+ (t (cdr option)))))
+ options)))
+ `(|CL|:defpackage ,(or normalized package) . ,options)))
+
+(defun substitute-symbol (stream symbol)
+ (declare (ignore stream))
+ (find-symbol (symbol-name symbol) #.*package*))
+
+(defun enable-hierarchy-packages ()
+ (set-handler *package-finders* :hierarchy #'hierarchy-find-package)
+ (set-macro-symbol '|CL|:in-package #'substitute-symbol)
+ (set-macro-symbol '|CL|:defpackage #'substitute-symbol))
+
+(defun enable-global-nicknames ()
+ (setf *global-nicknames* (make-hash-table :test 'equal))
+ (%set-handler *package-finders* :global-nicknames name
+ (gethash name *global-nicknames*)))
+
+(enable-hierarchy-packages)
+(enable-global-nicknames)
+
;;;
;;; 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*))))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (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 to-process (c)
+ (cond
+ ((eql c #\:) nil)
+ ((macro-char-p c) nil)
+ ((does-not-terminate-token-p c) t)
+ ((whitespace-p c) nil)
+ ((multiple-escape-p c) t)
+ ((single-escape-p c) t)
+ (t nil)))
- (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
- (set-macro-character #\( #'open-paren-reader nil *advanced-readtable*))
- (setf *readtable* *advanced-readtable*)))
+ (defparameter +additional-chars+ ""
+ "Fill this, if you need extra characters for packages to begin with")
+
+ (defun chars-to-process ()
+ (let ((*readtable* (copy-readtable nil)))
+ (nconc
+ (loop :for i :from 1 :to 127
+ :for c = (code-char i)
+ :when (to-process c) :collect c)
+ (loop :for c :across +additional-chars+
+ :when (to-process c) :collect c))))
+
+ (defun make-named-rt ()
+ `(,(cl:find-symbol "DEFREADTABLE" "NAMED-READTABLES") :advanced
+ (:merge :standard)
+ ,@(loop :for c :in (chars-to-process)
+ :collect `(:macro-char ,c #'read-token-with-colons t))
+ (:macro-char #\( #'open-paren-reader nil))))
+
+(macrolet ((def-advanced-readtable ()
+ (make-named-rt)))
+ (when (cl:find-package "NAMED-READTABLES")
+ (def-advanced-readtable)))
+
+(defun activate ()
+ (dolist (c (chars-to-process))
+ (set-macro-character c #'read-token-with-colons t))
+ (set-macro-character #\( #'open-paren-reader t))
(defun ! () (activate))
More information about the Advanced-readtable-cvs
mailing list