December 2012 - advanced-readtable-cvs@common-lisp.net

[Advanced-readtable-cvs] r13 -
by rklochkov＠common-lisp.net 31 Dec '12

31 Dec '12

Author: rklochkov Date: Mon Dec 31 14:35:23 2012 New Revision: 13 Log: Set license Modified: advanced-readtable.asd Modified: advanced-readtable.asd ============================================================================== --- advanced-readtable.asd Mon Dec 31 05:39:29 2012 (r12) +++ advanced-readtable.asd Mon Dec 31 14:35:23 2012 (r13) @@ -1,4 +1,8 @@ (asdf:defsystem #:advanced-readtable + :description "Advanced customizable readtable" + :author "Roman Klochkov <kalimehtar(a)mail.ru>" + :version "0.1.0" + :license "BSD" :serial t :components ((:file "package")

1 0

[Advanced-readtable-cvs] r12 -
by rklochkov＠common-lisp.net 31 Dec '12

31 Dec '12

Author: rklochkov Date: Mon Dec 31 05:39:29 2012 New Revision: 12 Log: Fixed wrong behavior when no symbol found Modified: package.lisp src.lisp Modified: package.lisp ============================================================================== --- package.lisp Sun Dec 30 06:35:37 2012 (r11) +++ package.lisp Mon Dec 31 05:39:29 2012 (r12) @@ -7,7 +7,7 @@ #:set-macro-symbol #:get-macro-symbol #:activate - #:! + #:! #:find-package #:find-symbol #:package-finders #:symbol-finders #:*package-finders* Modified: src.lisp ============================================================================== --- src.lisp Sun Dec 30 06:35:37 2012 (r11) +++ src.lisp Mon Dec 31 05:39:29 2012 (r12) @@ -15,15 +15,10 @@ "List of handlers. Each handler is a cons (key . function) function = (lambda (name package) ...) -> package") - - - ;;; ;;; Prepare readtables ;;; - - (defvar *advanced-readtable* (copy-readtable nil)) (defvar *colon-readtable* (copy-readtable nil) "Support readtable with colon as whitespace") @@ -34,8 +29,6 @@ (defpackage #:advanced-readtable.junk) - - (defun try-funcall (handlers-list name package) (declare (type list handlers-list) (type string name) @@ -55,7 +48,8 @@ (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) @@ -161,7 +155,8 @@ (defun read-after-colon (stream maybe-package colons) "Read symbol package:sym or list package:(...)" (declare (type stream stream) - (type fixnum colons)) + (type (integer 0 2) colons)) + (check-type colons (integer 0 2)) (when (= colons 0) ; no colon: this is a symbol or an atom (return-from read-after-colon (if (symbolp maybe-package) @@ -188,6 +183,11 @@ (check-type token symbol) (multiple-value-bind (symbol status) (find-symbol (symbol-name token) package) + (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))) (unintern token) (when (and (= colons 1) (not (eq status :external))) (cerror "Use anyway"

1 0

[Advanced-readtable-cvs] r11 -
by rklochkov＠common-lisp.net 30 Dec '12

30 Dec '12

Author: rklochkov Date: Sun Dec 30 06:35:37 2012 New Revision: 11 Log: Fix Modified: src.lisp Modified: src.lisp ============================================================================== --- src.lisp Sun Dec 30 06:24:44 2012 (r10) +++ src.lisp Sun Dec 30 06:35:37 2012 (r11) @@ -160,8 +160,7 @@ (defun read-after-colon (stream maybe-package colons) "Read symbol package:sym or list package:(...)" - (declare (type symbol maybe-package) - (type stream stream) + (declare (type stream stream) (type fixnum colons)) (when (= colons 0) ; no colon: this is a symbol or an atom (return-from read-after-colon

1 0

[Advanced-readtable-cvs] r10 -
by rklochkov＠common-lisp.net 30 Dec '12

30 Dec '12

Author: rklochkov Date: Sun Dec 30 06:24:44 2012 New Revision: 10 Log: Fixed bug with push-local-package Modified: src.lisp Modified: src.lisp ============================================================================== --- src.lisp Sun Dec 23 02:43:24 2012 (r9) +++ src.lisp Sun Dec 30 06:24:44 2012 (r10) @@ -160,11 +160,16 @@ (defun read-after-colon (stream maybe-package colons) "Read symbol package:sym or list package:(...)" + (declare (type symbol maybe-package) + (type stream stream) + (type fixnum colons)) (when (= colons 0) ; no colon: this is a symbol or an atom (return-from read-after-colon (if (symbolp maybe-package) - (let ((name (symbol-name maybe-package))) - (or (find-symbol name) (intern name))) + (prog1 + (let ((name (symbol-name maybe-package))) + (or (find-symbol name) (intern name))) + (unintern maybe-package)) maybe-package))) (let ((package (find-package maybe-package))) @@ -286,7 +291,7 @@ after that reducers:... will refer to new package, not com.clearly-useful.reducers. " (%set-handler (package-finders package) `(:prefix ,prefix) name - (cl:find-package (concatenate 'string prefix "." name)))) + (cl:find-package (concatenate 'string (string prefix) "." name)))) (defun push-local-nickname (long-package nick &optional (current-package *package*)) @@ -408,7 +413,7 @@ t *advanced-readtable*)))))) (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*) - (set-macro-character #\( #'open-paren-reader)) + (set-macro-character #\( #'open-paren-reader nil *advanced-readtable*)) (setf *readtable* *advanced-readtable*))) (defun ! () (activate))

1 0

[Advanced-readtable-cvs] r9 -
by rklochkov＠common-lisp.net 23 Dec '12

23 Dec '12

Author: rklochkov Date: Sun Dec 23 02:43:24 2012 New Revision: 9 Log: Added docs Added: README.md Modified: src.lisp Added: README.md ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ README.md Sun Dec 23 02:43:24 2012 (r9) @@ -0,0 +1,114 @@ +advanced-readtable +================== + +Features +- per-package aliases for packages +- per-package shortcuts for package hierarchies +- extendable find-package and find-symbol +- local use package in form package:(here form where package used) +- local intern package like in SBCL: package::(symbol1 symbol2) will intern + package::symbol1 and package::symbol2 + +_push-import-prefix_ -- enables import prefix on package name +-------------------------------------------- + +For example, you have packages com.clearly-useful.iterator-protocol, com.clearly-useful.reducers, ... +You may use them as + + (push-import-prefix :com.clearly-useful) + (iterator-protocol:do-iterator ...) + (reducers:r/map #'1+ data) + +and so on. +Package prefix is enabled per package so it is safe to use it in your package. + +If there is package, which name coincides with shortcut, package name has priority. + +So, if you make + + (defpackage :reducers ...) + +after that reducers:... will refer to new package, not com.clearly-useful.reducers. + +_push-local-nickname_ -- enables nickname for package in current package +------------------------------------------- + +Enables package nickname in CURRENT-PACKAGE. +For example, you found COM.INFORMATIMAGO.COMMON-LISP.CESARUM.LIST package and want to use +it. But don't want to USE-PACKAGE them, because some exported symbols from it are clashing +with yours. + +You may do it right: + + (push-local-nickname :com.informatimago.common-lisp.cesarum.list :ilist) + (ilist:circular-length l) + +Local-nicknames are local, so you may use it freely. + +If package A wants package LIB version 1, and package B wants package LIB version 2, one can simply +rename LIB version 1 to LIB1 and LIB version 2 to LIB2 and make + + (push-local-nickname :lib1 :lib :a) + (push-local-nickname :lib2 :lib :b) + +_push-local-package_ -- sets local-package for a symbol +---------------------------------------------- + +Many macroses use there own clauses. +For example, ITERATE uses FOR, COLLECT and so on. +If you don't want to USE-PACKAGE iterate, this function will help. + + (push-local-package 'iter:iter :iterate) + (iter:iter (for i from 1 to 10) (collect i)) + +Caution: this function enables package substitution in all cases, +where SYMBOL is the car of a list. +For example, this will be error: + + (let (iter:iter for) (list iter:iter for)) + +, because first for is in ITERATE package, but second -- is not. + +_set-macro-symbol_ - syntax is like set-macro-character, +------------------ + +But FUNC is binded to SYMBOL, not character. +Now you may make something like + + html:[body [table (as-html sql:[select * from t1])]] + +html:[ and sql:[ will have different handlers and you may mix them in +one expression. + +_get-macro-symbol_ - syntax is like get-macro-character, +------------------ + +Returns function, assigned by set-macro-symbol + +Low-level API +------------- + +There are five lists: +- *package-finders* -- global for find-package +- *symbol-finders* -- global for find-symbol +- (package-finders package) -- per-package for find-package +- (symbol-finders package) -- per-package for find-symbol +- (extra-finders symbol) -- per-symbol for (symbol ....) package substitution + +They are all alists. Key denotes handler and should be uniq for the list. +Value should have form (lambda (name package) ...) and return symbol for +symbol-finders and extra-finders and return pacakge for package-finders. + +You may freely change them to develop your own symbol or package schemes +(for example, hierarchy-packages, conduits and so on). + +Middle-level API +---------------- + +To simplify adding new handlers with keys there is macro _set-handler_ + + (set-handler (package-finders pack) '(:my handler1) #'handler-func) + +will set handler for package pack, if there are no hanler with key +(:my handler1). So you may set it in your file and not be afraid, that it +will duplicate on reloading. Modified: src.lisp ============================================================================== --- src.lisp Sun Dec 9 01:12:39 2012 (r8) +++ src.lisp Sun Dec 23 02:43:24 2012 (r9) @@ -1,13 +1,13 @@ (in-package #:advanced-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 +;;;; Advanced-readtable +;;;; +;;;; per-package aliases for packages +;;;; per-package shortcuts for package hierarchies +;;;; extendable find-package and find-symbol +;;;; local use package in form package:(here form where package used) +;;;; local intern package like in SBCL: package::(symbol1 symbol2) will intern +;;;; 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)") @@ -118,11 +118,12 @@ (defun find-symbol (name &optional dpackage) "We try to find symbol -1. In package set with car of list, for example, PUSh-LOCAL-PACKAGE -2. By CL-FIND-SYMBOL +1. In package set with car of list, for example, PUSH-LOCAL-PACKAGE +2. By CL-FIND-SYMBOL, when package explicitly given 3. By packages added with package:(...) 4. By per-package finders -5. By global finders" +5. By global finders +6. By CL-FIND-SYMBOL" (declare (type string name)) (let ((package (if dpackage (find-package dpackage) *package*))) (macrolet ((mv-or (&rest clauses) @@ -134,10 +135,11 @@ (mv-or (try-mv-funcall *extra-symbol-finders* name package) - (cl:find-symbol name package) + (when dpackage (cl:find-symbol name package)) (unless dpackage (try-local-packages *local-packages* name)) (try-mv-funcall (symbol-finders package) name package) - (try-mv-funcall *symbol-finders* name package))))) + (try-mv-funcall *symbol-finders* name package) + (unless dpackage (cl:find-symbol name package)))))) (defun read-token (stream) " @@ -158,7 +160,7 @@ (defun read-after-colon (stream maybe-package colons) "Read symbol package:sym or list package:(...)" - (when (= colons 0) + (when (= colons 0) ; no colon: this is a symbol or an atom (return-from read-after-colon (if (symbolp maybe-package) (let ((name (symbol-name maybe-package))) @@ -243,6 +245,17 @@ (gethash symbol *extra-finders*)) (defmacro set-handler (handler-list key function) + "This is middle-level public API for changing handlers for +find-symbol and find-package. There are five lists: + *package-finders* -- global for find-package + *symbol-finders* -- global for find-symbol + (package-finders package) -- per-package for find-package + (symbol-finders package) -- per-package for find-symbol + (extra-finders symbol) -- per-symbol for (symbol ....) package substitution + +Key should be uniq in the sense of EQUAL in the list. SET-HANDLER adds +new handler if it is not already there. +" (let ((key-var (gensym "key"))) `(let ((,key-var ,key)) (unless (assoc ,key-var ,handler-list :test #'equal) @@ -288,10 +301,11 @@ Local-nicknames are local, so you may use it freely. -Local-nickname shadows any package, which name is NICK, so if package A wants -package LIB version 1, and package B wants package LIB version 2, one can simply -rename LIB version 1 to LIB1 and make +If package A wants package LIB version 1, and package B wants package +LIB version 2, one can simply rename LIB version 1 to LIB1 and rename LIB +version 2 to LIB2 and make (push-local-nickname :lib1 :lib :a) + (push-local-nickname :lib2 :lib :b) " (let ((dpackage (find-package long-package))) (%set-handler (package-finders current-package) `(:nick ,long-package ,nick) name

1 0

[Advanced-readtable-cvs] r8 -
by rklochkov＠common-lisp.net 09 Dec '12

09 Dec '12

Author: rklochkov Date: Sun Dec 9 01:12:39 2012 New Revision: 8 Log: Fixed assoc check in handler Modified: src.lisp Modified: src.lisp ============================================================================== --- src.lisp Sat Dec 8 21:48:36 2012 (r7) +++ src.lisp Sun Dec 9 01:12:39 2012 (r8) @@ -245,7 +245,7 @@ (defmacro set-handler (handler-list key function) (let ((key-var (gensym "key"))) `(let ((,key-var ,key)) - (unless (assoc ,key-var ,handler-list) + (unless (assoc ,key-var ,handler-list :test #'equal) (push (cons ,key-var ,function) ,handler-list))))) @@ -272,7 +272,7 @@ after that reducers:... will refer to new package, not com.clearly-useful.reducers. " - (%set-handler (package-finders package) (list :prefix prefix) name + (%set-handler (package-finders package) `(:prefix ,prefix) name (cl:find-package (concatenate 'string prefix "." name)))) (defun push-local-nickname (long-package nick @@ -294,7 +294,7 @@ (push-local-nickname :lib1 :lib :a) " (let ((dpackage (find-package long-package))) - (%set-handler (package-finders current-package) (list :nick long-package nick) name + (%set-handler (package-finders current-package) `(:nick ,long-package ,nick) name (when (string= name (string nick)) dpackage)))) (defun push-local-package (symbol local-package) @@ -311,7 +311,7 @@ , because first for is in ITERATE package, but second -- is not. " (let ((dpackage (find-package local-package))) - (%set-handler (extra-finders symbol) (list :nick long-package nick) name + (%set-handler (extra-finders symbol) `(:local ,symbol ,local-package) name (multiple-value-bind (symbol status) (cl:find-symbol name dpackage) (when (eq status :external) symbol)))))

1 0

[Advanced-readtable-cvs] r7 -
by rklochkov＠common-lisp.net 09 Dec '12

09 Dec '12

Author: rklochkov Date: Sat Dec 8 21:48:36 2012 New Revision: 7 Log: Fixed typo Modified: src.lisp Modified: src.lisp ============================================================================== --- src.lisp Sat Dec 8 21:47:35 2012 (r6) +++ src.lisp Sat Dec 8 21:48:36 2012 (r7) @@ -251,9 +251,9 @@ (defmacro %set-handler (handler-list key name &body handler-body) "Local macros for push-* functions. No gensyms intended." - (set-handler ,handler-list ,key - (lambda (,name package) - (declare (ignore package)) . ,handler-body))) + `(set-handler ,handler-list ,key + (lambda (,name package) + (declare (ignore package)) . ,handler-body))) (defun push-import-prefix (prefix &optional (package *package*)) "Enables using package name omitting prefix. @@ -273,8 +273,7 @@ after that reducers:... will refer to new package, not com.clearly-useful.reducers. " (%set-handler (package-finders package) (list :prefix prefix) name - (or (cl:find-package name) - (cl:find-package (concatenate 'string prefix "." name))))) + (cl:find-package (concatenate 'string prefix "." name)))) (defun push-local-nickname (long-package nick &optional (current-package *package*)) @@ -296,7 +295,7 @@ " (let ((dpackage (find-package long-package))) (%set-handler (package-finders current-package) (list :nick long-package nick) name - (when (string= name (string nick)) dpackage)))) + (when (string= name (string nick)) dpackage)))) (defun push-local-package (symbol local-package) "Sets local-package for a symbol. Many macroses use there own clauses. @@ -313,8 +312,8 @@ " (let ((dpackage (find-package local-package))) (%set-handler (extra-finders symbol) (list :nick long-package nick) name - (multiple-value-bind (symbol status) (cl:find-symbol name dpackage) - (when (eq status :external) symbol))))) + (multiple-value-bind (symbol status) (cl:find-symbol name dpackage) + (when (eq status :external) symbol))))) ;;; ;;; Readtable analysis and change

1 0

[Advanced-readtable-cvs] r6 -
by rklochkov＠common-lisp.net 09 Dec '12

09 Dec '12

Author: rklochkov Date: Sat Dec 8 21:47:35 2012 New Revision: 6 Log: Fixed FIND-SYMBOL and FIND-PACKAGE Modified: package.lisp src.lisp Modified: package.lisp ============================================================================== --- package.lisp Sat Dec 8 10:04:29 2012 (r5) +++ package.lisp Sat Dec 8 21:47:35 2012 (r6) @@ -17,4 +17,5 @@ #:*disable-symbol-readmacro* #:push-import-prefix #:push-local-nickname - #:push-local-package)) + #:push-local-package + #:set-handler)) Modified: src.lisp ============================================================================== --- src.lisp Sat Dec 8 10:04:29 2012 (r5) +++ src.lisp Sat Dec 8 21:47:35 2012 (r6) @@ -10,9 +10,10 @@ ;;; package::symbol1 and package::symbol2 (defvar *per-package-finders* (make-hash-table :test 'eq) - "Hash package -> list of handlers") + "Hash package -> list of handlers. Each handler is a cons (key . function)") (defvar *package-finders* nil - "List of handlers (lambda (name package) ...) -> package") + "List of handlers. Each handler is a cons (key . function) +function = (lambda (name package) ...) -> package") @@ -40,25 +41,31 @@ (type string name) (type (or null package) package)) (when handlers-list - (or (funcall (car handlers-list) name package) + (or (funcall (cdr (car handlers-list)) name package) (try-funcall (cdr handlers-list) name package)))) (defun find-package (name &optional (current-package *package*)) + "We try to find package. +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)) (if (typep name 'package) name (let ((sname (string name))) - (or + (or + (cl:find-package name) (when current-package (try-funcall (package-finders current-package) sname current-package)) - (try-funcall *package-finders* sname current-package) - (cl:find-package name))))) + (try-funcall *package-finders* sname current-package))))) (defvar *package-symbol-finders* (make-hash-table :test 'eq) - "Hash package -> list of handlers") + "Hash package -> list of handlers. Each handler is a cons (key . function)") (defvar *symbol-finders* nil - "List of handlers (lambda (name package) ...) -> symbol") + "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 (lambda (name package) ...) -> symbol + "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)) @@ -103,15 +110,21 @@ (type (or null package) package)) (when handlers-list (multiple-value-bind (symbol status) - (funcall (car handlers-list) name package) + (funcall (cdr (car handlers-list)) name package) (if symbol (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 +2. By CL-FIND-SYMBOL +3. By packages added with package:(...) +4. By per-package finders +5. By global finders" (declare (type string name)) - (let ((package (find-package dpackage))) + (let ((package (if dpackage (find-package dpackage) *package*))) (macrolet ((mv-or (&rest clauses) (if clauses `(multiple-value-bind (symbol status) ,(car clauses) @@ -121,12 +134,10 @@ (mv-or (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)))))) + (cl:find-symbol name package) + (unless dpackage (try-local-packages *local-packages* name)) + (try-mv-funcall (symbol-finders package) name package) + (try-mv-funcall *symbol-finders* name package))))) (defun read-token (stream) " @@ -151,7 +162,7 @@ (return-from read-after-colon (if (symbolp maybe-package) (let ((name (symbol-name maybe-package))) - (or (find-symbol name)(intern name))) + (or (find-symbol name) (intern name))) maybe-package))) (let ((package (find-package maybe-package))) @@ -231,6 +242,19 @@ (defun extra-finders (symbol) (gethash symbol *extra-finders*)) +(defmacro set-handler (handler-list key function) + (let ((key-var (gensym "key"))) + `(let ((,key-var ,key)) + (unless (assoc ,key-var ,handler-list) + (push (cons ,key-var ,function) + ,handler-list))))) + +(defmacro %set-handler (handler-list key name &body handler-body) + "Local macros for push-* functions. No gensyms intended." + (set-handler ,handler-list ,key + (lambda (,name package) + (declare (ignore package)) . ,handler-body))) + (defun push-import-prefix (prefix &optional (package *package*)) "Enables using package name omitting prefix. For example, you have packages com.clearly-useful.iterator-protocol, com.clearly-useful.reducers, ... @@ -248,11 +272,9 @@ after that reducers:... will refer to new package, not com.clearly-useful.reducers. " - (push (lambda (name package) - (declare (ignore package)) - (or (cl:find-package name) - (cl:find-package (concatenate 'string prefix "." name)))) - (package-finders package))) + (%set-handler (package-finders package) (list :prefix prefix) name + (or (cl:find-package name) + (cl:find-package (concatenate 'string prefix "." name))))) (defun push-local-nickname (long-package nick &optional (current-package *package*)) @@ -273,13 +295,11 @@ (push-local-nickname :lib1 :lib :a) " (let ((dpackage (find-package long-package))) - (push (lambda (name package) - (declare (ignore package)) - (when (string= name (string nick)) dpackage)) - (package-finders current-package)))) + (%set-handler (package-finders current-package) (list :nick long-package nick) name + (when (string= name (string nick)) dpackage)))) (defun push-local-package (symbol local-package) - "Sets local-package for a symbol. Many macroses use the own clauses. + "Sets local-package for a symbol. Many macroses use there own clauses. For example, ITERATE uses FOR, COLLECT and so on. If you don't want to USE-PACKAGE iterate, this function will help. (push-local-package 'iter:iter :iterate) @@ -292,11 +312,9 @@ , because first for is in ITERATE package, but second -- is not. " (let ((dpackage (find-package local-package))) - (push (lambda (name package) - (declare (ignore package)) - (multiple-value-bind (symbol status) (cl:find-symbol name dpackage) - (when (eq status :external) symbol))) - (extra-finders symbol)))) + (%set-handler (extra-finders symbol) (list :nick long-package nick) name + (multiple-value-bind (symbol status) (cl:find-symbol name dpackage) + (when (eq status :external) symbol))))) ;;; ;;; Readtable analysis and change

1 0

[Advanced-readtable-cvs] r5 -
by rklochkov＠common-lisp.net 08 Dec '12

08 Dec '12

Author: rklochkov Date: Sat Dec 8 10:04:29 2012 New Revision: 5 Log: Fixed bug: (cl:+ 2 2) hadn't parsed. Modified: src.lisp Modified: src.lisp ============================================================================== --- src.lisp Fri Dec 7 22:20:09 2012 (r4) +++ src.lisp Sat Dec 8 10:04:29 2012 (r5) @@ -168,8 +168,9 @@ (read stream nil)))))) (let ((token (read-token stream))) + (check-type token symbol) (multiple-value-bind (symbol status) - (find-symbol token package) + (find-symbol (symbol-name token) package) (unintern token) (when (and (= colons 1) (not (eq status :external))) (cerror "Use anyway"

1 0

[Advanced-readtable-cvs] r4 -
by rklochkov＠common-lisp.net 08 Dec '12

08 Dec '12

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

1 0