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