1.1--- a/lisp/ffi/nuklear/nuklear.asd Sun Mar 03 20:50:37 2024 -0500
1.2+++ b/lisp/ffi/nuklear/nuklear.asd Thu Mar 07 23:06:25 2024 -0500
1.3@@ -0,0 +1,24 @@
1.4+;;; nuklear.asd --- NUKLEAR SYSTEMS
1.5+(eval-when (:compile-toplevel :load-toplevel :execute)
1.6+ (require :sb-grovel))
1.7+
1.8+(defpackage :nuklear.sys
1.9+ (:use :cl :asdf :sb-grovel :sb-alien))
1.10+
1.11+(in-package :nuklear.sys)
1.12+
1.13+(defsystem "nuklear"
1.14+ :version "0.1.0"
1.15+ :license (:file "LICENSE")
1.16+ :maintainer "ellis <ellis@rwest.io>"
1.17+ :bug-tracker "https://vc.compiler.company/comp/core/issues"
1.18+ :depends-on (:sb-grovel :std)
1.19+ :components ((:file "pkg")
1.20+ (grovel-constants-file "constants"
1.21+ :package :nuklear))
1.22+ :in-order-to ((test-op (test-op "nuklear/tests"))))
1.23+
1.24+(defsystem "nuklear/tests"
1.25+ :depends-on (:rt :nuklear)
1.26+ :components ((:file "tests"))
1.27+ :perform (test-op (op c) (uiop:symbol-call '#:rt '#:do-tests :nuklear)))
2.1--- a/lisp/ffi/nuklear/pkg.lisp Sun Mar 03 20:50:37 2024 -0500
2.2+++ b/lisp/ffi/nuklear/pkg.lisp Thu Mar 07 23:06:25 2024 -0500
2.3@@ -1,28 +1,4 @@
2.4-;;; nuklear.asd --- NUKLEAR SYSTEMS
2.5-
2.6-;; NUKLEAR for lisp.
2.7-
2.8-;;; Code:
2.9-(eval-when (:compile-toplevel :load-toplevel :execute)
2.10- (require :sb-grovel))
2.11-
2.12-(defpackage :nuklear.sys
2.13- (:use :cl :asdf :sb-grovel :sb-alien))
2.14-
2.15-(in-package :nuklear.sys)
2.16+(defpackage :nuklear
2.17+ (:use :cl :std))
2.18
2.19-(defsystem "nuklear"
2.20- :version "0.1.0"
2.21- :license (:file "LICENSE")
2.22- :maintainer "ellis <ellis@rwest.io>"
2.23- :bug-tracker "https://vc.compiler.company/comp/core/issues"
2.24- :depends-on (:sb-grovel :std)
2.25- :components ((:file "pkg")
2.26- (grovel-constants-file "constants"
2.27- :package :nuklear))
2.28- :in-order-to ((test-op (test-op "nuklear/tests"))))
2.29-
2.30-(defsystem "nuklear/tests"
2.31- :depends-on (:rt :nuklear)
2.32- :components ((:file "tests"))
2.33- :perform (test-op (op c) (uiop:symbol-call '#:rt '#:do-tests :nuklear)))
2.34+(in-package :nuklear)
3.1--- a/lisp/lib/log/err.lisp Sun Mar 03 20:50:37 2024 -0500
3.2+++ b/lisp/lib/log/err.lisp Thu Mar 07 23:06:25 2024 -0500
3.3@@ -1,4 +1,7 @@
3.4+;; log/err.lisp --- errors which may be signalled durring logging
3.5+
3.6+;;; Code:
3.7 (in-package :log)
3.8
3.9-(define-condition log-error (simple-error program-error) ()
3.10+(define-condition log-error (std-error simple-error program-error) ()
3.11 (:documentation "Base class for all LOG errors"))
4.1--- a/lisp/lib/log/log.asd Sun Mar 03 20:50:37 2024 -0500
4.2+++ b/lisp/lib/log/log.asd Thu Mar 07 23:06:25 2024 -0500
4.3@@ -5,8 +5,7 @@
4.4 :components ((:file "pkg")
4.5 (:file "err")
4.6 (:file "log")
4.7- (:file "source")
4.8- (:file "sink"))
4.9+ (:file "stream"))
4.10 :in-order-to ((test-op (test-op "log/tests"))))
4.11
4.12 (defsystem :log/tests
5.1--- a/lisp/lib/log/log.lisp Sun Mar 03 20:50:37 2024 -0500
5.2+++ b/lisp/lib/log/log.lisp Thu Mar 07 23:06:25 2024 -0500
5.3@@ -2,11 +2,11 @@
5.4
5.5 (deftype log-level-designator () '(member :warn :debug :info :trace))
5.6 (declaim (type (or boolean log-level-designator) *log-level*))
5.7-(defparameter *log-level* nil)
5.8-(defparameter *logger* nil)
5.9-(defparameter *log-router* nil)
5.10+(defvar *log-level* nil)
5.11+(defvar *logger* nil)
5.12+(defvar *log-router* nil)
5.13 (declaim (type (or boolean function) *log-timestamp*))
5.14-(defparameter *log-timestamp* t
5.15+(defvar *log-timestamp* t
5.16 "If non-nil, print a timestamp with log output. The value may be a
5.17 function in which case it is used as the function value of
5.18 `log-timestamp-source'.")
5.19@@ -39,6 +39,30 @@
5.20 ;; TODO: (defmacro generate-log-profile)
5.21 ;; (defmacro with-log-profile)
5.22 ;; (defmacro with-logger)
5.23+(defmacro define-log-level (name)
5.24+ (let ((%name (string-upcase name)))
5.25+ `(progn
5.26+ (defun ,(intern (concatenate 'string %name "!")) (&rest args)
5.27+ (format t ":~A:~A~%"
5.28+ ',name
5.29+ (if *log-timestamp*
5.30+ (format nil "~A ~t" (log-timestamp-source))
5.31+ ""))
5.32+ (map nil (lambda (x) (format t "~X~%" x)) args)
5.33+ (if (= 1 (length args))
5.34+ (car args)
5.35+ args))
5.36+ (defun ,(intern (concatenate 'string %name "-P")) ()
5.37+ (eql *log-level* ,(sb-int:keywordicate name)))
5.38+ (defun ,(intern (concatenate 'string %name "-DESCRIBE")) (&rest args)
5.39+ (,(intern (concatenate 'string %name "!")) (apply #'describe args))))))
5.40+
5.41+(define-log-level info)
5.42+(define-log-level trace)
5.43+(define-log-level warn)
5.44+(define-log-level debug)
5.45+
5.46+#+nil (test! "foo")
5.47
5.48 (defmacro info! (opts &rest args))
5.49
5.50@@ -64,4 +88,4 @@
5.51
5.52 (defun debug-describe (&rest args)
5.53 (debug! (apply #'describe args)))
5.54-
5.55+
6.1--- a/lisp/lib/log/pkg.lisp Sun Mar 03 20:50:37 2024 -0500
6.2+++ b/lisp/lib/log/pkg.lisp Thu Mar 07 23:06:25 2024 -0500
6.3@@ -25,6 +25,8 @@
6.4 ;;; Code:
6.5 (defpackage :log
6.6 (:use :cl :std)
6.7- (:export :*log-level* :log-level-designator :log-timestamp-source
6.8- :log! :warn! :info! :debug! :trace! :dbg!
6.9- :debug-p))
6.10+ (:export :*log-level* :*log-router* :*logger*
6.11+ :*log-timestmap* :log-level-designator :log-timestamp-source :logger
6.12+ :define-log-level :log! :warn! :info! :debug! :trace!
6.13+ :log-p :warn-p :info-p :debug-p :trace-p
6.14+ :log-describe :warn-describe :info-describe :debug-describe :trace-describe))
8.1--- a/lisp/lib/log/source.lisp Sun Mar 03 20:50:37 2024 -0500
8.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
8.3@@ -1,1 +0,0 @@
8.4-(in-package :log)
9.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
9.2+++ b/lisp/lib/log/stream.lisp Thu Mar 07 23:06:25 2024 -0500
9.3@@ -0,0 +1,2 @@
9.4+;;; log/stream.lisp --- Logging streams
9.5+(in-package :log)
10.1--- a/lisp/std/defpkg.lisp Sun Mar 03 20:50:37 2024 -0500
10.2+++ b/lisp/std/defpkg.lisp Thu Mar 07 23:06:25 2024 -0500
10.3@@ -7,4 +7,702 @@
10.4 ;;; Code:
10.5 (in-package :std)
10.6
10.7+(eval-when (:load-toplevel :compile-toplevel :execute)
10.8+ (defun find-package* (package-designator &optional (error t))
10.9+ (let ((package (find-package package-designator)))
10.10+ (cond
10.11+ (package package)
10.12+ (error (error "No package named ~S" (string package-designator)))
10.13+ (t nil))))
10.14+ (defun find-symbol* (name package-designator &optional (error t))
10.15+ "Find a symbol in a package of given string'ified NAME;
10.16+unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
10.17+by letting you supply a symbol or keyword for the name;
10.18+also works well when the package is not present.
10.19+If optional ERROR argument is NIL, return NIL instead of an error
10.20+when the symbol is not found."
10.21+ (block nil
10.22+ (let ((package (find-package* package-designator error)))
10.23+ (when package ;; package error handled by find-package* already
10.24+ (multiple-value-bind (symbol status) (find-symbol (string name) package)
10.25+ (cond
10.26+ (status (return (values symbol status)))
10.27+ (error (error "There is no symbol ~S in package ~S" name (package-name package))))))
10.28+ (values nil nil))))
10.29+ (defun symbol-call (package name &rest args)
10.30+ "Call a function associated with symbol of given name in given package,
10.31+with given ARGS. Useful when the call is read before the package is loaded,
10.32+or when loading the package is optional."
10.33+ (apply (find-symbol* name package) args))
10.34+ (defun intern* (name package-designator &optional (error t))
10.35+ (intern (string name) (find-package* package-designator error)))
10.36+ (defun export* (name package-designator)
10.37+ (let* ((package (find-package* package-designator))
10.38+ (symbol (intern* name package)))
10.39+ (export (or symbol (list symbol)) package)))
10.40+ (defun import* (symbol package-designator)
10.41+ (import (or symbol (list symbol)) (find-package* package-designator)))
10.42+ (defun shadowing-import* (symbol package-designator)
10.43+ (shadowing-import (or symbol (list symbol)) (find-package* package-designator)))
10.44+ (defun shadow* (name package-designator)
10.45+ (shadow (list (string name)) (find-package* package-designator)))
10.46+ (defun make-symbol* (name)
10.47+ (etypecase name
10.48+ (string (make-symbol name))
10.49+ (symbol (copy-symbol name))))
10.50+ (defun unintern* (name package-designator &optional (error t))
10.51+ (block nil
10.52+ (let ((package (find-package* package-designator error)))
10.53+ (when package
10.54+ (multiple-value-bind (symbol status) (find-symbol* name package error)
10.55+ (cond
10.56+ (status (unintern symbol package)
10.57+ (return (values symbol status)))
10.58+ (error (error "symbol ~A not present in package ~A"
10.59+ (string symbol) (package-name package))))))
10.60+ (values nil nil))))
10.61+ (defun symbol-shadowing-p (symbol package)
10.62+ (and (member symbol (package-shadowing-symbols package)) t))
10.63+ (defun home-package-p (symbol package)
10.64+ (and package (let ((sp (symbol-package symbol)))
10.65+ (and sp (let ((pp (find-package* package)))
10.66+ (and pp (eq sp pp))))))))
10.67
10.68+
10.69+(eval-when (:load-toplevel :compile-toplevel :execute)
10.70+ (defun symbol-package-name (symbol)
10.71+ (let ((package (symbol-package symbol)))
10.72+ (and package (package-name package))))
10.73+ (defun standard-common-lisp-symbol-p (symbol)
10.74+ (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
10.75+ (and (eq sym symbol) (eq status :external))))
10.76+ (defun reify-package (package &optional package-context)
10.77+ (if (eq package package-context) t
10.78+ (etypecase package
10.79+ (null nil)
10.80+ ((eql (find-package :cl)) :cl)
10.81+ (package (package-name package)))))
10.82+ (defun unreify-package (package &optional package-context)
10.83+ (etypecase package
10.84+ (null nil)
10.85+ ((eql t) package-context)
10.86+ ((or symbol string) (find-package package))))
10.87+ (defun reify-symbol (symbol &optional package-context)
10.88+ (etypecase symbol
10.89+ ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
10.90+ (symbol (vector (symbol-name symbol)
10.91+ (reify-package (symbol-package symbol) package-context)))))
10.92+ (defun unreify-symbol (symbol &optional package-context)
10.93+ (etypecase symbol
10.94+ (symbol symbol)
10.95+ ((simple-vector 2)
10.96+ (let* ((symbol-name (svref symbol 0))
10.97+ (package-foo (svref symbol 1))
10.98+ (package (unreify-package package-foo package-context)))
10.99+ (if package (intern* symbol-name package)
10.100+ (make-symbol* symbol-name)))))))
10.101+
10.102+(eval-when (:load-toplevel :compile-toplevel :execute)
10.103+ (defvar *all-package-happiness* '())
10.104+ (defvar *all-package-fishiness* (list t))
10.105+ (defun record-fishy (info)
10.106+ ;;(format t "~&FISHY: ~S~%" info)
10.107+ (push info *all-package-fishiness*))
10.108+ (defmacro when-package-fishiness (&body body)
10.109+ `(when *all-package-fishiness* ,@body))
10.110+ (defmacro note-package-fishiness (&rest info)
10.111+ `(when-package-fishiness (record-fishy (list ,@info)))))
10.112+
10.113+(eval-when (:load-toplevel :compile-toplevel :execute)
10.114+ #+(or clisp clozure)
10.115+ (defun get-setf-function-symbol (symbol)
10.116+ #+clisp (let ((sym (get symbol 'system::setf-function)))
10.117+ (if sym (values sym :setf-function)
10.118+ (let ((sym (get symbol 'system::setf-expander)))
10.119+ (if sym (values sym :setf-expander)
10.120+ (values nil nil)))))
10.121+ #+clozure (gethash symbol ccl::%setf-function-names%))
10.122+ #+(or clisp clozure)
10.123+ (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
10.124+ #+clisp (assert (member kind '(:setf-function :setf-expander)))
10.125+ #+clozure (assert (eq kind t))
10.126+ #+clisp
10.127+ (cond
10.128+ ((null new-setf-symbol)
10.129+ (remprop symbol 'system::setf-function)
10.130+ (remprop symbol 'system::setf-expander))
10.131+ ((eq kind :setf-function)
10.132+ (setf (get symbol 'system::setf-function) new-setf-symbol))
10.133+ ((eq kind :setf-expander)
10.134+ (setf (get symbol 'system::setf-expander) new-setf-symbol))
10.135+ (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
10.136+ kind symbol new-setf-symbol)))
10.137+ #+clozure
10.138+ (progn
10.139+ (gethash symbol ccl::%setf-function-names%) new-setf-symbol
10.140+ (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
10.141+ #+(or clisp clozure)
10.142+ (defun create-setf-function-symbol (symbol)
10.143+ #+clisp (system::setf-symbol symbol)
10.144+ #+clozure (ccl::construct-setf-function-name symbol))
10.145+ (defun set-dummy-symbol (symbol reason other-symbol)
10.146+ (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
10.147+ (defun make-dummy-symbol (symbol)
10.148+ (let ((dummy (copy-symbol symbol)))
10.149+ (set-dummy-symbol dummy 'replacing symbol)
10.150+ (set-dummy-symbol symbol 'replaced-by dummy)
10.151+ dummy))
10.152+ (defun dummy-symbol (symbol)
10.153+ (get symbol 'dummy-symbol))
10.154+ (defun get-dummy-symbol (symbol)
10.155+ (let ((existing (dummy-symbol symbol)))
10.156+ (if existing (values (cdr existing) (car existing))
10.157+ (make-dummy-symbol symbol))))
10.158+ (defun nuke-symbol-in-package (symbol package-designator)
10.159+ (let ((package (find-package* package-designator))
10.160+ (name (symbol-name symbol)))
10.161+ (multiple-value-bind (sym stat) (find-symbol name package)
10.162+ (when (and (member stat '(:internal :external)) (eq symbol sym))
10.163+ (if (symbol-shadowing-p symbol package)
10.164+ (shadowing-import* (get-dummy-symbol symbol) package)
10.165+ (unintern* symbol package))))))
10.166+ (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
10.167+ #+(or clisp clozure)
10.168+ (multiple-value-bind (setf-symbol kind)
10.169+ (get-setf-function-symbol symbol)
10.170+ (when kind (nuke-symbol setf-symbol)))
10.171+ (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
10.172+ (defun rehome-symbol (symbol package-designator)
10.173+ "Changes the home package of a symbol, also leaving it present in its old home if any"
10.174+ (let* ((name (symbol-name symbol))
10.175+ (package (find-package* package-designator))
10.176+ (old-package (symbol-package symbol))
10.177+ (old-status (and old-package (nth-value 1 (find-symbol name old-package))))
10.178+ (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
10.179+ (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
10.180+ (unless (eq package old-package)
10.181+ (let ((overwritten-symbol-shadowing-p
10.182+ (and overwritten-symbol-status
10.183+ (symbol-shadowing-p overwritten-symbol package))))
10.184+ (note-package-fishiness
10.185+ :rehome-symbol name
10.186+ (when old-package (package-name old-package)) old-status (and shadowing t)
10.187+ (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
10.188+ (when old-package
10.189+ (if shadowing
10.190+ (shadowing-import* shadowing old-package))
10.191+ (unintern* symbol old-package))
10.192+ (cond
10.193+ (overwritten-symbol-shadowing-p
10.194+ (shadowing-import* symbol package))
10.195+ (t
10.196+ (when overwritten-symbol-status
10.197+ (unintern* overwritten-symbol package))
10.198+ (import* symbol package)))
10.199+ (if shadowing
10.200+ (shadowing-import* symbol old-package)
10.201+ (import* symbol old-package))
10.202+ #+(or clisp clozure)
10.203+ (multiple-value-bind (setf-symbol kind)
10.204+ (get-setf-function-symbol symbol)
10.205+ (when kind
10.206+ (let* ((setf-function (fdefinition setf-symbol))
10.207+ (new-setf-symbol (create-setf-function-symbol symbol)))
10.208+ (note-package-fishiness
10.209+ :setf-function
10.210+ name (package-name package)
10.211+ (symbol-name setf-symbol) (symbol-package-name setf-symbol)
10.212+ (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
10.213+ (when (symbol-package setf-symbol)
10.214+ (unintern* setf-symbol (symbol-package setf-symbol)))
10.215+ (setf (fdefinition new-setf-symbol) setf-function)
10.216+ (set-setf-function-symbol new-setf-symbol symbol kind))))
10.217+ #+(or clisp clozure)
10.218+ (multiple-value-bind (overwritten-setf foundp)
10.219+ (get-setf-function-symbol overwritten-symbol)
10.220+ (when foundp
10.221+ (unintern overwritten-setf)))
10.222+ (when (eq old-status :external)
10.223+ (export* symbol old-package))
10.224+ (when (eq overwritten-symbol-status :external)
10.225+ (export* symbol package))))
10.226+ (values overwritten-symbol overwritten-symbol-status))))
10.227+ (defun ensure-package-unused (package)
10.228+ (loop :for p :in (package-used-by-list package) :do
10.229+ (unuse-package package p)))
10.230+ (defun delete-package* (package &key nuke)
10.231+ (let ((p (find-package package)))
10.232+ (when p
10.233+ (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
10.234+ (ensure-package-unused p)
10.235+ (delete-package package))))
10.236+ (defun package-names (package)
10.237+ (cons (package-name package) (package-nicknames package)))
10.238+ (defun packages-from-names (names)
10.239+ (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
10.240+ (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
10.241+ separator
10.242+ (index (random most-positive-fixnum)))
10.243+ (loop :for i :from index
10.244+ :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
10.245+ :thereis (and (not (find-package n)) n)))
10.246+ (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
10.247+ (let ((new-name
10.248+ (apply 'fresh-package-name
10.249+ :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
10.250+ (record-fishy (list :rename-away (package-names p) new-name))
10.251+ (rename-package p new-name))))
10.252+
10.253+
10.254+;;; Communicable representation of symbol and package information
10.255+
10.256+(eval-when (:load-toplevel :compile-toplevel :execute)
10.257+ (defun package-definition-form (package-designator
10.258+ &key (nicknamesp t) (usep t)
10.259+ (shadowp t) (shadowing-import-p t)
10.260+ (exportp t) (importp t) internp (error t))
10.261+ (let* ((package (or (find-package* package-designator error)
10.262+ (return-from package-definition-form nil)))
10.263+ (name (package-name package))
10.264+ (nicknames (package-nicknames package))
10.265+ (use (mapcar #'package-name (package-use-list package)))
10.266+ (shadow ())
10.267+ (shadowing-import (make-hash-table :test 'equal))
10.268+ (import (make-hash-table :test 'equal))
10.269+ (export ())
10.270+ (intern ()))
10.271+ (when package
10.272+ (loop :for sym :being :the :symbols :in package
10.273+ :for status = (nth-value 1 (find-symbol* sym package)) :do
10.274+ (ecase status
10.275+ ((nil :inherited))
10.276+ ((:internal :external)
10.277+ (let* ((name (symbol-name sym))
10.278+ (external (eq status :external))
10.279+ (home (symbol-package sym))
10.280+ (home-name (package-name home))
10.281+ (imported (not (eq home package)))
10.282+ (shadowing (symbol-shadowing-p sym package)))
10.283+ (cond
10.284+ ((and shadowing imported)
10.285+ (push name (gethash home-name shadowing-import)))
10.286+ (shadowing
10.287+ (push name shadow))
10.288+ (imported
10.289+ (push name (gethash home-name import))))
10.290+ (cond
10.291+ (external
10.292+ (push name export))
10.293+ (imported)
10.294+ (t (push name intern)))))))
10.295+ (labels ((sort-names (names)
10.296+ (sort (copy-list names) #'string<))
10.297+ (table-keys (table)
10.298+ (loop :for k :being :the :hash-keys :of table :collect k))
10.299+ (when-relevant (key value)
10.300+ (when value (list (cons key value))))
10.301+ (import-options (key table)
10.302+ (loop :for i :in (sort-names (table-keys table))
10.303+ :collect `(,key ,i ,@(sort-names (gethash i table))))))
10.304+ `(defpackage ,name
10.305+ ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
10.306+ (:use ,@(and usep (sort-names use)))
10.307+ ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
10.308+ ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
10.309+ ,@(import-options :import-from (and importp import))
10.310+ ,@(when-relevant :export (and exportp (sort-names export)))
10.311+ ,@(when-relevant :intern (and internp (sort-names intern)))))))))
10.312+
10.313+(eval-when (:load-toplevel :compile-toplevel :execute)
10.314+ (defun ensure-shadowing-import (name to-package from-package shadowed imported)
10.315+ (check-type name string)
10.316+ (check-type to-package package)
10.317+ (check-type from-package package)
10.318+ (check-type shadowed hash-table)
10.319+ (check-type imported hash-table)
10.320+ (let ((import-me (find-symbol* name from-package)))
10.321+ (multiple-value-bind (existing status) (find-symbol name to-package)
10.322+ (cond
10.323+ ((gethash name shadowed)
10.324+ (unless (eq import-me existing)
10.325+ (error "Conflicting shadowings for ~A" name)))
10.326+ (t
10.327+ (setf (gethash name shadowed) t)
10.328+ (setf (gethash name imported) t)
10.329+ (unless (or (null status)
10.330+ (and (member status '(:internal :external))
10.331+ (eq existing import-me)
10.332+ (symbol-shadowing-p existing to-package)))
10.333+ (note-package-fishiness
10.334+ :shadowing-import name
10.335+ (package-name from-package)
10.336+ (or (home-package-p import-me from-package) (symbol-package-name import-me))
10.337+ (package-name to-package) status
10.338+ (and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
10.339+ (shadowing-import* import-me to-package))))))
10.340+ (defun ensure-imported (import-me into-package &optional from-package)
10.341+ (check-type import-me symbol)
10.342+ (check-type into-package package)
10.343+ (check-type from-package (or null package))
10.344+ (let ((name (symbol-name import-me)))
10.345+ (multiple-value-bind (existing status) (find-symbol name into-package)
10.346+ (cond
10.347+ ((not status)
10.348+ (import* import-me into-package))
10.349+ ((eq import-me existing))
10.350+ (t
10.351+ (let ((shadowing-p (symbol-shadowing-p existing into-package)))
10.352+ (note-package-fishiness
10.353+ :ensure-imported name
10.354+ (and from-package (package-name from-package))
10.355+ (or (home-package-p import-me from-package) (symbol-package-name import-me))
10.356+ (package-name into-package)
10.357+ status
10.358+ (and status (or (home-package-p existing into-package) (symbol-package-name existing)))
10.359+ shadowing-p)
10.360+ (cond
10.361+ ((or shadowing-p (eq status :inherited))
10.362+ (shadowing-import* import-me into-package))
10.363+ (t
10.364+ (unintern* existing into-package)
10.365+ (import* import-me into-package))))))))
10.366+ (values))
10.367+ (defun ensure-import (name to-package from-package shadowed imported)
10.368+ (check-type name string)
10.369+ (check-type to-package package)
10.370+ (check-type from-package package)
10.371+ (check-type shadowed hash-table)
10.372+ (check-type imported hash-table)
10.373+ (multiple-value-bind (import-me import-status) (find-symbol name from-package)
10.374+ (when (null import-status)
10.375+ (note-package-fishiness
10.376+ :import-uninterned name (package-name from-package) (package-name to-package))
10.377+ (setf import-me (intern* name from-package)))
10.378+ (multiple-value-bind (existing status) (find-symbol name to-package)
10.379+ (cond
10.380+ ((and imported (gethash name imported))
10.381+ (unless (and status (eq import-me existing))
10.382+ (error "Can't import ~S from both ~S and ~S"
10.383+ name (package-name (symbol-package existing)) (package-name from-package))))
10.384+ ((gethash name shadowed)
10.385+ (error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
10.386+ (t
10.387+ (setf (gethash name imported) t))))
10.388+ (ensure-imported import-me to-package from-package)))
10.389+ (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
10.390+ (check-type name string)
10.391+ (check-type symbol symbol)
10.392+ (check-type to-package package)
10.393+ (check-type from-package package)
10.394+ (check-type mixp (member nil t)) ; no cl:boolean on Genera
10.395+ (check-type shadowed hash-table)
10.396+ (check-type imported hash-table)
10.397+ (check-type inherited hash-table)
10.398+ (multiple-value-bind (existing status) (find-symbol name to-package)
10.399+ (let* ((sp (symbol-package symbol))
10.400+ (in (gethash name inherited))
10.401+ (xp (and status (symbol-package existing))))
10.402+ (when (null sp)
10.403+ (note-package-fishiness
10.404+ :import-uninterned name
10.405+ (package-name from-package) (package-name to-package) mixp)
10.406+ (import* symbol from-package)
10.407+ (setf sp (package-name from-package)))
10.408+ (cond
10.409+ ((gethash name shadowed))
10.410+ (in
10.411+ (unless (equal sp (first in))
10.412+ (if mixp
10.413+ (ensure-shadowing-import name to-package (second in) shadowed imported)
10.414+ (error "Can't inherit ~S from ~S, it is inherited from ~S"
10.415+ name (package-name sp) (package-name (first in))))))
10.416+ ((gethash name imported)
10.417+ (unless (eq symbol existing)
10.418+ (error "Can't inherit ~S from ~S, it is imported from ~S"
10.419+ name (package-name sp) (package-name xp))))
10.420+ (t
10.421+ (setf (gethash name inherited) (list sp from-package))
10.422+ (when (and status (not (eq sp xp)))
10.423+ (let ((shadowing (symbol-shadowing-p existing to-package)))
10.424+ (note-package-fishiness
10.425+ :inherited name
10.426+ (package-name from-package)
10.427+ (or (home-package-p symbol from-package) (symbol-package-name symbol))
10.428+ (package-name to-package)
10.429+ (or (home-package-p existing to-package) (symbol-package-name existing)))
10.430+ (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported)
10.431+ (unintern* existing to-package)))))))))
10.432+ (defun ensure-mix (name symbol to-package from-package shadowed imported inherited)
10.433+ (check-type name string)
10.434+ (check-type symbol symbol)
10.435+ (check-type to-package package)
10.436+ (check-type from-package package)
10.437+ (check-type shadowed hash-table)
10.438+ (check-type imported hash-table)
10.439+ (check-type inherited hash-table)
10.440+ (unless (gethash name shadowed)
10.441+ (multiple-value-bind (existing status) (find-symbol name to-package)
10.442+ (let* ((sp (symbol-package symbol))
10.443+ (im (gethash name imported))
10.444+ (in (gethash name inherited)))
10.445+ (cond
10.446+ ((or (null status)
10.447+ (and status (eq symbol existing))
10.448+ (and in (eq sp (first in))))
10.449+ (ensure-inherited name symbol to-package from-package t shadowed imported inherited))
10.450+ (in
10.451+ (remhash name inherited)
10.452+ (ensure-shadowing-import name to-package (second in) shadowed imported))
10.453+ (im
10.454+ (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]"
10.455+ name (package-name from-package)
10.456+ (home-package-p symbol from-package) (symbol-package-name symbol)
10.457+ (package-name to-package)
10.458+ (home-package-p existing to-package) (symbol-package-name existing)))
10.459+ (t
10.460+ (ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
10.461+
10.462+ (defun recycle-symbol (name recycle exported)
10.463+ ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE
10.464+ ;; packages, and a hash-table of names (strings) of symbols scheduled to be
10.465+ ;; EXPORTED from the package being defined. It returns two values, the
10.466+ ;; symbol found (if any, or else NIL), and a boolean flag indicating whether
10.467+ ;; a symbol was found. The caller (DEFPKG) will then do the
10.468+ ;; re-homing of the symbol, etc.
10.469+ (check-type name string)
10.470+ (check-type recycle list)
10.471+ (check-type exported hash-table)
10.472+ (when (gethash name exported) ;; don't bother recycling private symbols
10.473+ (let (recycled foundp)
10.474+ (dolist (r recycle (values recycled foundp))
10.475+ (multiple-value-bind (symbol status) (find-symbol name r)
10.476+ (when (and status (home-package-p symbol r))
10.477+ (cond
10.478+ (foundp
10.479+ ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
10.480+ (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r)))
10.481+ (t
10.482+ (setf recycled symbol foundp r)))))))))
10.483+ (defun symbol-recycled-p (sym recycle)
10.484+ (check-type sym symbol)
10.485+ (check-type recycle list)
10.486+ (and (member (symbol-package sym) recycle) t))
10.487+ (defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
10.488+ (check-type name string)
10.489+ (check-type package package)
10.490+ (check-type intern (member nil t)) ; no cl:boolean on Genera
10.491+ (check-type shadowed hash-table)
10.492+ (check-type imported hash-table)
10.493+ (check-type inherited hash-table)
10.494+ (unless (or (gethash name shadowed)
10.495+ (gethash name imported)
10.496+ (gethash name inherited))
10.497+ (multiple-value-bind (existing status)
10.498+ (find-symbol name package)
10.499+ (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
10.500+ (cond
10.501+ ((and status (eq existing recycled) (eq previous package)))
10.502+ (previous
10.503+ (rehome-symbol recycled package))
10.504+ ((and status (eq package (symbol-package existing))))
10.505+ (t
10.506+ (when status
10.507+ (note-package-fishiness
10.508+ :ensure-symbol name
10.509+ (reify-package (symbol-package existing) package)
10.510+ status intern)
10.511+ (unintern existing))
10.512+ (when intern
10.513+ (intern* name package))))))))
10.514+ (declaim (ftype (function (t t t &optional t) t) ensure-exported))
10.515+ (defun ensure-exported-to-user (name symbol to-package &optional recycle)
10.516+ (check-type name string)
10.517+ (check-type symbol symbol)
10.518+ (check-type to-package package)
10.519+ (check-type recycle list)
10.520+ (assert (equal name (symbol-name symbol)))
10.521+ (multiple-value-bind (existing status) (find-symbol name to-package)
10.522+ (unless (and status (eq symbol existing))
10.523+ (let ((accessible
10.524+ (or (null status)
10.525+ (let ((shadowing (symbol-shadowing-p existing to-package))
10.526+ (recycled (symbol-recycled-p existing recycle)))
10.527+ (unless (and shadowing (not recycled))
10.528+ (note-package-fishiness
10.529+ :ensure-export name (symbol-package-name symbol)
10.530+ (package-name to-package)
10.531+ (or (home-package-p existing to-package) (symbol-package-name existing))
10.532+ status shadowing)
10.533+ (if (or (eq status :inherited) shadowing)
10.534+ (shadowing-import* symbol to-package)
10.535+ (unintern existing to-package))
10.536+ t)))))
10.537+ (when (and accessible (eq status :external))
10.538+ (ensure-exported name symbol to-package recycle))))))
10.539+ (defun ensure-exported (name symbol from-package &optional recycle)
10.540+ (dolist (to-package (package-used-by-list from-package))
10.541+ (ensure-exported-to-user name symbol to-package recycle))
10.542+ (unless (eq from-package (symbol-package symbol))
10.543+ (ensure-imported symbol from-package))
10.544+ (export* name from-package))
10.545+ (defun ensure-export (name from-package &optional recycle)
10.546+ (multiple-value-bind (symbol status) (find-symbol* name from-package)
10.547+ (unless (eq status :external)
10.548+ (ensure-exported name symbol from-package recycle))))
10.549+
10.550+ (defun ensure-package (name &key
10.551+ nicknames documentation use
10.552+ shadow shadowing-import-from
10.553+ import-from export intern
10.554+ recycle mix reexport
10.555+ unintern)
10.556+ #+genera (declare (ignore documentation))
10.557+ (let* ((package-name (string name))
10.558+ (nicknames (mapcar #'string nicknames))
10.559+ (names (cons package-name nicknames))
10.560+ (previous (packages-from-names names))
10.561+ (discarded (cdr previous))
10.562+ (to-delete ())
10.563+ (package (or (first previous) (make-package package-name :nicknames nicknames)))
10.564+ (recycle (packages-from-names recycle))
10.565+ (use (mapcar 'find-package* use))
10.566+ (mix (mapcar 'find-package* mix))
10.567+ (reexport (mapcar 'find-package* reexport))
10.568+ (shadow (mapcar 'string shadow))
10.569+ (export (mapcar 'string export))
10.570+ (intern (mapcar 'string intern))
10.571+ (unintern (mapcar 'string unintern))
10.572+ (shadowed (make-hash-table :test 'equal)) ; string to bool
10.573+ (imported (make-hash-table :test 'equal)) ; string to bool
10.574+ (exported (make-hash-table :test 'equal)) ; string to bool
10.575+ ;; string to list home package and use package:
10.576+ (inherited (make-hash-table :test 'equal)))
10.577+ (when-package-fishiness (record-fishy package-name))
10.578+ #-genera
10.579+ (when documentation (setf (documentation package t) documentation))
10.580+ (loop :for p :in (set-difference (package-use-list package) (append mix use))
10.581+ :do (note-package-fishiness :over-use name (package-names p))
10.582+ (unuse-package p package))
10.583+ (loop :for p :in discarded
10.584+ :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
10.585+ (package-names p))
10.586+ :do (note-package-fishiness :nickname name (package-names p))
10.587+ (cond (n (rename-package p (first n) (rest n)))
10.588+ (t (rename-package-away p)
10.589+ (push p to-delete))))
10.590+ (rename-package package package-name nicknames)
10.591+ (dolist (name unintern)
10.592+ (multiple-value-bind (existing status) (find-symbol name package)
10.593+ (when status
10.594+ (unless (eq status :inherited)
10.595+ (note-package-fishiness
10.596+ :unintern (package-name package) name (symbol-package-name existing) status)
10.597+ (unintern* name package nil)))))
10.598+ (dolist (name export)
10.599+ (setf (gethash name exported) t))
10.600+ (dolist (p reexport)
10.601+ (do-external-symbols (sym p)
10.602+ (setf (gethash (string sym) exported) t)))
10.603+ (do-external-symbols (sym package)
10.604+ (let ((name (symbol-name sym)))
10.605+ (unless (gethash name exported)
10.606+ (note-package-fishiness
10.607+ :over-export (package-name package) name
10.608+ (or (home-package-p sym package) (symbol-package-name sym)))
10.609+ (unexport sym package))))
10.610+ (dolist (name shadow)
10.611+ (setf (gethash name shadowed) t)
10.612+ (multiple-value-bind (existing status) (find-symbol name package)
10.613+ (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
10.614+ (let ((shadowing (and status (symbol-shadowing-p existing package))))
10.615+ (cond
10.616+ ((eq previous package))
10.617+ (previous
10.618+ (rehome-symbol recycled package))
10.619+ ((or (member status '(nil :inherited))
10.620+ (home-package-p existing package)))
10.621+ (t
10.622+ (let ((dummy (make-symbol name)))
10.623+ (note-package-fishiness
10.624+ :shadow-imported (package-name package) name
10.625+ (symbol-package-name existing) status shadowing)
10.626+ (shadowing-import* dummy package)
10.627+ (import* dummy package)))))))
10.628+ (shadow* name package))
10.629+ (loop :for (p . syms) :in shadowing-import-from
10.630+ :for pp = (find-package* p) :do
10.631+ (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
10.632+ (loop :for p :in mix
10.633+ :for pp = (find-package* p) :do
10.634+ (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited)))
10.635+ (loop :for (p . syms) :in import-from
10.636+ :for pp = (find-package p) :do
10.637+ (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
10.638+ (dolist (p (append use mix))
10.639+ (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
10.640+ (use-package p package))
10.641+ (loop :for name :being :the :hash-keys :of exported :do
10.642+ (ensure-symbol name package t recycle shadowed imported inherited exported)
10.643+ (ensure-export name package recycle))
10.644+ (dolist (name intern)
10.645+ (ensure-symbol name package t recycle shadowed imported inherited exported))
10.646+ (do-symbols (sym package)
10.647+ (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
10.648+ (map () 'delete-package* to-delete)
10.649+ package)))
10.650+
10.651+(eval-when (:load-toplevel :compile-toplevel :execute)
10.652+ (defun parse-defpkg-form (package clauses)
10.653+ (loop
10.654+ :with use-p = nil :with recycle-p = nil
10.655+ :with documentation = nil
10.656+ :for (kw . args) :in clauses
10.657+ :when (eq kw :nicknames) :append args :into nicknames :else
10.658+ :when (eq kw :documentation)
10.659+ :do (cond
10.660+ (documentation (error "defpkg: can't define documentation twice"))
10.661+ ((or (atom args) (cdr args)) (error "defpkg: bad documentation"))
10.662+ (t (setf documentation (car args)))) :else
10.663+ :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
10.664+ :when (eq kw :shadow) :append args :into shadow :else
10.665+ :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
10.666+ :when (eq kw :import-from) :collect args :into import-from :else
10.667+ :when (eq kw :export) :append args :into export :else
10.668+ :when (eq kw :intern) :append args :into intern :else
10.669+ :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
10.670+ :when (eq kw :mix) :append args :into mix :else
10.671+ :when (eq kw :reexport) :append args :into reexport :else
10.672+ :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport
10.673+ :and :do (setf use-p t) :else
10.674+ :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport
10.675+ :and :do (setf use-p t) :else
10.676+ :when (eq kw :unintern) :append args :into unintern :else
10.677+ :do (error "unrecognized defpkg keyword ~S" kw)
10.678+ :finally (return `(,package
10.679+ :nicknames ,nicknames :documentation ,documentation
10.680+ :use ,(if use-p use '(:common-lisp))
10.681+ :shadow ,shadow :shadowing-import-from ,shadowing-import-from
10.682+ :import-from ,import-from :export ,export :intern ,intern
10.683+ :recycle ,(if recycle-p recycle (cons package nicknames))
10.684+ :mix ,mix :reexport ,reexport :unintern ,unintern)))))
10.685+
10.686+(defmacro defpkg (package &rest clauses)
10.687+ "Richard's Robust DEFPACKAGE macro. Based on UIOP:DEFINE-PACKAGE. ymmv.
10.688+
10.689+DEFPKG takes a PACKAGE and a number of CLAUSES, of the form (KEYWORD . ARGS).
10.690+
10.691+DEFPKG supports the following keywords:
10.692+USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN -- as per CL:DEFPACKAGE.
10.693+
10.694+DEFPKG also redefines the following extensions:
10.695+RECYCLE, MIX, REEXPORT, UNINTERN -- as per UIOP/PACKAGE:DEFINE-PACKAGE
10.696+
10.697+REEXPORT -- Takes a list of package designators. For each package in
10.698+the list, export symbols with the same name as those exported from
10.699+that package. In the case of shadowing, etc. They may not be EQL."
10.700+ (let ((ensure-form
10.701+ `(apply 'ensure-package ',(parse-defpkg-form package clauses))))
10.702+ `(progn
10.703+ #+(or clasp ecl gcl mkcl) (defpackage ,package (:use))
10.704+ (eval-when (:compile-toplevel :load-toplevel :execute)
10.705+ ,ensure-form))))
11.1--- a/lisp/std/util.lisp Sun Mar 03 20:50:37 2024 -0500
11.2+++ b/lisp/std/util.lisp Thu Mar 07 23:06:25 2024 -0500
11.3@@ -184,706 +184,6 @@
11.4 (setf p (ash p -1)))
11.5 (nreverse network)))
11.6
11.7-(eval-when (:load-toplevel :compile-toplevel :execute)
11.8- (defun find-package* (package-designator &optional (error t))
11.9- (let ((package (find-package package-designator)))
11.10- (cond
11.11- (package package)
11.12- (error (error "No package named ~S" (string package-designator)))
11.13- (t nil))))
11.14- (defun find-symbol* (name package-designator &optional (error t))
11.15- "Find a symbol in a package of given string'ified NAME;
11.16-unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
11.17-by letting you supply a symbol or keyword for the name;
11.18-also works well when the package is not present.
11.19-If optional ERROR argument is NIL, return NIL instead of an error
11.20-when the symbol is not found."
11.21- (block nil
11.22- (let ((package (find-package* package-designator error)))
11.23- (when package ;; package error handled by find-package* already
11.24- (multiple-value-bind (symbol status) (find-symbol (string name) package)
11.25- (cond
11.26- (status (return (values symbol status)))
11.27- (error (error "There is no symbol ~S in package ~S" name (package-name package))))))
11.28- (values nil nil))))
11.29- (defun symbol-call (package name &rest args)
11.30- "Call a function associated with symbol of given name in given package,
11.31-with given ARGS. Useful when the call is read before the package is loaded,
11.32-or when loading the package is optional."
11.33- (apply (find-symbol* name package) args))
11.34- (defun intern* (name package-designator &optional (error t))
11.35- (intern (string name) (find-package* package-designator error)))
11.36- (defun export* (name package-designator)
11.37- (let* ((package (find-package* package-designator))
11.38- (symbol (intern* name package)))
11.39- (export (or symbol (list symbol)) package)))
11.40- (defun import* (symbol package-designator)
11.41- (import (or symbol (list symbol)) (find-package* package-designator)))
11.42- (defun shadowing-import* (symbol package-designator)
11.43- (shadowing-import (or symbol (list symbol)) (find-package* package-designator)))
11.44- (defun shadow* (name package-designator)
11.45- (shadow (list (string name)) (find-package* package-designator)))
11.46- (defun make-symbol* (name)
11.47- (etypecase name
11.48- (string (make-symbol name))
11.49- (symbol (copy-symbol name))))
11.50- (defun unintern* (name package-designator &optional (error t))
11.51- (block nil
11.52- (let ((package (find-package* package-designator error)))
11.53- (when package
11.54- (multiple-value-bind (symbol status) (find-symbol* name package error)
11.55- (cond
11.56- (status (unintern symbol package)
11.57- (return (values symbol status)))
11.58- (error (error "symbol ~A not present in package ~A"
11.59- (string symbol) (package-name package))))))
11.60- (values nil nil))))
11.61- (defun symbol-shadowing-p (symbol package)
11.62- (and (member symbol (package-shadowing-symbols package)) t))
11.63- (defun home-package-p (symbol package)
11.64- (and package (let ((sp (symbol-package symbol)))
11.65- (and sp (let ((pp (find-package* package)))
11.66- (and pp (eq sp pp))))))))
11.67-
11.68-
11.69-(eval-when (:load-toplevel :compile-toplevel :execute)
11.70- (defun symbol-package-name (symbol)
11.71- (let ((package (symbol-package symbol)))
11.72- (and package (package-name package))))
11.73- (defun standard-common-lisp-symbol-p (symbol)
11.74- (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
11.75- (and (eq sym symbol) (eq status :external))))
11.76- (defun reify-package (package &optional package-context)
11.77- (if (eq package package-context) t
11.78- (etypecase package
11.79- (null nil)
11.80- ((eql (find-package :cl)) :cl)
11.81- (package (package-name package)))))
11.82- (defun unreify-package (package &optional package-context)
11.83- (etypecase package
11.84- (null nil)
11.85- ((eql t) package-context)
11.86- ((or symbol string) (find-package package))))
11.87- (defun reify-symbol (symbol &optional package-context)
11.88- (etypecase symbol
11.89- ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
11.90- (symbol (vector (symbol-name symbol)
11.91- (reify-package (symbol-package symbol) package-context)))))
11.92- (defun unreify-symbol (symbol &optional package-context)
11.93- (etypecase symbol
11.94- (symbol symbol)
11.95- ((simple-vector 2)
11.96- (let* ((symbol-name (svref symbol 0))
11.97- (package-foo (svref symbol 1))
11.98- (package (unreify-package package-foo package-context)))
11.99- (if package (intern* symbol-name package)
11.100- (make-symbol* symbol-name)))))))
11.101-
11.102-(eval-when (:load-toplevel :compile-toplevel :execute)
11.103- (defvar *all-package-happiness* '())
11.104- (defvar *all-package-fishiness* (list t))
11.105- (defun record-fishy (info)
11.106- ;;(format t "~&FISHY: ~S~%" info)
11.107- (push info *all-package-fishiness*))
11.108- (defmacro when-package-fishiness (&body body)
11.109- `(when *all-package-fishiness* ,@body))
11.110- (defmacro note-package-fishiness (&rest info)
11.111- `(when-package-fishiness (record-fishy (list ,@info)))))
11.112-
11.113-(eval-when (:load-toplevel :compile-toplevel :execute)
11.114- #+(or clisp clozure)
11.115- (defun get-setf-function-symbol (symbol)
11.116- #+clisp (let ((sym (get symbol 'system::setf-function)))
11.117- (if sym (values sym :setf-function)
11.118- (let ((sym (get symbol 'system::setf-expander)))
11.119- (if sym (values sym :setf-expander)
11.120- (values nil nil)))))
11.121- #+clozure (gethash symbol ccl::%setf-function-names%))
11.122- #+(or clisp clozure)
11.123- (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
11.124- #+clisp (assert (member kind '(:setf-function :setf-expander)))
11.125- #+clozure (assert (eq kind t))
11.126- #+clisp
11.127- (cond
11.128- ((null new-setf-symbol)
11.129- (remprop symbol 'system::setf-function)
11.130- (remprop symbol 'system::setf-expander))
11.131- ((eq kind :setf-function)
11.132- (setf (get symbol 'system::setf-function) new-setf-symbol))
11.133- ((eq kind :setf-expander)
11.134- (setf (get symbol 'system::setf-expander) new-setf-symbol))
11.135- (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
11.136- kind symbol new-setf-symbol)))
11.137- #+clozure
11.138- (progn
11.139- (gethash symbol ccl::%setf-function-names%) new-setf-symbol
11.140- (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
11.141- #+(or clisp clozure)
11.142- (defun create-setf-function-symbol (symbol)
11.143- #+clisp (system::setf-symbol symbol)
11.144- #+clozure (ccl::construct-setf-function-name symbol))
11.145- (defun set-dummy-symbol (symbol reason other-symbol)
11.146- (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
11.147- (defun make-dummy-symbol (symbol)
11.148- (let ((dummy (copy-symbol symbol)))
11.149- (set-dummy-symbol dummy 'replacing symbol)
11.150- (set-dummy-symbol symbol 'replaced-by dummy)
11.151- dummy))
11.152- (defun dummy-symbol (symbol)
11.153- (get symbol 'dummy-symbol))
11.154- (defun get-dummy-symbol (symbol)
11.155- (let ((existing (dummy-symbol symbol)))
11.156- (if existing (values (cdr existing) (car existing))
11.157- (make-dummy-symbol symbol))))
11.158- (defun nuke-symbol-in-package (symbol package-designator)
11.159- (let ((package (find-package* package-designator))
11.160- (name (symbol-name symbol)))
11.161- (multiple-value-bind (sym stat) (find-symbol name package)
11.162- (when (and (member stat '(:internal :external)) (eq symbol sym))
11.163- (if (symbol-shadowing-p symbol package)
11.164- (shadowing-import* (get-dummy-symbol symbol) package)
11.165- (unintern* symbol package))))))
11.166- (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
11.167- #+(or clisp clozure)
11.168- (multiple-value-bind (setf-symbol kind)
11.169- (get-setf-function-symbol symbol)
11.170- (when kind (nuke-symbol setf-symbol)))
11.171- (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
11.172- (defun rehome-symbol (symbol package-designator)
11.173- "Changes the home package of a symbol, also leaving it present in its old home if any"
11.174- (let* ((name (symbol-name symbol))
11.175- (package (find-package* package-designator))
11.176- (old-package (symbol-package symbol))
11.177- (old-status (and old-package (nth-value 1 (find-symbol name old-package))))
11.178- (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
11.179- (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
11.180- (unless (eq package old-package)
11.181- (let ((overwritten-symbol-shadowing-p
11.182- (and overwritten-symbol-status
11.183- (symbol-shadowing-p overwritten-symbol package))))
11.184- (note-package-fishiness
11.185- :rehome-symbol name
11.186- (when old-package (package-name old-package)) old-status (and shadowing t)
11.187- (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
11.188- (when old-package
11.189- (if shadowing
11.190- (shadowing-import* shadowing old-package))
11.191- (unintern* symbol old-package))
11.192- (cond
11.193- (overwritten-symbol-shadowing-p
11.194- (shadowing-import* symbol package))
11.195- (t
11.196- (when overwritten-symbol-status
11.197- (unintern* overwritten-symbol package))
11.198- (import* symbol package)))
11.199- (if shadowing
11.200- (shadowing-import* symbol old-package)
11.201- (import* symbol old-package))
11.202- #+(or clisp clozure)
11.203- (multiple-value-bind (setf-symbol kind)
11.204- (get-setf-function-symbol symbol)
11.205- (when kind
11.206- (let* ((setf-function (fdefinition setf-symbol))
11.207- (new-setf-symbol (create-setf-function-symbol symbol)))
11.208- (note-package-fishiness
11.209- :setf-function
11.210- name (package-name package)
11.211- (symbol-name setf-symbol) (symbol-package-name setf-symbol)
11.212- (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
11.213- (when (symbol-package setf-symbol)
11.214- (unintern* setf-symbol (symbol-package setf-symbol)))
11.215- (setf (fdefinition new-setf-symbol) setf-function)
11.216- (set-setf-function-symbol new-setf-symbol symbol kind))))
11.217- #+(or clisp clozure)
11.218- (multiple-value-bind (overwritten-setf foundp)
11.219- (get-setf-function-symbol overwritten-symbol)
11.220- (when foundp
11.221- (unintern overwritten-setf)))
11.222- (when (eq old-status :external)
11.223- (export* symbol old-package))
11.224- (when (eq overwritten-symbol-status :external)
11.225- (export* symbol package))))
11.226- (values overwritten-symbol overwritten-symbol-status))))
11.227- (defun ensure-package-unused (package)
11.228- (loop :for p :in (package-used-by-list package) :do
11.229- (unuse-package package p)))
11.230- (defun delete-package* (package &key nuke)
11.231- (let ((p (find-package package)))
11.232- (when p
11.233- (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
11.234- (ensure-package-unused p)
11.235- (delete-package package))))
11.236- (defun package-names (package)
11.237- (cons (package-name package) (package-nicknames package)))
11.238- (defun packages-from-names (names)
11.239- (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
11.240- (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
11.241- separator
11.242- (index (random most-positive-fixnum)))
11.243- (loop :for i :from index
11.244- :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
11.245- :thereis (and (not (find-package n)) n)))
11.246- (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
11.247- (let ((new-name
11.248- (apply 'fresh-package-name
11.249- :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
11.250- (record-fishy (list :rename-away (package-names p) new-name))
11.251- (rename-package p new-name))))
11.252-
11.253-
11.254-;;; Communicable representation of symbol and package information
11.255-
11.256-(eval-when (:load-toplevel :compile-toplevel :execute)
11.257- (defun package-definition-form (package-designator
11.258- &key (nicknamesp t) (usep t)
11.259- (shadowp t) (shadowing-import-p t)
11.260- (exportp t) (importp t) internp (error t))
11.261- (let* ((package (or (find-package* package-designator error)
11.262- (return-from package-definition-form nil)))
11.263- (name (package-name package))
11.264- (nicknames (package-nicknames package))
11.265- (use (mapcar #'package-name (package-use-list package)))
11.266- (shadow ())
11.267- (shadowing-import (make-hash-table :test 'equal))
11.268- (import (make-hash-table :test 'equal))
11.269- (export ())
11.270- (intern ()))
11.271- (when package
11.272- (loop :for sym :being :the :symbols :in package
11.273- :for status = (nth-value 1 (find-symbol* sym package)) :do
11.274- (ecase status
11.275- ((nil :inherited))
11.276- ((:internal :external)
11.277- (let* ((name (symbol-name sym))
11.278- (external (eq status :external))
11.279- (home (symbol-package sym))
11.280- (home-name (package-name home))
11.281- (imported (not (eq home package)))
11.282- (shadowing (symbol-shadowing-p sym package)))
11.283- (cond
11.284- ((and shadowing imported)
11.285- (push name (gethash home-name shadowing-import)))
11.286- (shadowing
11.287- (push name shadow))
11.288- (imported
11.289- (push name (gethash home-name import))))
11.290- (cond
11.291- (external
11.292- (push name export))
11.293- (imported)
11.294- (t (push name intern)))))))
11.295- (labels ((sort-names (names)
11.296- (sort (copy-list names) #'string<))
11.297- (table-keys (table)
11.298- (loop :for k :being :the :hash-keys :of table :collect k))
11.299- (when-relevant (key value)
11.300- (when value (list (cons key value))))
11.301- (import-options (key table)
11.302- (loop :for i :in (sort-names (table-keys table))
11.303- :collect `(,key ,i ,@(sort-names (gethash i table))))))
11.304- `(defpackage ,name
11.305- ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
11.306- (:use ,@(and usep (sort-names use)))
11.307- ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
11.308- ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
11.309- ,@(import-options :import-from (and importp import))
11.310- ,@(when-relevant :export (and exportp (sort-names export)))
11.311- ,@(when-relevant :intern (and internp (sort-names intern)))))))))
11.312-
11.313-(eval-when (:load-toplevel :compile-toplevel :execute)
11.314- (defun ensure-shadowing-import (name to-package from-package shadowed imported)
11.315- (check-type name string)
11.316- (check-type to-package package)
11.317- (check-type from-package package)
11.318- (check-type shadowed hash-table)
11.319- (check-type imported hash-table)
11.320- (let ((import-me (find-symbol* name from-package)))
11.321- (multiple-value-bind (existing status) (find-symbol name to-package)
11.322- (cond
11.323- ((gethash name shadowed)
11.324- (unless (eq import-me existing)
11.325- (error "Conflicting shadowings for ~A" name)))
11.326- (t
11.327- (setf (gethash name shadowed) t)
11.328- (setf (gethash name imported) t)
11.329- (unless (or (null status)
11.330- (and (member status '(:internal :external))
11.331- (eq existing import-me)
11.332- (symbol-shadowing-p existing to-package)))
11.333- (note-package-fishiness
11.334- :shadowing-import name
11.335- (package-name from-package)
11.336- (or (home-package-p import-me from-package) (symbol-package-name import-me))
11.337- (package-name to-package) status
11.338- (and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
11.339- (shadowing-import* import-me to-package))))))
11.340- (defun ensure-imported (import-me into-package &optional from-package)
11.341- (check-type import-me symbol)
11.342- (check-type into-package package)
11.343- (check-type from-package (or null package))
11.344- (let ((name (symbol-name import-me)))
11.345- (multiple-value-bind (existing status) (find-symbol name into-package)
11.346- (cond
11.347- ((not status)
11.348- (import* import-me into-package))
11.349- ((eq import-me existing))
11.350- (t
11.351- (let ((shadowing-p (symbol-shadowing-p existing into-package)))
11.352- (note-package-fishiness
11.353- :ensure-imported name
11.354- (and from-package (package-name from-package))
11.355- (or (home-package-p import-me from-package) (symbol-package-name import-me))
11.356- (package-name into-package)
11.357- status
11.358- (and status (or (home-package-p existing into-package) (symbol-package-name existing)))
11.359- shadowing-p)
11.360- (cond
11.361- ((or shadowing-p (eq status :inherited))
11.362- (shadowing-import* import-me into-package))
11.363- (t
11.364- (unintern* existing into-package)
11.365- (import* import-me into-package))))))))
11.366- (values))
11.367- (defun ensure-import (name to-package from-package shadowed imported)
11.368- (check-type name string)
11.369- (check-type to-package package)
11.370- (check-type from-package package)
11.371- (check-type shadowed hash-table)
11.372- (check-type imported hash-table)
11.373- (multiple-value-bind (import-me import-status) (find-symbol name from-package)
11.374- (when (null import-status)
11.375- (note-package-fishiness
11.376- :import-uninterned name (package-name from-package) (package-name to-package))
11.377- (setf import-me (intern* name from-package)))
11.378- (multiple-value-bind (existing status) (find-symbol name to-package)
11.379- (cond
11.380- ((and imported (gethash name imported))
11.381- (unless (and status (eq import-me existing))
11.382- (error "Can't import ~S from both ~S and ~S"
11.383- name (package-name (symbol-package existing)) (package-name from-package))))
11.384- ((gethash name shadowed)
11.385- (error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
11.386- (t
11.387- (setf (gethash name imported) t))))
11.388- (ensure-imported import-me to-package from-package)))
11.389- (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
11.390- (check-type name string)
11.391- (check-type symbol symbol)
11.392- (check-type to-package package)
11.393- (check-type from-package package)
11.394- (check-type mixp (member nil t)) ; no cl:boolean on Genera
11.395- (check-type shadowed hash-table)
11.396- (check-type imported hash-table)
11.397- (check-type inherited hash-table)
11.398- (multiple-value-bind (existing status) (find-symbol name to-package)
11.399- (let* ((sp (symbol-package symbol))
11.400- (in (gethash name inherited))
11.401- (xp (and status (symbol-package existing))))
11.402- (when (null sp)
11.403- (note-package-fishiness
11.404- :import-uninterned name
11.405- (package-name from-package) (package-name to-package) mixp)
11.406- (import* symbol from-package)
11.407- (setf sp (package-name from-package)))
11.408- (cond
11.409- ((gethash name shadowed))
11.410- (in
11.411- (unless (equal sp (first in))
11.412- (if mixp
11.413- (ensure-shadowing-import name to-package (second in) shadowed imported)
11.414- (error "Can't inherit ~S from ~S, it is inherited from ~S"
11.415- name (package-name sp) (package-name (first in))))))
11.416- ((gethash name imported)
11.417- (unless (eq symbol existing)
11.418- (error "Can't inherit ~S from ~S, it is imported from ~S"
11.419- name (package-name sp) (package-name xp))))
11.420- (t
11.421- (setf (gethash name inherited) (list sp from-package))
11.422- (when (and status (not (eq sp xp)))
11.423- (let ((shadowing (symbol-shadowing-p existing to-package)))
11.424- (note-package-fishiness
11.425- :inherited name
11.426- (package-name from-package)
11.427- (or (home-package-p symbol from-package) (symbol-package-name symbol))
11.428- (package-name to-package)
11.429- (or (home-package-p existing to-package) (symbol-package-name existing)))
11.430- (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported)
11.431- (unintern* existing to-package)))))))))
11.432- (defun ensure-mix (name symbol to-package from-package shadowed imported inherited)
11.433- (check-type name string)
11.434- (check-type symbol symbol)
11.435- (check-type to-package package)
11.436- (check-type from-package package)
11.437- (check-type shadowed hash-table)
11.438- (check-type imported hash-table)
11.439- (check-type inherited hash-table)
11.440- (unless (gethash name shadowed)
11.441- (multiple-value-bind (existing status) (find-symbol name to-package)
11.442- (let* ((sp (symbol-package symbol))
11.443- (im (gethash name imported))
11.444- (in (gethash name inherited)))
11.445- (cond
11.446- ((or (null status)
11.447- (and status (eq symbol existing))
11.448- (and in (eq sp (first in))))
11.449- (ensure-inherited name symbol to-package from-package t shadowed imported inherited))
11.450- (in
11.451- (remhash name inherited)
11.452- (ensure-shadowing-import name to-package (second in) shadowed imported))
11.453- (im
11.454- (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]"
11.455- name (package-name from-package)
11.456- (home-package-p symbol from-package) (symbol-package-name symbol)
11.457- (package-name to-package)
11.458- (home-package-p existing to-package) (symbol-package-name existing)))
11.459- (t
11.460- (ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
11.461-
11.462- (defun recycle-symbol (name recycle exported)
11.463- ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE
11.464- ;; packages, and a hash-table of names (strings) of symbols scheduled to be
11.465- ;; EXPORTED from the package being defined. It returns two values, the
11.466- ;; symbol found (if any, or else NIL), and a boolean flag indicating whether
11.467- ;; a symbol was found. The caller (DEFPKG) will then do the
11.468- ;; re-homing of the symbol, etc.
11.469- (check-type name string)
11.470- (check-type recycle list)
11.471- (check-type exported hash-table)
11.472- (when (gethash name exported) ;; don't bother recycling private symbols
11.473- (let (recycled foundp)
11.474- (dolist (r recycle (values recycled foundp))
11.475- (multiple-value-bind (symbol status) (find-symbol name r)
11.476- (when (and status (home-package-p symbol r))
11.477- (cond
11.478- (foundp
11.479- ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
11.480- (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r)))
11.481- (t
11.482- (setf recycled symbol foundp r)))))))))
11.483- (defun symbol-recycled-p (sym recycle)
11.484- (check-type sym symbol)
11.485- (check-type recycle list)
11.486- (and (member (symbol-package sym) recycle) t))
11.487- (defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
11.488- (check-type name string)
11.489- (check-type package package)
11.490- (check-type intern (member nil t)) ; no cl:boolean on Genera
11.491- (check-type shadowed hash-table)
11.492- (check-type imported hash-table)
11.493- (check-type inherited hash-table)
11.494- (unless (or (gethash name shadowed)
11.495- (gethash name imported)
11.496- (gethash name inherited))
11.497- (multiple-value-bind (existing status)
11.498- (find-symbol name package)
11.499- (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
11.500- (cond
11.501- ((and status (eq existing recycled) (eq previous package)))
11.502- (previous
11.503- (rehome-symbol recycled package))
11.504- ((and status (eq package (symbol-package existing))))
11.505- (t
11.506- (when status
11.507- (note-package-fishiness
11.508- :ensure-symbol name
11.509- (reify-package (symbol-package existing) package)
11.510- status intern)
11.511- (unintern existing))
11.512- (when intern
11.513- (intern* name package))))))))
11.514- (declaim (ftype (function (t t t &optional t) t) ensure-exported))
11.515- (defun ensure-exported-to-user (name symbol to-package &optional recycle)
11.516- (check-type name string)
11.517- (check-type symbol symbol)
11.518- (check-type to-package package)
11.519- (check-type recycle list)
11.520- (assert (equal name (symbol-name symbol)))
11.521- (multiple-value-bind (existing status) (find-symbol name to-package)
11.522- (unless (and status (eq symbol existing))
11.523- (let ((accessible
11.524- (or (null status)
11.525- (let ((shadowing (symbol-shadowing-p existing to-package))
11.526- (recycled (symbol-recycled-p existing recycle)))
11.527- (unless (and shadowing (not recycled))
11.528- (note-package-fishiness
11.529- :ensure-export name (symbol-package-name symbol)
11.530- (package-name to-package)
11.531- (or (home-package-p existing to-package) (symbol-package-name existing))
11.532- status shadowing)
11.533- (if (or (eq status :inherited) shadowing)
11.534- (shadowing-import* symbol to-package)
11.535- (unintern existing to-package))
11.536- t)))))
11.537- (when (and accessible (eq status :external))
11.538- (ensure-exported name symbol to-package recycle))))))
11.539- (defun ensure-exported (name symbol from-package &optional recycle)
11.540- (dolist (to-package (package-used-by-list from-package))
11.541- (ensure-exported-to-user name symbol to-package recycle))
11.542- (unless (eq from-package (symbol-package symbol))
11.543- (ensure-imported symbol from-package))
11.544- (export* name from-package))
11.545- (defun ensure-export (name from-package &optional recycle)
11.546- (multiple-value-bind (symbol status) (find-symbol* name from-package)
11.547- (unless (eq status :external)
11.548- (ensure-exported name symbol from-package recycle))))
11.549-
11.550- (defun ensure-package (name &key
11.551- nicknames documentation use
11.552- shadow shadowing-import-from
11.553- import-from export intern
11.554- recycle mix reexport
11.555- unintern)
11.556- #+genera (declare (ignore documentation))
11.557- (let* ((package-name (string name))
11.558- (nicknames (mapcar #'string nicknames))
11.559- (names (cons package-name nicknames))
11.560- (previous (packages-from-names names))
11.561- (discarded (cdr previous))
11.562- (to-delete ())
11.563- (package (or (first previous) (make-package package-name :nicknames nicknames)))
11.564- (recycle (packages-from-names recycle))
11.565- (use (mapcar 'find-package* use))
11.566- (mix (mapcar 'find-package* mix))
11.567- (reexport (mapcar 'find-package* reexport))
11.568- (shadow (mapcar 'string shadow))
11.569- (export (mapcar 'string export))
11.570- (intern (mapcar 'string intern))
11.571- (unintern (mapcar 'string unintern))
11.572- (shadowed (make-hash-table :test 'equal)) ; string to bool
11.573- (imported (make-hash-table :test 'equal)) ; string to bool
11.574- (exported (make-hash-table :test 'equal)) ; string to bool
11.575- ;; string to list home package and use package:
11.576- (inherited (make-hash-table :test 'equal)))
11.577- (when-package-fishiness (record-fishy package-name))
11.578- #-genera
11.579- (when documentation (setf (documentation package t) documentation))
11.580- (loop :for p :in (set-difference (package-use-list package) (append mix use))
11.581- :do (note-package-fishiness :over-use name (package-names p))
11.582- (unuse-package p package))
11.583- (loop :for p :in discarded
11.584- :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
11.585- (package-names p))
11.586- :do (note-package-fishiness :nickname name (package-names p))
11.587- (cond (n (rename-package p (first n) (rest n)))
11.588- (t (rename-package-away p)
11.589- (push p to-delete))))
11.590- (rename-package package package-name nicknames)
11.591- (dolist (name unintern)
11.592- (multiple-value-bind (existing status) (find-symbol name package)
11.593- (when status
11.594- (unless (eq status :inherited)
11.595- (note-package-fishiness
11.596- :unintern (package-name package) name (symbol-package-name existing) status)
11.597- (unintern* name package nil)))))
11.598- (dolist (name export)
11.599- (setf (gethash name exported) t))
11.600- (dolist (p reexport)
11.601- (do-external-symbols (sym p)
11.602- (setf (gethash (string sym) exported) t)))
11.603- (do-external-symbols (sym package)
11.604- (let ((name (symbol-name sym)))
11.605- (unless (gethash name exported)
11.606- (note-package-fishiness
11.607- :over-export (package-name package) name
11.608- (or (home-package-p sym package) (symbol-package-name sym)))
11.609- (unexport sym package))))
11.610- (dolist (name shadow)
11.611- (setf (gethash name shadowed) t)
11.612- (multiple-value-bind (existing status) (find-symbol name package)
11.613- (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
11.614- (let ((shadowing (and status (symbol-shadowing-p existing package))))
11.615- (cond
11.616- ((eq previous package))
11.617- (previous
11.618- (rehome-symbol recycled package))
11.619- ((or (member status '(nil :inherited))
11.620- (home-package-p existing package)))
11.621- (t
11.622- (let ((dummy (make-symbol name)))
11.623- (note-package-fishiness
11.624- :shadow-imported (package-name package) name
11.625- (symbol-package-name existing) status shadowing)
11.626- (shadowing-import* dummy package)
11.627- (import* dummy package)))))))
11.628- (shadow* name package))
11.629- (loop :for (p . syms) :in shadowing-import-from
11.630- :for pp = (find-package* p) :do
11.631- (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
11.632- (loop :for p :in mix
11.633- :for pp = (find-package* p) :do
11.634- (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited)))
11.635- (loop :for (p . syms) :in import-from
11.636- :for pp = (find-package p) :do
11.637- (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
11.638- (dolist (p (append use mix))
11.639- (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
11.640- (use-package p package))
11.641- (loop :for name :being :the :hash-keys :of exported :do
11.642- (ensure-symbol name package t recycle shadowed imported inherited exported)
11.643- (ensure-export name package recycle))
11.644- (dolist (name intern)
11.645- (ensure-symbol name package t recycle shadowed imported inherited exported))
11.646- (do-symbols (sym package)
11.647- (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
11.648- (map () 'delete-package* to-delete)
11.649- package)))
11.650-
11.651-(eval-when (:load-toplevel :compile-toplevel :execute)
11.652- (defun parse-defpkg-form (package clauses)
11.653- (loop
11.654- :with use-p = nil :with recycle-p = nil
11.655- :with documentation = nil
11.656- :for (kw . args) :in clauses
11.657- :when (eq kw :nicknames) :append args :into nicknames :else
11.658- :when (eq kw :documentation)
11.659- :do (cond
11.660- (documentation (error "defpkg: can't define documentation twice"))
11.661- ((or (atom args) (cdr args)) (error "defpkg: bad documentation"))
11.662- (t (setf documentation (car args)))) :else
11.663- :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
11.664- :when (eq kw :shadow) :append args :into shadow :else
11.665- :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
11.666- :when (eq kw :import-from) :collect args :into import-from :else
11.667- :when (eq kw :export) :append args :into export :else
11.668- :when (eq kw :intern) :append args :into intern :else
11.669- :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
11.670- :when (eq kw :mix) :append args :into mix :else
11.671- :when (eq kw :reexport) :append args :into reexport :else
11.672- :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport
11.673- :and :do (setf use-p t) :else
11.674- :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport
11.675- :and :do (setf use-p t) :else
11.676- :when (eq kw :unintern) :append args :into unintern :else
11.677- :do (error "unrecognized defpkg keyword ~S" kw)
11.678- :finally (return `(,package
11.679- :nicknames ,nicknames :documentation ,documentation
11.680- :use ,(if use-p use '(:common-lisp))
11.681- :shadow ,shadow :shadowing-import-from ,shadowing-import-from
11.682- :import-from ,import-from :export ,export :intern ,intern
11.683- :recycle ,(if recycle-p recycle (cons package nicknames))
11.684- :mix ,mix :reexport ,reexport :unintern ,unintern)))))
11.685-
11.686-(defmacro defpkg (package &rest clauses)
11.687- "Richard's Robust DEFPACKAGE macro. Based on UIOP:DEFINE-PACKAGE. ymmv.
11.688-
11.689-DEFPKG takes a PACKAGE and a number of CLAUSES, of the form (KEYWORD . ARGS).
11.690-
11.691-DEFPKG supports the following keywords:
11.692-USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN -- as per CL:DEFPACKAGE.
11.693-
11.694-DEFPKG also redefines the following extensions:
11.695-RECYCLE, MIX, REEXPORT, UNINTERN -- as per UIOP/PACKAGE:DEFINE-PACKAGE
11.696-
11.697-REEXPORT -- Takes a list of package designators. For each package in
11.698-the list, export symbols with the same name as those exported from
11.699-that package. In the case of shadowing, etc. They may not be EQL."
11.700- (let ((ensure-form
11.701- `(apply 'ensure-package ',(parse-defpkg-form package clauses))))
11.702- `(progn
11.703- #+(or clasp ecl gcl mkcl) (defpackage ,package (:use))
11.704- (eval-when (:compile-toplevel :load-toplevel :execute)
11.705- ,ensure-form))))
11.706-
11.707 ;; TODO
11.708 (defun save-lisp-and-live (filename completion-function restart &rest args)
11.709 (flet ((restart-sbcl ()
12.1Binary file std has changed
