From rklochkov at common-lisp.net Fri Jan 25 14:09:35 2013 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Fri, 25 Jan 2013 06:09:35 -0800 Subject: [Advanced-readtable-cvs] r14 - Message-ID: 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))) + # + CL-USER> (in-package .test) + TEST> (in-package ..) + CL-USER> (defpackage .test.a (:use cl)) + # + 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 " - :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)) From rklochkov at common-lisp.net Sat Jan 26 19:59:30 2013 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Sat, 26 Jan 2013 11:59:30 -0800 Subject: [Advanced-readtable-cvs] r15 - Message-ID: Author: rklochkov Date: Sat Jan 26 11:59:30 2013 New Revision: 15 Log: Refactored. Beta release. Now strong depends on named-readtables Modified: advanced-readtable.asd package.lisp src.lisp Modified: advanced-readtable.asd ============================================================================== --- advanced-readtable.asd Fri Jan 25 06:09:35 2013 (r14) +++ advanced-readtable.asd Sat Jan 26 11:59:30 2013 (r15) @@ -1,9 +1,13 @@ (asdf:defsystem #:advanced-readtable :description "Advanced customizable readtable" :author "Roman Klochkov " - :version "0.2.0" + :version "0.8.0" :license "BSD" + :depends-on (#:named-readtables) :serial t :components ((:file "package") - (:file "src"))) + (:file "finders") + (:file "api") + (:file "readtable") + (:file "hierarchy"))) Modified: package.lisp ============================================================================== --- package.lisp Fri Jan 25 06:09:35 2013 (r14) +++ package.lisp Sat Jan 26 11:59:30 2013 (r15) @@ -1,5 +1,6 @@ -(cl:|DEFPACKAGE| #:advanced-readtable - (:use #:cl) +(defpackage #:advanced-readtable + (:use #:cl #:named-readtables) + (:import-from #:named-readtables #:define-api #:=>) (:shadow #:find-package #:find-symbol Modified: src.lisp ============================================================================== --- src.lisp Fri Jan 25 06:09:35 2013 (r14) +++ src.lisp Sat Jan 26 11:59:30 2013 (r15) @@ -494,27 +494,24 @@ (defun chars-to-process () (let ((*readtable* (copy-readtable nil))) (nconc - (loop :for i :from 1 :to 127 + (loop :for i :from 0 :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 + `(defreadtable :advanced (:merge :standard) - ,@(loop :for c :in (chars-to-process) - :collect `(:macro-char ,c #'read-token-with-colons t)) + ,@(mapcar (lambda (c) (list :macro-char c #'read-token-with-colons t)) + (chars-to-process)) (:macro-char #\( #'open-paren-reader nil)))) (macrolet ((def-advanced-readtable () (make-named-rt))) - (when (cl:find-package "NAMED-READTABLES") - (def-advanced-readtable))) + (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)) + (in-readtable :advanced)) (defun ! () (activate)) From rklochkov at common-lisp.net Sat Jan 26 20:15:49 2013 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Sat, 26 Jan 2013 12:15:49 -0800 Subject: [Advanced-readtable-cvs] r16 - Message-ID: Author: rklochkov Date: Sat Jan 26 12:15:48 2013 New Revision: 16 Log: Reverted activate Modified: advanced-readtable.asd Modified: advanced-readtable.asd ============================================================================== --- advanced-readtable.asd Sat Jan 26 11:59:30 2013 (r15) +++ advanced-readtable.asd Sat Jan 26 12:15:48 2013 (r16) @@ -1,7 +1,7 @@ (asdf:defsystem #:advanced-readtable :description "Advanced customizable readtable" :author "Roman Klochkov " - :version "0.8.0" + :version "0.8.1" :license "BSD" :depends-on (#:named-readtables) :serial t From rklochkov at common-lisp.net Sat Jan 26 20:28:44 2013 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Sat, 26 Jan 2013 12:28:44 -0800 Subject: [Advanced-readtable-cvs] r17 - Message-ID: Author: rklochkov Date: Sat Jan 26 12:28:43 2013 New Revision: 17 Log: Documentation Modified: README.md package.lisp Modified: README.md ============================================================================== --- README.md Sat Jan 26 12:15:48 2013 (r16) +++ README.md Sat Jan 26 12:28:43 2013 (r17) @@ -24,6 +24,9 @@ ------------------ Advanced-readtable has fully functional built-in support of hierarchy-packages. +.name means "subpackage name in current package", ..name -- "subpackage name in above package", +...name -- "subpackage in two-level-up package" and so on. +In in-package you may use .. for above package, ... for two level up, and so on. CL-USER> (defpackage .test (:use cl))) # @@ -145,8 +148,8 @@ ------------- There are five lists: -- *package-finders* -- global for find-package -- *symbol-finders* -- global for find-symbol +- `*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 @@ -168,3 +171,19 @@ 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. + +Restrictions +------------ + +You must only ASCII characters for first letter of every part of package name +and for first letter of symbols, that you want to use in set-macro-symbol + +If you really need other characters you may set them by calling + + (set-macro-character c #'advanced-readtable:read-token-with-colons t) + +for every your character. + +If you need to temporary disable macro-characted substitution, you may set +`advanced-readtable:*enable-symbol-readmacro*` to nil. It could be useful, if you +describe a lot of symbols and don't want to enclose every of them in || (and upcase, of course). Modified: package.lisp ============================================================================== --- package.lisp Sat Jan 26 12:15:48 2013 (r16) +++ package.lisp Sat Jan 26 12:28:43 2013 (r17) @@ -16,11 +16,9 @@ #:*package-finders* #:*symbol-finders* #:*extra-finders* - #:*advanced-readtable* - #:*disable-symbol-readmacro* + #:*enable-symbol-readmacro* #:push-import-prefix #:push-local-nickname #:push-local-package #:set-handler - #:enable-global-nicknames - #:enable-hierarchy-packages)) + #:read-token-with-colons)) From rklochkov at common-lisp.net Sun Jan 27 10:14:58 2013 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Sun, 27 Jan 2013 02:14:58 -0800 Subject: [Advanced-readtable-cvs] r18 - Message-ID: Author: rklochkov Date: Sun Jan 27 02:14:58 2013 New Revision: 18 Log: Docs Modified: README.md Modified: README.md ============================================================================== --- README.md Sat Jan 26 12:28:43 2013 (r17) +++ README.md Sun Jan 27 02:14:58 2013 (r18) @@ -113,11 +113,22 @@ 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. This symbol will be processed -in all cases, where it is not bounded by ||. +_set-macro-symbol_ symbol func -- sets FUNC to process the SYMBOL. +-------------------------- +FUNC will get stream of reader and the symbol (see set-macro-character). + +To prevent symbol from processing (for example in set-macro-symbol construction) you should enclose it in bars. + +This construction will set 'foo as an alias to 'long-package-name:long-name: + + (set-macro-symbol '|FOO| + (lambda (stream symbol) + (declare (ignore stream symbol)) + 'long-package-name:long-name)) + +Another way to prevent symbol processing is setting `advanced-readtable:*enable-symbol-readmacro*` to nil. +Remember, that symbol processing is done during reading the file, so, if you need to temporarily disable +`*enable-symbol-readmacro*`, then enclose it in #. Now you may make something like @@ -126,17 +137,13 @@ 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. +alias. But be careful: this change is not local to your package. If you write qualified name +of the symbol, you should enclose package-name int bars: + (set-macro-symbol '|OTHER-PACKAGE|:foo + (lambda (stream symbol) + (declare (ignore stream symbol)) + 'long-package-name:long-name)) _get-macro-symbol_ - syntax is like get-macro-character, From rklochkov at common-lisp.net Mon Jan 28 17:03:50 2013 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Mon, 28 Jan 2013 09:03:50 -0800 Subject: [Advanced-readtable-cvs] r19 - Message-ID: Author: rklochkov Date: Mon Jan 28 09:03:50 2013 New Revision: 19 Log: Added tests Added: advanced-readtable.test.asd test.lisp Added: advanced-readtable.test.asd ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ advanced-readtable.test.asd Mon Jan 28 09:03:50 2013 (r19) @@ -0,0 +1,8 @@ +(asdf:defsystem #:advanced-readtable.test + :description "Tests for advanced-customizable" + :author "Roman Klochkov " + :version "0.8.1" + :license "BSD" + :depends-on (#:advanced-readtable #:fiveam) + :components ((:file "test"))) + \ No newline at end of file Added: test.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ test.lisp Mon Jan 28 09:03:50 2013 (r19) @@ -0,0 +1,44 @@ +(named-readtables:in-readtable :advanced) + +(5am:in-suite* :advanced-readtable) + +(defpackage a (:use cl)) +(in-package a) +(5am:test hierarchy1 + (5am:is (string= (package-name *package*) "A"))) + +(defpackage .b (:use cl)) +(in-package .b) +(5am:test hierarchy2 + (5am:is (string= (package-name *package*) "A.B"))) + +(in-package ..) +(5am:test hierarchy3 + (5am:is (string= (package-name *package*) "A"))) + +(defun foo () 1) + +(in-package a.b) + +(defun foo () 2) + +(5am:test hierarchy4 + (5am:is (= (+ (foo) (..::foo) 3))) + (5am:is (= (+ (foo) (..b::foo) 4))) + (5am:is (eq 'foo '..b::foo))) +; (5am:is (eq 'foo '........b::foo))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (advanced-readtable:push-import-prefix :a)) + +(5am:test import-prefix + (5am:is (eq 'foo 'b::foo))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (advanced-readtable:push-local-nickname :cl :alias)) + +(5am:test local-nickname + (5am:is (eq 'car 'alias:car))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (advanced-readtable:push-local-nickname :cl :alias))