(in-package :ccl)

(setf *warn-if-redefine-kernel* nil)

;;; nfasload.lisp

(defun pkg-arg (thing &optional deleted-ok errorp)
  (let* ((xthing (cond ((or (symbolp thing) (typep thing 'character))
                        (string thing))
                       ((typep thing 'string)
                        (ensure-simple-string thing))
                       (t
                        thing))))
    (let* ((typecode (typecode xthing)))
      (declare (fixnum typecode))
      (cond ((= typecode target::subtag-package)
             (if (or deleted-ok (pkg.names xthing))
               xthing
               (error "~S is a deleted package ." thing)))
            ((= typecode target::subtag-simple-base-string)
             (let ((local-nicknames (package-%local-nicknames *package*)))
               (cond ((and local-nicknames
                           (cdr (assoc xthing local-nicknames :test #'string=))))
                     ((%find-pkg xthing))
                     (errorp (%kernel-restart $xnopkg xthing)))))
            (t (report-bad-arg thing 'simple-string))))))

;;; We use a pair of hash-tables for storing local nickname information.
;;; We use it in order to avoid modifying the package objects themselves.
;;; We use a lock to synchronize access to the local nickname system; using
;;; shared hash tables is not enough as the lists that are the values of the
;;; hash tables may be modified by different threads at the same time.
(defvar *package-local-nicknames-lock* (make-lock))
(defvar *package-local-nicknames* (make-hash-table :test #'eq :weak t))
(defvar *package-locally-nicknamed-by* (make-hash-table :test #'eq :weak t))

(defun package-%local-nicknames (package)
  (with-lock-grabbed (*package-local-nicknames-lock*)
    (values (gethash package *package-local-nicknames*))))
(defun (setf package-%local-nicknames) (newval package)
  (with-lock-grabbed (*package-local-nicknames-lock*)
    (setf (gethash package *package-local-nicknames*) newval)))

(defun package-%locally-nicknamed-by (package)
  (with-lock-grabbed (*package-local-nicknames-lock*)
    (values (gethash package *package-locally-nicknamed-by*))))
(defun (setf package-%locally-nicknamed-by) (newval package)
  (with-lock-grabbed (*package-local-nicknames-lock*)
    (setf (gethash package *package-locally-nicknamed-by*) newval)))


;;; macros.lisp

(defun %defpackage-all-names-hash (options)
  (let ((all-options-alist nil)
        (all-names-size 0)
        (intern-export-size 0)
        (shadow-etc-size 0))
    (declare (fixnum all-names-size intern-export-size shadow-etc-size))
    (dolist (option options)
      (let ((option-name (car option)))
        (when (memq option-name
                    '(:nicknames :shadow :shadowing-import-from
                      :use :import-from :intern :export))
          (let ((option-size (length (cdr option)))
                (cell (assq option-name all-options-alist)))
            (declare (fixnum option-size))
            (if cell
              (incf (cdr cell) option-size)
              (push (cons option-name option-size) all-options-alist))
            (when (memq option-name '(:shadow :shadowing-import-from :import-from :intern))
              (incf shadow-etc-size option-size))
            (when (memq option-name '(:export :intern))
              (incf intern-export-size option-size))))))
    (dolist (cell all-options-alist)
      (let ((option-size (cdr cell)))
        (when (> option-size all-names-size)
          (setq all-names-size option-size))))
    (values
     (when (> all-names-size 0)
       (make-hash-table :test 'equal :size all-names-size))
     intern-export-size shadow-etc-size)))

(defun %defpackage (name &rest options)
  (multiple-value-bind (all-names-hash intern-export-size shadow-etc-size)
      (%defpackage-all-names-hash options)
    (declare (fixnum intern-export-size shadow-etc-size))
    (let* ((intern-export-hash (when (> intern-export-size 0)
                                 (make-hash-table :test 'equal :size intern-export-size)))
           (shadow-etc-hash (when (> shadow-etc-size 0)
                              (make-hash-table :test 'equal :size shadow-etc-size)))
           (size nil)
           (documentation nil)
           (external-size nil)
           (nicknames nil)
           (local-nicknames nil)
           (shadow nil)
           (shadowing-import-from-specs nil)
           (use :default)
           (import-from-specs nil)
           (intern nil)
           (export nil))
      (labels ((string-or-name (s) (string s))
               (duplicate-option (o)
                 (signal-program-error "Duplicate ~S option in ~S ." o options))
               (duplicate-name (name option-name)
                 (signal-program-error "Name ~s, used in ~s option, is already used in a conflicting option ." name option-name))
               (all-names (option-name tail already)
                 (when (eq already :default) (setq already nil))
                 (when all-names-hash
                   (clrhash all-names-hash))
                 (dolist (name already)
                   (setf (gethash (string-or-name name) all-names-hash) t))
                 (dolist (name tail already)
                   (setq name (string-or-name name))
                   (unless (gethash name all-names-hash)          ; Ok to repeat name in same option.
                     (when (memq option-name '(:shadow :shadowing-import-from :import-from :intern))
                       (if (gethash name shadow-etc-hash)
                         (duplicate-name name option-name))
                       (setf (gethash name shadow-etc-hash) t))
                     (when (memq option-name '(:export :intern))
                       (if (gethash name intern-export-hash)
                         (duplicate-name name option-name))
                       (setf (gethash name intern-export-hash) t))
                     (setf (gethash name all-names-hash) t)
                     (push name already)))))
        (dolist (option options)
          (let ((args (cdr option)))
            (ecase (%car option)
              (:size
               (if size
                 (duplicate-option :size)
                 (setq size (car args))))
              (:external-size
               (if external-size
                 (duplicate-option :external-size)
                 (setq external-size (car args))))
              (:nicknames (setq nicknames (all-names nil args nicknames)))
              ;; (:local-nicknames (setq local-nicknames (all-local-nicknames args local-nicknames)))
              (:local-nicknames
               (setq local-nicknames
                     (append local-nicknames
                             (mapcar (lambda (spec)
                                       (destructuring-bind (nick name) spec
                                         (cons (string nick)(string name))))
                                     args))))
              (:shadow (setq shadow (all-names :shadow args shadow)))
              (:shadowing-import-from
               (destructuring-bind (from &rest shadowing-imports) args
                 (push (cons (string-or-name from)
                             (all-names :shadowing-import-from shadowing-imports nil))
                       shadowing-import-from-specs)))
              (:use (setq use (all-names nil args use)))
              (:import-from
               (destructuring-bind (from &rest imports) args
                 (push (cons (string-or-name from)
                             (all-names :import-from imports nil))
                       import-from-specs)))
              (:intern (setq intern (all-names :intern args intern)))
              (:export (setq export (all-names :export args export)))
		          (:documentation
		           (if documentation
		             (duplicate-option :documentation)
		             (setq documentation (cadr option)))))))
        `(eval-when (:execute :compile-toplevel :load-toplevel)
           (%define-package
            ',(string-or-name name)
	          ',size
	          ',external-size
	          ',nicknames
            ',local-nicknames
	          ',shadow
	          ',shadowing-import-from-specs
	          ',use
	          ',import-from-specs
	          ',intern
	          ',export
	          ',documentation))))))

(defmacro defpackage (name &rest options)
  "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
   following:
    (:NICKNAMES {package-name}*)
    (:SIZE <integer>)
    (:EXTERNAL-SIZE <integer>)
    (:SHADOW {symbol-name}*)
    (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
    (:USE {package-name}*)
    (:IMPORT-FROM <package-name> {symbol-name}*)
    (:INTERN {symbol-name}*)
    (:EXPORT {symbol-name}*)
    (:DOCUMENTATION doc-string)
   All options except SIZE and DOCUMENTATION can be used multiple
   times."
  (apply #'%defpackage name options))

;;; l1-symhash.lisp

(defun %define-package (name
                        size
                        external-size ; extension (may be nil.)
                        nicknames
                        local-nicknames
                        shadow
                        shadowing-import-from-specs
                        use
                        import-from-specs
                        intern
                        export
			                  &optional doc)
  (if (eq use :default) (setq use *make-package-use-defaults*))
  (let* ((pkg (find-package name)))
    (if pkg
      ;; Restarts could offer several ways of fixing this.
      (unless (string= (package-name pkg) name)
        (cerror "Redefine ~*~S"
                "~S is already a nickname for ~S" name pkg))
      (setq pkg (make-package name
                              :use nil
                              :internal-size (or size 60)
                              :external-size (or external-size
                                                 (max (length export) 1)))))
    (record-source-file name 'package)
    (unuse-package (package-use-list pkg) pkg)
    (rename-package pkg name nicknames)
    (dolist (cons (package-%local-nicknames pkg))
      (remove-package-local-nickname (car cons) pkg))
    (dolist (cons local-nicknames)
      (add-package-local-nickname (car cons) (cdr cons) pkg))
    (flet ((operation-on-all-specs (function speclist)
             (let ((to-do nil))
               (dolist (spec speclist)
                 (let ((from (pop spec)))
                   (dolist (str spec)
                     (multiple-value-bind (sym win) (find-symbol str from)
                       (if win
                         (push sym to-do)
                         ;; This should (maybe) be a PACKAGE-ERROR.
                         (cerror "Ignore attempt to ~s ~s from package ~s"
                                 "Cannot ~s ~s from package ~s" function str from))))))
               (when to-do (funcall function to-do pkg)))))
      (dolist (sym shadow) (shadow sym pkg))
      (operation-on-all-specs 'shadowing-import shadowing-import-from-specs)
      (use-package use pkg)
      (operation-on-all-specs 'import import-from-specs)
      (dolist (str intern) (intern str pkg))
      (when export
        (let* ((syms nil))
          (dolist (str export)
            (multiple-value-bind (sym found) (find-symbol str pkg)
              (unless found (setq sym (intern str pkg)))
              (push sym syms)))
          (export syms pkg)))
      (when (and doc *save-doc-strings*)
        (set-documentation pkg t doc))
      pkg)))


(define-condition simple-package-error (package-error simple-condition) ())

(defun signal-package-error (package format-control &rest format-args)
  (error 'simple-package-error
         :package package
         :format-control format-control
         :format-arguments format-args))

(defun signal-package-cerror (package continue-string
                              format-control &rest format-args)
  (cerror continue-string
          'simple-package-error
          :package package
          :format-control format-control
          :format-arguments format-args))

(defun package-local-nicknames (package-designator)
  "Returns an alist of \(local-nickname . actual-package) describing the
nicknames local to the designated package.
When in the designated package, calls to FIND-PACKAGE with the any of the
local-nicknames will return the corresponding actual-package instead. This
also affects all implied calls to FIND-PACKAGE, including those performed by
the reader.
When printing a package prefix for a symbol with a package local nickname, the
local nickname is used instead of the real name in order to preserve
print-read consistency.
See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCALLY-NICKNAMED-BY-LIST,
REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES.
Experimental: interface subject to change."
  (copy-tree
   (package-%local-nicknames
    (if (typep package-designator 'package)
      package-designator
      (pkg-arg package-designator)))))

(defun package-locally-nicknamed-by-list (package-designator)
  "Returns a list of packages which have a local nickname for the designated
package.
See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCAL-NICKNAMES,
REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES.
Experimental: interface subject to change."
  (copy-list
   (package-%locally-nicknamed-by
    (if (typep package-designator 'package)
      package-designator
      (pkg-arg package-designator)))))

(defun add-package-local-nickname (local-nickname actual-package
                                   &optional (package-designator *package*))
  "Adds LOCAL-NICKNAME for ACTUAL-PACKAGE in the designated package, defaulting
to current package. LOCAL-NICKNAME must be a string designator, and
ACTUAL-PACKAGE must be a package designator.
Returns the designated package.
Signals a continuable error if LOCAL-NICKNAME is already a package local
nickname for a different package, or if LOCAL-NICKNAME is one of \"CL\",
\"COMMON-LISP\", or, \"KEYWORD\", or if LOCAL-NICKNAME is a global name or
nickname for the package to which the nickname would be added.
When in the designated package, calls to FIND-PACKAGE with the LOCAL-NICKNAME
will return the package the designated ACTUAL-PACKAGE instead. This also
affects all implied calls to FIND-PACKAGE, including those performed by the
reader.
When printing a package prefix for a symbol with a package local nickname,
local nickname is used instead of the real name in order to preserve
print-read consistency.
See also: PACKAGE-LOCAL-NICKNAMES, PACKAGE-LOCALLY-NICKNAMED-BY-LIST,
REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES.
Experimental: interface subject to change."
  (let* ((nick (string local-nickname))
         (actual (pkg-arg actual-package))
         (package (pkg-arg package-designator))
         (existing (package-%local-nicknames package))
         (cell (assoc nick existing :test #'string=)))
    (unless actual
      (signal-package-error
       package-designator
       "The name ~S does not designate any package."
       actual-package))
    (unless (package-name actual)
      (signal-package-error
       actual
       "Cannot add ~A as local nickname for a deleted package: ~S"
       nick actual))
    (when (member nick '("CL" "COMMON-LISP" "KEYWORD") :test #'string=)
      (signal-package-cerror
       actual
       "Continue, use it as local nickname anyways."
       "Attempt to use ~A as a package local nickname (for ~A)."
       nick (package-name actual)))
    (when (string= nick (package-name package))
      (signal-package-cerror
       package
       "Continue, use it as a local nickname anyways."
       "Attempt to use ~A as a package local nickname (for ~A) in ~
        package named globally ~A."
       nick (package-name actual) nick))
    (when (member nick (package-nicknames package) :test #'string=)
      (signal-package-cerror
       package
       "Continue, use it as a local nickname anyways."
       "Attempt to use ~A as a package local nickname (for ~A) in ~
        package nicknamed globally ~A."
       nick (package-name actual) nick))
    (when (and cell (neq actual (cdr cell)))
      (restart-case
          (signal-package-error
           actual
           "~@<Cannot add ~A as local nickname for ~A in ~A: ~
            already nickname for ~A.~:@>"
           nick (package-name actual)
           (package-name package) (package-name (cdr cell)))
        (keep-old ()
          :report (lambda (s)
                    (format s "Keep ~A as local nicname for ~A."
                            nick (package-name (cdr cell)))))
        (change-nick ()
          :report (lambda (s)
                    (format s "Use ~A as local nickname for ~A instead."
                            nick (package-name actual)))
          (let ((old (cdr cell)))
            (setf (package-%locally-nicknamed-by old)
                  (delete package (package-%locally-nicknamed-by old)))
            (push package (package-%locally-nicknamed-by actual))
            (setf (cdr cell) actual))))
      (return-from add-package-local-nickname package))
    (unless cell
      (push (cons nick actual) (package-%local-nicknames package))
      (push package (package-%locally-nicknamed-by actual)))
    package))

(defun remove-package-local-nickname (old-nickname
                                      &optional (package-designator *package*))
  "If the designated package had OLD-NICKNAME as a local nickname for
another package, it is removed. Returns true if the nickname existed and was
removed, and NIL otherwise.
See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCAL-NICKNAMES,
PACKAGE-LOCALLY-NICKNAMED-BY-LIST, and the DEFPACKAGE option :LOCAL-NICKNAMES.
Experimental: interface subject to change."
  (let* ((nick (string old-nickname))
         (package (pkg-arg package-designator))
         (existing (package-%local-nicknames package))
         (cell (assoc nick existing :test #'string=)))
    (when cell
      (let ((old (cdr cell)))
        (setf (package-%local-nicknames package) (delete cell existing))
        (setf (package-%locally-nicknamed-by old)
              (delete package (package-%locally-nicknamed-by old))))
      t)))

(export '(package-local-nicknames
          package-locally-nicknamed-by-list
          add-package-local-nickname
          remove-package-local-nickname)
        (find-package :ccl))