Imported package from COM.INFORMATIMAGO.COMMON-LISP.LISP-READER.

Pascal J. Bourguignon [2013-12-15 02:07]
Imported package from COM.INFORMATIMAGO.COMMON-LISP.LISP-READER.
Filename
package-def.lisp
package-fun.lisp
package-mac.lisp
package-pac.lisp
diff --git a/package-def.lisp b/package-def.lisp
index c6cc121..8a1ec1c 100644
--- a/package-def.lisp
+++ b/package-def.lisp
@@ -64,7 +64,7 @@
 ;;;;**************************************************************************


-(cl:in-package "COM.INFORMATIMAGO.COMMON-LISP.LISP-READER.PACKAGE")
+(cl:in-package "COM.INFORMATIMAGO.COMMON-LISP.LISPOS.PACKAGE")


 (defpackage "KEYWORD"
diff --git a/package-fun.lisp b/package-fun.lisp
index 00b3abb..9609dfc 100644
--- a/package-fun.lisp
+++ b/package-fun.lisp
@@ -6,16 +6,15 @@
 ;;;;USER-INTERFACE:     NONE
 ;;;;DESCRIPTION
 ;;;;
-;;;;    See defpackage documentation string.
+;;;;    This package is a CLOS wrapper over the Common Lisp package system.
+;;;;
+;;;;    This file contains the generic functions and methods wrapping
+;;;;    over the CL package functions.
 ;;;;
 ;;;;AUTHORS
-;;;;    <XACH> Zachary Beane <xach@xach.com>,
 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
 ;;;;MODIFICATIONS
-;;;;    2012-04-03 <PJB> Completed corrections to pass package ansi-tests.
-;;;;    2012-03-30 <PJB> Added checks, made the API conforming to CL.
-;;;;    2012-03-30 <PJB> Added this header; Removed "Z" prefix to CL
-;;;;                     symbol names; shadowed and exported them.
+;;;;    2013-11-30 <PJB> cl:package wrapper for LispOS.
 ;;;;BUGS
 ;;;;
 ;;;;    make-load-form for packages should probably return two forms, since
@@ -26,61 +25,31 @@
 ;;;;    for all conflicts, etc).
 ;;;;
 ;;;;LEGAL
-;;;;    Copyright (c) 2012 Zachary Beane <xach@xach.com>, All Rights Reserved
-;;;;    Copyright (c) 2012 Pascal Bourguignon <pjb@informatimago.com>, All Rights Reserved
-;;;;
-;;;;    Redistribution and use in source and binary forms, with or without
-;;;;    modification, are permitted provided that the following conditions
-;;;;    are met:
-;;;;
-;;;;      * Redistributions of source code must retain the above copyright
-;;;;        notice, this list of conditions and the following disclaimer.
-;;;;
-;;;;      * Redistributions in binary form must reproduce the above
-;;;;        copyright notice, this list of conditions and the following
-;;;;        disclaimer in the documentation and/or other materials
-;;;;        provided with the distribution.
-;;;;
-;;;;    THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
-;;;;    OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;;;;    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-;;;;    ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
-;;;;    DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;;;;    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
-;;;;    GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-;;;;    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-;;;;    WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-;;;;    NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-;;;;    SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 ;;;;**************************************************************************



-(cl:in-package "COM.INFORMATIMAGO.COMMON-LISP.LISP-READER.PACKAGE")
-
-;;; Symbol internal management
+(cl:in-package "COM.INFORMATIMAGO.COMMON-LISP.LISPOS.PACKAGE")

-(defgeneric sym-pack (sym))
-(defgeneric (setf sym-pack) (pack sym))
-
-(defgeneric make-constant (symbol value))
-
-;;; Sym tables
-
-(defgeneric make-sym-table ())
-(defgeneric tget (sym-name table))
-(defgeneric tput (sym table))
-(defgeneric tremove (sym table))
-(defgeneric tmember (sym table))
-(defgeneric tmap-syms (fun table))
-(defgeneric tmembers (table))

 ;;; Pack management

-(defgeneric present-table (pack))
-(defgeneric shadowing-table (pack))
-(defgeneric external-table (pack))
-
 (defgeneric accessiblep (sym pack))
 (defgeneric externalp (sym pack))
 (defgeneric shadowingp (sym pack))
@@ -91,27 +60,10 @@
 (defgeneric check-export-conflict (sym pack))
 (defgeneric check-unintern-conflict (sym-name pack))

-(defgeneric zimport-without-checks (sym pack))
-(defgeneric zunintern-without-checks (sym pack))
-
-(defgeneric (setf used-packs) (used-packs pack))
-(defgeneric (setf used-by-packs) (used-by-packs pack))
-
 ;;; Clone of the CL symbol/package interface

-(defgeneric make-symbol (sym-name)
-  (:documentation "
-DO:     Make a new symbol
-URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_mk_sym.htm>
-"))
-
-(defgeneric symbol-name (sym)
-  (:documentation "
-RETURN: the name of the symbol.
-URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_2.htm>
-"))
-
 (defgeneric symbol-package (sym)
+  ;; We need this wrapper to return our PACKAGE instead of CL:PACKAGE
   (:documentation "
 RETURN: the home package of the symbol.
 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_3.htm>
@@ -201,6 +153,9 @@ RETURN: The package name.
 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_pkg_na.htm>
 "))

+(defgeneric package-nicknames (package)
+  (:documentation "RETURN: The list of nicknames of the package."))
+
 (defgeneric package-use-list (pack)
   (:documentation "
 RETURN: The list of packages used by PACK.
@@ -232,6 +187,13 @@ URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_rn_pkg.htm>
 "))


+;; an additionnal function:
+
+(defgeneric package-documentation (package)
+  (:documentation "RETURN: The documentation string of the package."))
+
+
+

 ;;; Variables

@@ -353,391 +315,9 @@ URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/e_pkg_er.htm>



-
-
-;;; Implementation of syms
-
-(defgeneric symbol-plist (symbol)
-(:documentation "
-RETURN: The plist of the symbol.
-URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_4.htm>
-"))
-
-(defgeneric symbol-value (symbol)
-(:documentation "
-RETURN: The value of the symbol.
-URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_5.htm>
-"))
-
-(defgeneric symbol-function (symbol)
-(:documentation "
-RETURN: The function of the symbol.
-URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_1.htm>
-"))
-
-(defclass symbol ()
-  ((name
-    :initarg :name
-    :reader symbol-name)
-   (pack
-    :initarg :pack
-    :reader symbol-package
-    :accessor sym-pack)
-   (plist
-    :initarg :plist
-    :initform nil
-    :accessor symbol-plist)
-   (value
-    :initarg :value
-    :accessor symbol-value)
-   (function
-    :initarg :function
-    :accessor symbol-function)
-   (constantp
-    :initarg :constantp
-    :initform nil
-    :accessor symbol-constantp))
-  (:default-initargs
-   :pack nil)
-  (:documentation "
-The symbol class.
-URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/t_symbol.htm>
-"))
-
-(defgeneric symbolp (object)
-  (:method ((object t))      nil)
-  (:method ((object symbol)) t)
-  (:documentation "
-RETURN: Whether the object is a symbol.
-URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_symbol.htm>
-"))
-
-
-(defgeneric boundp (object)
-  (:method ((object t))
-    (error 'type-error :datum object :expected-type 'symbol))
-  (:method ((object symbol))
-    (slot-boundp object 'value))
-  (:documentation "
-RETURN: Whether the symbol is bound to a value.
-URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_boundp.htm>
-"))
-
-(defgeneric fboundp (object)
-  (:method ((object t))
-    (error 'type-error :datum object :expected-type 'symbol))
-  (:method ((object symbol))
-    (slot-boundp object 'function))
-  (:documentation "
-RETURN: Whether the symbol is fbound to a function.
-URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_fbound.htm>
-"))
-
-
-(defclass keyword (symbol)
-  ()
-  (:documentation "
-The keyword class.
-URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/t_kwd.htm>
-"))
-
-
-(defgeneric keywordp (object)
-  (:method ((object t))       nil)
-  (:method ((object keyword)) t)
-  (:documentation "
-RETURN: Whether the object is a keyword.
-URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_kwdp.htm>
-"))
-
-
-(defmethod make-symbol (sym-name)
-  (make-instance 'symbol :name (copy-seq sym-name)))
-
-(defmethod make-load-form ((sym symbol) &optional environment)
-  (declare (ignore environment))
-  `(intern ,(symbol-name sym) ,(package-name (symbol-package sym))))
-
-
-(defun constituentp (ch first-character-p &optional (readtable *readtable*))
-  (multiple-value-bind (macro-character-p non-terminating-p) (get-macro-character ch readtable)
-    (or (not macro-character-p)
-        (and (not first-character-p)
-             non-terminating-p))))
-
-(defun specialp (ch &optional (readtable *readtable*))
-  (declare (ignore readtable))
-  (find ch #(#\Space #\: #\| #\\
-             #\Newline #\Tab #\Linefeed #\Return #\Page)))
-
-(defun parses-as-a-number-p (string &key (start 0) (end nil) (base *read-base*))
-  ;; integer  ::= [sign] digit+
-  ;; integer  ::= [sign] decimal-digit+ decimal-point
-  ;; ratio    ::= [sign] {decimal-digit}+ '/' {decimal-digit}+
-  ;; float    ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ exponent
-  ;; float    ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+
-  ;; float    ::= [sign] {decimal-digit}+ exponent
-  ;; float    ::= [sign] {decimal-digit}+ decimal-point {decimal-digit}* exponent
-  ;; exponent ::=  exponent-marker [sign] {digit}+
-  ;; We may ignore ratio starting with #\# since that's excluded by constituentp.
-  ;; ratio    ::= [#b|#o|#x|#{decimal-digit}+r] [sign] digit+ '/' digit+
-  (loop
-    :with end =  (or end (length string))
-    :with i = start
-    :with state = :opt-sign
-    :for ch = (and (< i end) (aref string i))
-    :while (< i end)
-    :do (ecase state
-          (:opt-sign (case ch ((#\+ #\-) (incf i)))
-                     (setf state :unknown0))
-          (:unknown0  (if (<= base 10)
-                          (cond
-                            ((digit-char-p ch base) (incf i) (setf state :unknown1))
-                            ((digit-char-p ch 10)   (incf i) (setf state :decimal))
-                            (t (case ch
-                                 ((#\.) (incf i) (setf state :float0))
-                                 (otherwise (return nil)))))
-                          (cond
-                            ((digit-char-p ch 10)   (incf i) (setf state :unknown1))
-                            ((digit-char-p ch base) (incf i) (setf state :integer))
-                            (t (case ch
-                                 ((#\.) (incf i) (setf state :float0))
-                                 (otherwise (return nil)))))))
-          (:unknown1  (if (<= base 10)
-                          (cond
-                            ((digit-char-p ch base) (incf i) (setf state :unknown1))
-                            ((digit-char-p ch 10)   (incf i) (setf state :decimal))
-                            (t (case ch
-                                 ((#\/) (incf i) (setf state :ratio0))
-                                 ((#\.) (incf i) (setf state :dot))
-                                 ((#\D #\d #\E #\e #\F #\f #\L #\l #\S #\s)
-                                  (incf i) (setf state :float-expo/opt-sign))
-                                 (otherwise (return nil)))))
-                          (cond
-                            ((digit-char-p ch 10)   (incf i) (setf state :unknown1))
-                            ((digit-char-p ch base) (incf i) (setf state :integer))
-                            (t (case ch
-                                 ((#\/) (incf i) (setf state :ratio0))
-                                 ((#\.) (incf i) (setf state :dot))
-                                 ((#\D #\d #\E #\e #\F #\f #\L #\l #\S #\s)
-                                  (incf i) (setf state :float-expo/opt-sign))
-                                 (otherwise (return nil)))))))
-          (:integer   (if (digit-char-p ch base)
-                          (incf i)
-                          (return nil)))
-          (:decimal   (if (digit-char-p ch 10)
-                          (incf i)
-                          (case ch
-                            ((#\/) (incf i) (setf state :ratio0))
-                            ((#\.) (incf i) (setf state :dot))
-                            ((#\D #\d #\E #\e #\F #\f #\L #\l #\S #\s)
-                             (incf i) (setf state :float-expo/opt-sign))
-                            (otherwise (return nil)))))
-          (:dot      (if (digit-char-p ch 10)
-                         (progn (incf i) (setf state :float))
-                         (case ch
-                           ((#\D #\d #\E #\e #\F #\f #\L #\l #\S #\s)
-                            (incf i) (setf state :float-expo/opt-sign))
-                           (otherwise (return nil)))))
-          (:ratio0   (if (digit-char-p ch 10)
-                         (progn (incf i) (setf state :ratio))
-                         (return nil)))
-          (:ratio    (if (digit-char-p ch 10)
-                         (incf i)
-                         (return nil)))
-          (:float0   (if (digit-char-p ch 10)
-                         (progn (incf i) (setf state :float))
-                         (return nil)))
-          (:float    (if (digit-char-p ch 10)
-                         (incf i)
-                         (case ch
-                           ((#\D #\d #\E #\e #\F #\f #\L #\l #\S #\s)
-                            (incf i) (setf state :float-expo/opt-sign))
-                           (otherwise (return nil)))))
-          (:float-expo/opt-sign (case ch ((#\+ #\-) (incf i)))
-                                (setf state :float-expo0))
-          (:float-expo0 (if (digit-char-p ch 10)
-                            (progn (incf i) (setf state :float-expo))
-                            (return nil)))
-          (:float-expo  (if (digit-char-p ch 10)
-                            (incf i)
-                            (return nil))))
-    :finally (return (case state
-                       ((:unknown1 :integer :dot :ratio :float :float-expo) t)
-                       (otherwise nil)))))
-
-
-(defun needs-escape-p (symbol-name)
-  "Whether the symbol name needs to be escaped."
-  (cond
-    ((string= "" symbol-name) t)
-    ((or *print-readably* *print-escape*)
-     (or (notevery (let ((first-character-p t))
-                     (lambda (ch)
-                       (prog1 (and (not (specialp ch))
-                                   (constituentp ch first-character-p))
-                         (setf first-character-p nil))))
-                   symbol-name)
-         ;; Parses as a number integer, decimal, ratio or float.
-         (parses-as-a-number-p symbol-name :base *print-base*)))
-    (t
-     nil)))
-
-(defun mixed-case-p (string)
-  "Whether the string contains both lower case and upper case letters."
-  (and (some (lambda (ch) (and (alpha-char-p ch) (upper-case-p ch))) string)
-       (some (lambda (ch) (and (alpha-char-p ch) (lower-case-p ch))) string)))
-
-(defun prepare-symbol-name (sname)
-  (cond
-    ((needs-escape-p sname)
-     (with-output-to-string (*standard-output*)
-       (loop
-         :for ch :across sname
-         :initially (princ "|")
-         :do (if (char= #\| ch) (princ "\\|") (princ ch))
-         :finally (princ "|"))))
-    (t
-     (let ((transform
-            (if *print-escape*
-                (ecase (readtable-case *readtable*)
-                  (:upcase     (lambda (ch)
-                                 (if (both-case-p ch)
-                                     (if (lower-case-p ch)
-                                         (format nil "\\~C" ch)
-                                         ch)
-                                     ch)))
-                  (:downcase   (lambda (ch)
-                                 (if (both-case-p ch)
-                                     (if (upper-case-p ch)
-                                         (format nil "\\~C" ch)
-                                         ch))))
-                  (:preserve   (function identity))
-                  (:invert     (function identity)))
-                (ecase (readtable-case *readtable*)
-                  (:upcase     (let ((start-word t))
-                                 (lambda (ch)
-                                   (prog1 (if (both-case-p ch)
-                                              (if (upper-case-p ch)
-                                                  (ecase *print-case*
-                                                    (:upcase     ch)
-                                                    (:downcase   (char-downcase ch))
-                                                    (:capitalize (if start-word
-                                                                     (char-upcase ch)
-                                                                     (char-downcase ch))))
-                                                  ch)
-                                              ch)
-                                     (if (alphanumericp ch)
-                                         (setf start-word nil)
-                                         (setf start-word t))))))
-                  (:downcase   (let ((start-word t))
-                                 (lambda (ch)
-                                   (prog1 (if (both-case-p ch)
-                                              (if (lower-case-p ch)
-                                                  (ecase *print-case*
-                                                    (:upcase     (char-upcase ch))
-                                                    (:downcase   ch)
-                                                    (:capitalize (if start-word
-                                                                     (char-upcase ch)
-                                                                     (char-downcase ch))))
-                                                  ch)
-                                              ch)
-                                     (if (alphanumericp ch)
-                                         (setf start-word nil)
-                                         (setf start-word t))))))
-                  (:preserve   (function identity))
-                  (:invert     (if (mixed-case-p sname)
-                                   (function identity)
-                                   (lambda (ch)
-                                     (cond
-                                       ((not (both-case-p ch)) ch)
-                                       ((upper-case-p ch)      (char-downcase ch))
-                                       ((lower-case-p ch)      (char-upcase ch))
-                                       (t                      ch)))))))))
-       (with-output-to-string (*standard-output*)
-         (loop
-           :for ch :across sname
-           :do (princ (funcall transform ch))))))))
-
-
-(defmethod print-object ((sym symbol) stream)
-  (let ((*print-readably* t))
-    (flet ((print-it ()
-             (let ((pack (symbol-package sym)))
-               (cond ((null pack)
-                      (format stream "~:[~;#:~]~A"
-                              (or *print-readably* (and *print-escape* *print-gensym*))
-                              (prepare-symbol-name (symbol-name sym))))
-                     ((eql pack *keyword-package*)
-                      (format stream ":~A"
-                              (prepare-symbol-name (symbol-name sym))))
-                     ((or (eq pack *package*)
-                          (eq sym (find-symbol (symbol-name sym) *package*)))
-                      (format stream "~A" (prepare-symbol-name (symbol-name sym))))
-                     (t
-                      (format stream "~A~:[::~;:~]~A"
-                              (prepare-symbol-name (package-name pack))
-                              (externalp sym pack)
-                              (prepare-symbol-name (symbol-name sym))))))))
-      (if *print-readably*
-          (print-it)
-          (progn
-            (format stream "#<~S " 'symbol)
-            (print-it)
-            (format stream ">")))))
-  sym)
-
-
-(defmethod make-constant (symbol value)
-  (declare (ignorable value))
-  (setf (symbol-value symbol) value
-        (symbol-constantp symbol) t)
-  symbol)
-
-
-
-;;; Implementation of sym-tables
-
-(defclass sym-table ()
-  ((name-table
-    :initarg :name-table
-    :reader name-table))
-  (:default-initargs
-   :name-table (make-hash-table :test 'equal)))
-
-(defmethod make-sym-table ()
-  (make-instance 'sym-table))
-
-(defmethod tget (sym-name table)
-  (values (gethash sym-name (name-table table))))
-
-(defmethod tmember (sym table)
-  (let ((entry (tget (symbol-name sym) table)))
-    (eq entry sym)))
-
-(defmethod tput (sym table)
-  (setf (gethash (symbol-name sym) (name-table table)) sym))
-
-(defmethod tremove (sym table)
-  (remhash (symbol-name sym) (name-table table)))
-
-(defmethod tmap-syms (fun table)
-  (maphash (lambda (sym-name sym)
-             (declare (ignore sym-name))
-             (funcall fun sym))
-           (name-table table)))
-
-(defmethod tmembers (table)
-  (let ((members '()))
-    (tmap-syms (lambda (sym)
-                 (push sym members))
-               table)
-    members))
-
-
 ;;; Implementation of packs & CL clone interface

-(defparameter *packs* (make-hash-table :test 'equal))
+(defparameter *packages* (make-hash-table :test 'equal))


 (defun list-all-packages ()
@@ -746,15 +326,18 @@ RETURN: A fresh list of all registered packages.
 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_list_a.htm>
 "
   (let ((packages '()))
-    (maphash (lambda (k v) (declare (ignore k)) (pushnew v packages)) *packs*)
+    (maphash (lambda (k v) (declare (ignore k)) (pushnew v packages)) *packages*)
     packages))

-(defgeneric package-documentation (package)
-  (:documentation "RETURN: The documentation string of the package."))
-(defgeneric package-nicknames (package)
-  (:documentation "RETURN: The list of nicknames of the package."))
-
 (defclass package ()
+  ())
+
+
+(defclass cl-package (package)
+  ())
+
+
+(defclass lispos-package (package)
   ((name
     :initarg :name
     :reader package-name
@@ -1287,13 +870,13 @@ IF-PACKAGE-EXISTS           The default is :PACKAGE
       (dolist (upack use)
         (use-package upack package))
       (dolist (name (cons pack-name nicknames) package)
-        (setf (gethash name *packs*) package)))))
+        (setf (gethash name *packages*) package)))))


 (defmethod find-package (pack-name)
   (etypecase pack-name
     (string-designator
-     (values (gethash (normalize-string-designator pack-name) *packs*)))
+     (values (gethash (normalize-string-designator pack-name) *packages*)))
     (package pack-name)))


@@ -1309,7 +892,7 @@ IF-PACKAGE-EXISTS           The default is :PACKAGE
         (when (eq (symbol-package sym) pack)
           (zunintern-without-checks sym pack)))
       (dolist (name (cons (package-name pack) (package-nicknames pack)))
-        (remhash name *packs*))
+        (remhash name *packages*))
       (setf (name pack) nil)
       pack)))

@@ -1475,12 +1058,12 @@ IF-PACKAGE-EXISTS           The default is :PACKAGE
                                                                    :renaming-package package))
     ;; remove old names:
     (dolist (name (cons (package-name package) (package-nicknames package)))
-      (remhash name *packs*))
+      (remhash name *packages*))
     ;; set new names:
     (setf (name package) (copy-seq new-name)
           (nicknames package) (mapcar (function copy-seq) new-nicknames))
     (dolist (name (cons new-name new-nicknames) package)
-      (setf (gethash name *packs*) package))))
+      (setf (gethash name *packages*) package))))



diff --git a/package-mac.lisp b/package-mac.lisp
index 494a238..9777e95 100644
--- a/package-mac.lisp
+++ b/package-mac.lisp
@@ -6,64 +6,35 @@
 ;;;;USER-INTERFACE:     NONE
 ;;;;DESCRIPTION
 ;;;;
-;;;;    This file contains the macros.
-;;;;
+;;;;    This package is a CLOS wrapper over the Common Lisp package system.
 ;;;;
-;;;;    Implements the Common Lisp package system.
-;;;;
-;;;;    <Xach> The basic idea of that file is that the semantics of the CL
-;;;;    package system can be implemented by an object with three special
-;;;;    kinds of tables (present-table, shadowing-table, external-table)
-;;;;    and two lists (used-packs, used-by-packs). The rest is
-;;;;    implementation.
+;;;;    This file contains the macros.
 ;;;;
 ;;;;AUTHORS
-;;;;    <XACH> Zachary Beane <xach@xach.com>,
 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
 ;;;;MODIFICATIONS
-;;;;    2012-04-03 <PJB> Completed corrections to pass package ansi-tests.
-;;;;    2012-03-30 <PJB> Added checks, made the API conforming to CL.
-;;;;    2012-03-30 <PJB> Added this header; Removed "Z" prefix to CL
-;;;;                     symbol names; shadowed and exported them.
+;;;;    2013-11-30 <PJB> cl:package wrapper for LispOS.
 ;;;;BUGS
-;;;;
-;;;;    make-load-form for packages should probably return two forms, since
-;;;;    packages can have circular dependencies.
-;;;;
-;;;;    Are missing some standard restarts to correct
-;;;;    conflicts. (choosing one or the other symbol, doing the same
-;;;;    for all conflicts, etc).
-;;;;
 ;;;;LEGAL
-;;;;    Copyright (c) 2012 Zachary Beane <xach@xach.com>, All Rights Reserved
-;;;;    Copyright (c) 2012 Pascal Bourguignon <pjb@informatimago.com>, All Rights Reserved
-;;;;
-;;;;    Redistribution and use in source and binary forms, with or without
-;;;;    modification, are permitted provided that the following conditions
-;;;;    are met:
-;;;;
-;;;;      * Redistributions of source code must retain the above copyright
-;;;;        notice, this list of conditions and the following disclaimer.
-;;;;
-;;;;      * Redistributions in binary form must reproduce the above
-;;;;        copyright notice, this list of conditions and the following
-;;;;        disclaimer in the documentation and/or other materials
-;;;;        provided with the distribution.
-;;;;
-;;;;    THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
-;;;;    OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;;;;    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-;;;;    ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
-;;;;    DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;;;;    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
-;;;;    GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-;;;;    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-;;;;    WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-;;;;    NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-;;;;    SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 ;;;;**************************************************************************

-(cl:in-package "COM.INFORMATIMAGO.COMMON-LISP.LISP-READER.PACKAGE")
+(cl:in-package "COM.INFORMATIMAGO.COMMON-LISP.LISPOS.PACKAGE")

 (define-modify-macro appendf (&rest args) append "Append onto list")

diff --git a/package-pac.lisp b/package-pac.lisp
index 0857b34..3fe5149 100644
--- a/package-pac.lisp
+++ b/package-pac.lisp
@@ -9,13 +9,9 @@
 ;;;;    See defpackage documentation string.
 ;;;;
 ;;;;AUTHORS
-;;;;    <XACH> Zachary Beane <xach@xach.com>,
 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
 ;;;;MODIFICATIONS
-;;;;    2012-04-03 <PJB> Completed corrections to pass package ansi-tests.
-;;;;    2012-03-30 <PJB> Added checks, made the API conforming to CL.
-;;;;    2012-03-30 <PJB> Added this header; Removed "Z" prefix to CL
-;;;;                     symbol names; shadowed and exported them.
+;;;;    2013-11-30 <PJB> cl:package wrapper for LispOS.
 ;;;;BUGS
 ;;;;
 ;;;;    make-load-form for packages should probably return two forms, since
@@ -26,38 +22,27 @@
 ;;;;    for all conflicts, etc).
 ;;;;
 ;;;;LEGAL
-;;;;    Copyright (c) 2012 Zachary Beane <xach@xach.com>, All Rights Reserved
-;;;;    Copyright (c) 2012 Pascal Bourguignon <pjb@informatimago.com>, All Rights Reserved
-;;;;
-;;;;    Redistribution and use in source and binary forms, with or without
-;;;;    modification, are permitted provided that the following conditions
-;;;;    are met:
-;;;;
-;;;;      * Redistributions of source code must retain the above copyright
-;;;;        notice, this list of conditions and the following disclaimer.
-;;;;
-;;;;      * Redistributions in binary form must reproduce the above
-;;;;        copyright notice, this list of conditions and the following
-;;;;        disclaimer in the documentation and/or other materials
-;;;;        provided with the distribution.
-;;;;
-;;;;    THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
-;;;;    OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;;;;    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-;;;;    ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
-;;;;    DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;;;;    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
-;;;;    GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-;;;;    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-;;;;    WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-;;;;    NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-;;;;    SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 ;;;;**************************************************************************


-(cl:defpackage "COM.INFORMATIMAGO.COMMON-LISP.LISP-READER.PACKAGE"
+(cl:defpackage "COM.INFORMATIMAGO.COMMON-LISP.LISPOS.PACKAGE"
   (:use "COMMON-LISP")
-  (:nicknames "ZPACK")
   (:shadow "SIMPLE-TYPE-ERROR")
   (:shadow . #1=("SYMBOL"
                  "SYMBOLP" "MAKE-SYMBOL" "SYMBOL-NAME" "SYMBOL-PACKAGE"
@@ -85,16 +70,10 @@
            "SYMBOL-CONFLICT-IMPORTED-SYMBOL"
            "PACKAGE-DOCUMENTATION")
   (:documentation "
-This package implements the Common Lisp package system.
-
-<Xach> The basic idea of that file is that the semantics of the CL
-package system can be implemented by an object with three special
-kinds of tables (present-table, shadowing-table, external-table)
-and two lists (used-packs, used-by-packs). The rest is
-implementation.
+This package is a CLOS wrapper over the Common Lisp package system.

 It shadows the CL symbols dealing with packages, and exports
-replacements that implement the package system anew.
+replacements generic functions and CLOS objects.


 Additionnal symbol exported:
@@ -109,34 +88,22 @@ Additionnal symbol exported:

 License:

-    BSD
-
-    Copyright (c) 2012 Zachary Beane <xach@xach.com>, All Rights Reserved
-    Copyright (c) 2012 Pascal Bourguignon <pjb@informatimago.com>, All Rights Reserved
-
-    Redistribution and use in source and binary forms, with or without
-    modification, are permitted provided that the following conditions
-    are met:
-
-      * Redistributions of source code must retain the above copyright
-        notice, this list of conditions and the following disclaimer.
-
-      * Redistributions in binary form must reproduce the above
-        copyright notice, this list of conditions and the following
-        disclaimer in the documentation and/or other materials
-        provided with the distribution.
-
-    THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
-    OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-    ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
-    DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
-    GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-    WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-    NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-    SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+    AGPL3
+
+    Copyright Pascal J. Bourguignon 2013 - 2013
+
+    This program is free software: you can redistribute it and/or modify
+    it under the terms of the GNU Affero General Public License as published by
+    the Free Software Foundation, either version 3 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU Affero General Public License for more details.
+
+    You should have received a copy of the GNU Affero General Public License
+    along with this program.  If not, see <http://www.gnu.org/licenses/>.

 "))
ViewGit