Commit 85dedfeb authored by François-René Rideau's avatar François-René Rideau Committed by Robert Goldman
Browse files

Support package local nicknames.

Fixes #14 as suggested by reporter Andriy Kmit.
Add support for package local nicknames to package-inferred-systems and define-package.
parent fc406ce1
......@@ -75,9 +75,9 @@ the DEFPACKAGE-FORM uses it or imports a symbol from it."
(dolist (p arguments) (dep (string p))))
((:import-from :shadowing-import-from)
(dep (string (first arguments))))
(loop* :for (local-nickname actual-package-name) :in arguments :do
(loop* :for (nil actual-package-name) :in arguments :do
(dep (string actual-package-name))))
((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
:from-end t :test 'equal))
......@@ -17,8 +17,11 @@
;; package-inferred-system object.
(assert-equal "package-inferred-system-test" (primary-system-name (find-system :package-inferred-system-test/a/x)))
;; Test that SBCL's :local-nicknames are recognized
;; Test that :local-nicknames are recognized on relevant implementations
;; NB: requires ABCL >= ? (old 1.5.0 works), CCL >= 1.12 (unreleased as of Dec 2019),
;; CLASP >= ??? (no less released than anything else?), ECL >= 1.6.4 (unreleased as of Dec 2019),
;; SBCL >= ? (old 1.5.0 works)
(load-system :package-inferred-system-test/local-nicknames-1)
(assert-equal "g" (symbol-call :package-inferred-system-test/local-nicknames-1 :f)))
;;; -*- mode:common-lisp; -*-
(in-package :asdf-test)
;;; these tests for DEFINE-PACKAGE support of package-local-nicknames were adapted from
;;; the trivial-package-local-nicknames system, to test UIOP's support for package local
;;; nicknames
(defparameter +test-data+
#+sbcl '(:sb-ext :sb :exit)
#+ccl '(:ccl :cc :quit)
#+ecl '(:ext :ex :exit)
#+abcl '(:ext :ex :quit)
#+clasp '(:core :ex :quit)
#+lispworks '(:lispworks :ex :quit)
#+allegro '(:excl :ex :exit))
(defparameter +pkg-name+ (first +test-data+))
(defparameter +nn-name+ (second +test-data+))
(defparameter +sym-name+ (third +test-data+))
(defparameter +pkg-sname+ (string +pkg-name+))
(defparameter +nn-sname+ (string +nn-name+))
(defparameter +sym-sname+ (string +sym-name+))
(defparameter +sym-fullname+ (concatenate 'string +pkg-sname+ ":" +sym-sname+))
(defparameter +sym-fullnickname+ (concatenate 'string +nn-sname+ ":" +sym-sname+))
(defparameter +sym+ (or (find-symbol +sym-sname+ +pkg-name+)
(error "Symbol not found while loading tests: check +SYM+ binding."))))
(defun reset-test-packages ()
(#+sbcl sb-ext:without-package-locks
#-sbcl progn
(when (find-package :package-local-nicknames-test-1)
(delete-package :package-local-nicknames-test-1))
(when (find-package :package-local-nicknames-test-2)
(delete-package :package-local-nicknames-test-2)))
(let ((form1 `(uiop/package:define-package :package-local-nicknames-test-1 (:use)
(:local-nicknames (:l :cl) (,+nn-name+ ,+pkg-name+)))))
(eval form1))
(let ((form2 `(uiop/package:define-package :package-local-nicknames-test-2 (:use)
(:export "CONS"))))
(eval form2)))
(defmacro define-test (name &rest body)
(DBG ,(symbol-name name))
(define-test test-package-local-nicknames-introspection
(let ((*package* (find-package p)))
(let ((alist (uiop/package:package-local-nicknames :package-local-nicknames-test-1)))
(assert (equal (cons "L" (find-package "CL")) (assoc "L" alist :test 'string=)))
(assert (equal (cons +nn-sname+ (find-package +pkg-sname+))
(assoc +nn-sname+ alist :test 'string=)))
(assert (eql 2 (length alist)))))))
(define-test test-package-local-nicknames-symbol-equality
(let ((*package* (find-package :package-local-nicknames-test-1)))
(let ((cons0 (read-from-string "L:CONS"))
(cons1 (find-symbol "CONS" :l))
(cons1s (find-symbol "CONS" #\L))
(exit0 (read-from-string +sym-fullname+))
(exit1 (find-symbol +sym-sname+ +nn-name+)))
(assert (eq 'cons cons0))
(assert (eq 'cons cons1))
(assert (eq 'cons cons1s))
(assert (eq +sym+ exit0))
(assert (eq +sym+ exit1)))))
(define-test test-package-local-nicknames-package-equality
(let ((*package* (find-package :package-local-nicknames-test-1)))
(let ((cl (find-package :l))
(cls (find-package #\L))
(sb (find-package +nn-name+)))
(assert (eq cl (find-package :common-lisp)))
(assert (eq cls (find-package :common-lisp)))
(assert (eq sb (find-package +pkg-name+))))))
(define-test test-package-local-nicknames-nickname-removal
(assert (= 2 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1))))
(assert (uiop/package:remove-package-local-nickname :l :package-local-nicknames-test-1))
(assert (= 1 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1))))
(let ((*package* (find-package :package-local-nicknames-test-1)))
(assert (not (find-package :l)))))
(define-test test-package-local-nicknames-nickname-removal-char
#+ignore (declare (optimize (debug 3) (speed 0)))
(assert (= 2 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1))))
(assert (uiop/package:remove-package-local-nickname #\L :package-local-nicknames-test-1))
(assert (= 1 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1))))
(let ((*package* (find-package :package-local-nicknames-test-1)))
(assert (not (find-package :l)))))
(define-test test-package-local-nicknames-nickname-removal-readd-another-package-equality
(assert (uiop/package:remove-package-local-nickname :l :package-local-nicknames-test-1))
(assert (eq (find-package :package-local-nicknames-test-1)
(uiop/package:add-package-local-nickname :l :package-local-nicknames-test-2
(let ((*package* (find-package :package-local-nicknames-test-1)))
(let ((cl (find-package :l))
(sb (find-package +nn-name+)))
(assert (eq cl (find-package :package-local-nicknames-test-2)))
(assert (eq sb (find-package +pkg-name+))))))
......@@ -140,6 +140,7 @@
(unless (member :lispworks6 *features*)
(pushnew :lispworks7+ *features*)))))
#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
"(eval-when (:load-toplevel :compile-toplevel :execute)
......@@ -4,6 +4,22 @@
;; See
;;; package local nicknames feature. Can't be deferred until common-lisp.lisp,
;;; where most such features are set.
;;; ABCL and CCL already define this feature appropriately.
;;; Seems to be unconditionally present for SBCL, ACL, and clasp
;;; Don't know about ecl, or others
(eval-when (:load-toplevel :compile-toplevel :execute)
;; abcl pushes :package-local-nicknames without UIOP interfering,
;; and Lispworks will do so
#+(or sbcl clasp)
(pushnew :package-local-nicknames *features*)
(let ((fname (find-symbol (symbol-name '#:add-package-local-nickname) '#:excl)))
(when (and fname (fboundp fname))
(pushnew :package-local-nicknames *features*))))
(defpackage :uiop/package
;; CAUTION: we must handle the first few packages specially for hot-upgrade.
;; This package definition MUST NOT change unless its name too changes;
......@@ -12,6 +28,15 @@
;; import and export the same exact symbols as for ASDF 2.27.
;; Any other symbol must be import-from'ed and re-export'ed in a different package.
(:use :common-lisp)
(:import-from #+allegro #:excl
#+sbcl #:sb-ext
#+(or clasp abcl) #:ext
#+ccl #:ccl
#+lispworks #:hcl
#-(or allegro sbcl clasp abcl ccl lispworks)
(error "Don't know from which package this lisp supplies the local-package-nicknames API.")
#:remove-package-local-nickname #:package-local-nicknames #:add-package-local-nickname)
#:find-package* #:find-symbol* #:symbol-call
#:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern*
......@@ -22,7 +47,11 @@
#:ensure-package-unused #:delete-package*
#:package-names #:packages-from-names #:fresh-package-name #:rename-package-away
#:package-definition-form #:parse-define-package-form
#:ensure-package #:define-package))
#:ensure-package #:define-package
#+package-local-nicknames #:add-package-local-nickname
#+package-local-nicknames #:remove-package-local-nickname
#+package-local-nicknames #:package-local-nicknames
(in-package :uiop/package)
......@@ -572,12 +601,13 @@ or when loading the package is optional."
(multiple-value-bind (symbol status) (find-symbol* name from-package)
(unless (eq status :external)
(ensure-exported name symbol from-package recycle))))
(defun ensure-package (name &key
nicknames documentation use
shadow shadowing-import-from
import-from export intern
recycle mix reexport
unintern local-nicknames)
#+genera (declare (ignore documentation))
(let* ((package-name (string name))
(nicknames (mapcar #'string nicknames))
......@@ -594,11 +624,13 @@ or when loading the package is optional."
(export (mapcar 'string export))
(intern (mapcar 'string intern))
(unintern (mapcar 'string unintern))
(local-nicknames (mapcar #'(lambda (pair) (mapcar 'string pair)) local-nicknames))
(shadowed (make-hash-table :test 'equal)) ; string to bool
(imported (make-hash-table :test 'equal)) ; string to bool
(exported (make-hash-table :test 'equal)) ; string to bool
;; string to list home package and use package:
(inherited (make-hash-table :test 'equal)))
(declare (ignorable local-nicknames)) ; if not supported
(when-package-fishiness (record-fishy package-name))
(when documentation (setf (documentation package t) documentation))
......@@ -613,6 +645,15 @@ or when loading the package is optional."
(t (rename-package-away p)
(push p to-delete))))
(rename-package package package-name nicknames)
;; Handle local nicknames
(let* ((existing-nicknames (mapcar #'(lambda (x) (string (car x))) (package-local-nicknames package)))
(new-nicknames (mapcar #'(lambda (x) (string (first x))) local-nicknames))
(to-remove (set-difference existing-nicknames new-nicknames :test 'equal)))
(mapc #'(lambda (x) (remove-package-local-nickname x package)) to-remove))
(loop :for (nick-str package-str) :in local-nicknames
:do (add-package-local-nickname nick-str package-str package))
(dolist (name unintern)
(multiple-value-bind (existing status) (find-symbol name package)
(when status
......@@ -673,6 +714,7 @@ or when loading the package is optional."
(map () 'delete-package* to-delete)
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun parse-define-package-form (package clauses)
......@@ -699,6 +741,13 @@ or when loading the package is optional."
:when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport
:and :do (setf use-p t) :else
:when (eq kw :unintern) :append args :into unintern :else
:when (eq kw :local-nicknames)
:if (symbol-call '#:uiop '#:featurep :package-local-nicknames)
:append args :into local-nicknames
:do (error ":LOCAL-NICKAMES option is not supported on this lisp implementation.")
:do (error "unrecognized define-package keyword ~S" kw)
:finally (return `(',package
:nicknames ',nicknames :documentation ',documentation
......@@ -706,7 +755,8 @@ or when loading the package is optional."
:shadow ',shadow :shadowing-import-from ',shadowing-import-from
:import-from ',import-from :export ',export :intern ',intern
:recycle ',(if recycle-p recycle (cons package nicknames))
:mix ',mix :reexport ',reexport :unintern ',unintern)))))
:mix ',mix :reexport ',reexport :unintern ',unintern
:local-nicknames ',local-nicknames)))))
(defmacro define-package (package &rest clauses)
"DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form
......@@ -730,7 +780,11 @@ an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
REEXPORT -- Takes a list of package designators. For each package, p, in the list,
export symbols with the same name as those exported from p. Note that in the case
of shadowing, etc. the symbols with the same name may not be the same symbols.
UNINTERN -- Remove symbols here from PACKAGE."
UNINTERN -- Remove symbols here from PACKAGE.
LOCAL-NICKNAMES -- If the host implementation supports package local nicknames
\(check for the :PACKAGE-LOCAL-NICKNAMES feature\), then this should be a list of
nickname and package name pairs. Using this option will cause an error if the
host CL implementation does not support it."
(let ((ensure-form
(funcall 'ensure-package ,@(parse-define-package-form package clauses))
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment