diff --git a/README.md b/README.md index c512cbb..58da9d6 100644 --- a/README.md +++ b/README.md @@ -39,6 +39,7 @@ 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. +Verbose documentation one may see at [allegro CL][http://www.franz.com/support/documentation/9.0/doc/packages.htm#relative-2]. CL-USER> (defpackage .test (:use cl))) # @@ -55,6 +56,13 @@ In in-package you may use .. for above package, ... for two level up, and so on. TEST> (in-package ..) CL-USER> +You may use local-nicknames in defpackage (syntax taken from [SBCL][https://github.com/nikodemus/SBCL/commit/3c11847d1e12db89b24a7887b18a137c45ed4661]) + + CL-USER> (defpackage :foo (:use :cl) (:local-nicknames (:it :cl))) + CL-USER> (in-package :foo) + FOO> (it:car '(1 2 3)) + 1 + API === diff --git a/finders.lisp b/finders.lisp index 4a6f4f6..12cf8e5 100644 --- a/finders.lisp +++ b/finders.lisp @@ -104,7 +104,8 @@ new handler if it is not already there. " `(let ((key ,key) (function ,function)) (let ((found (assoc key ,handler-list :test #'equal))) - (if found (cdr found) + (if found + (setf (cdr found) function) (prog1 function (push (cons key function) diff --git a/hierarchy.lisp b/hierarchy.lisp index 83f86db..a94d6de 100644 --- a/hierarchy.lisp +++ b/hierarchy.lisp @@ -24,12 +24,12 @@ Replace first section of hierarchy with proper name" (if pos (subseq name 0 pos) ""))) (relative-to (parent name) (cond - ((string= parent "") name) + ((string= parent "") nil) ((string= name "") parent) (t (concatenate 'string parent "." name))))) (defun hierarchy-find-package (name package) (when (string= name "") - (return-from hierarchy-find-package package)) + (return-from hierarchy-find-package nil)) (if (char= (char name 0) #\.) (do ((i 1 (1+ i)) (p (package-name package) (parent p))) @@ -46,19 +46,35 @@ Replace first section of hierarchy with proper name" (defmacro in-package (designator) `(|CL|:in-package ,(correct-package (string designator)))) +(defun process-local-nicknames (package pairs) + (let (res) + (dolist (pair pairs (nreverse res)) + (destructuring-bind (sym orig) pair + (push (list 'push-local-nickname orig sym package) res))))) + (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))) + (let (post-commands new-options + (normalized (or (normalize-package (string package)) + package))) + (dolist (option options) + (push (cons (car option) + (case (car option) + (:use (mapcar #'correct-package (cdr option))) + ((:import-from :shadowing-import-from) + (cons (correct-package (second option)) (cddr option))) + (:local-nicknames + (progn + (mapcar + (lambda (command) + (push command post-commands)) + (process-local-nicknames normalized (cdr option))) + (go next))) + (t (cdr option)))) + new-options) + next) + `(prog1 + (|CL|:defpackage ,normalized . ,(nreverse new-options)) + ,@post-commands))) (defun substitute-symbol (stream symbol) (declare (ignore stream))