(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "LISP")

(il:filecreated "30-Oct-86 10:00:24" il:{eris}<lispcore>sources>cmlpackage.\;28
 26390  

      il:|changes| il:|to:|  (il:functions il:package-hashtable-inspect-fetchfn 
                                    il:symbol-inspect-fetchfn il:resolve-reader-conflict)

      il:|previous| il:|date:| "28-Oct-86 11:51:48" il:{eris}<lispcore>sources>cmlpackage.\;24)


; Copyright (c) 1986 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:cmlpackagecoms)

(il:rpaqq il:cmlpackagecoms
 ((il:* il:|;;;| "This is the second part of the package system, the first is in LLPACKAGE, which is loaded during the init"
                                   )
                             (il:advise il:comp.userfn)
                             (il:setfs symbol-package)
                             (il:functions il:dwim-symbol-package)
                             (il:declare\: il:donteval@load il:docopy (il:addvars (il:dwimuserforms
                                                                                   (
                                                                               il:dwim-symbol-package
                                                                                    ))))
                             (il:vars (il:* il:\; 
                 "As soon as defcondition works again this becomes the conflicting symbol condition."
                                            )
                                    il:nucondition)
                             (il:variables il:*preferred-reading-symbols*)
                             (il:functions il:resolve-reader-conflict)
                             (il:* il:|;;| "User friendly symbol error resolving functions")
                             (il:functions il:resolve-missing-external-symbol 
                                    il:resolve-use-package-conflict il:resolve-export-conflict 
                                    il:resolve-export-missing il:resolve-import-conflict 
                                    il:resolve-unintern-conflict)
                             (il:* il:|;;| "Symbol inspector")
                             (il:functions il:symbol-inspect-fetchfn il:symbol-inspect-storefn)
                             (il:p (let ((il:form '((il:function symbolp)
                                                    (il:name il:value il:plist package)
                                                    il:symbol-inspect-fetchfn 
                                                    il:symbol-inspect-storefn nil nil nil 
                                                    "Symbol inspector")))
                                        (cond ((not (il:member il:form il:inspectmacros))
                                               (il:|push| il:inspectmacros il:form)))))
                             (il:* il:|;;| "Package inspector")
                             (il:functions il:package-inspect-fetchfn il:package-inspect-storefn)
                             (il:p (let ((il:form '((il:function packagep)
                                                    (il:name il:nicknames il:use-list 
                                                           il:internal-symbols il:external-symbols 
                                                           il:shadowing-symbols)
                                                    il:package-inspect-fetchfn 
                                                    il:package-inspect-storefn nil nil nil 
                                                    "Package inspector")))
                                        (cond ((not (il:member il:form il:inspectmacros))
                                               (il:|push| il:inspectmacros il:form)))))
                             (il:* il:|;;| "Package-hashtable inspector")
                             (il:functions il:package-hashtable-inspect-fetchfn 
                                    il:package-hashtable-inspect-storefn)
                             (il:p (let ((il:form '((il:function package-hashtable-p)
                                                    (il:size il:free il:deleted il:contents)
                                                    il:package-hashtable-inspect-fetchfn 
                                                    il:package-hashtable-inspect-storefn)))
                                        (cond ((not (il:member il:form il:inspectmacros))
                                               (il:|push| il:inspectmacros il:form)))))
                             (il:prop (il:filetype il:makefile-environment)
                                    il:cmlpackage)
                             (il:declare\: il:donteval@load il:doeval@compile il:dontcopy 
                                    il:compilervars (il:addvars (il:nlama)
                                                           (il:nlaml)
                                                           (il:lama)))))



(il:* il:|;;;| 
"This is the second part of the package system, the first is in LLPACKAGE, which is loaded during the init"
)



(il:putprops il:comp.userfn il:readvice
 
             (nil (il:before nil (cond ((keywordp il:x)
                                        (return (list 'quote il:x)))
                                       ((and (eq (car (il:listp (car (il:listp il:x))))
                                                 'lambda)
                                             (cond ((il:intersection (cadr (car il:x))
                                                           lambda-list-keywords)
                                                    (il:error 
                                           "Can't cope with lambda keywords in internal LAMBDA lists"
                                                           ))
                                                   (t (return `((il:lambda ,@(cdar il:x))
                                                                ,@(cdr il:x)))))))))))
(il:readvise il:comp.userfn)
(defsetf symbol-package
 il:setf-symbol-package)

(defun il:dwim-symbol-package

   nil (declare (special il:faultx il:faultapplyflg))

                                                  (il:* il:|;;| "This is placed on DWIMUSERFORMS to attempt corrections where the typed symbol is in the wrong package.")

       (let ((il:sym (or (car (il:listp il:faultx))
                         il:faultx))
             il:others)
            (cond
               ((and (il:litatom il:sym)
                     (cdr (il:setq il:others (find-all-symbols (symbol-name il:sym))))
                     (il:setq il:others (il:|for| il:x il:|in| il:others il:|collect| il:x il:|when|
                                               (and (il:neq il:x il:sym)
                                                    (not (keywordp il:x))
                                                    (il:|if| (and (il:litatom il:faultx)
                                                                  (not il:faultapplyflg))
                                                           il:|then|

                                                             (il:* il:\; "Error is uba")

                                                           (boundp il:x)
                                                           il:|else|
                                                           (fboundp il:x))))))
                (il:|for| il:choice il:|in| il:others il:|when| (il:fixspell1 il:sym il:choice nil t
                                                                       (and (cdr il:others)
                                                                            'il:mustapprove))
                       il:|do|
                    (il:* il:|;;| "Normally there is only one choice, and we offer it.  If there is more than one choice, probably should do something like a menu.  This is quick and dirty--ask user for each in turn and require approval so that it doesn't choose the first automatically.")

                       (return (il:|if| (il:listp il:faultx)
                                      il:|then|
              (il:* il:\; "SYM = (CAR FAULTX)")

                                      (il:/rplaca il:faultx il:choice)
                                      il:|else| il:choice)))))))

(il:declare\: il:donteval@load il:docopy 

(il:addtovar il:dwimuserforms
 (il:dwim-symbol-package))
)

(il:rpaqq il:nucondition
 (il:define-condition il:symbol-conflict
 il:simple-error :report
                                                                       (il:format nil 
                                                             "Symbols named ~s exists in packages ~s"
                                                                              (
                                                                              il:symbol-conflict-name
                                                                               il:condition)
                                                                              (
                                                                          il:symbol-conflict-packages
                                                                               il:condition))
                                                                       :handle
                                                                       (il:handle-symbol-conflict
                                                                        il:condition)
                                                                       il:name il:packages)
)
(defvar il:*preferred-reading-symbols*
 nil 
                      "List of symbols whose lookup is preferred by the litatom to symbol converter.")

(defun il:resolve-reader-conflict
 (il:ilsym il:clsym il:clsymwhere) "Reader finds unqualified symbol that exists in both InterLisp and Lisp.  Checks *PREFERRED-READING-SYMBOLS* list against names."
   (declare (special il:cmlsymbols.conflicts il:*preferred-reading-symbols*))

                                                  (il:* il:|;;| "CAUTION: Do not attempt to move the namestring check from \\NEW.READ.SYMBOL into this function as RESOLVE-READER-CONFLICT has a dummy definition in the INIT.  Also, namestring resolutions must be made during the time that packages are turned off in the beginning of the INIT.")

   (cond
      ((member il:ilsym il:cmlsymbols.conflicts :test 'string=)

                                                  (il:* il:\; "If this symbol was qualified in Koto sources (eg, it has never appeared unqualified in old sources), then use the Interlisp definition.")

       il:ilsym)
      ((not (eq il:clsymwhere :external))
         (il:* il:\; 

                                    "Will not resolve internal (therefore private) symbols from LISP")

       il:ilsym)
      (t (let ((il:ilpreferred (member il:ilsym il:*preferred-reading-symbols* :test 'eq))
               (il:clpreferred (member il:clsym il:*preferred-reading-symbols* :test 'eq)))
              (cond
                 ((and il:ilpreferred (not il:clpreferred))
                  il:ilsym)
                 ((and il:clpreferred (not il:ilpreferred))
                  il:clsym)
                 (t 
                                         (il:* il:\; "Ask what they meant.")

                    (il:proceed-case (error "Symbols named ~s exist in LISP and INTERLISP"
                                            (symbol-name il:ilsym))
                           (il:prefer-clsym-proceed (il:condition)
                                  :test il:true :report "Return LISP symbol, make it preferred"
                                  (setq il:*preferred-reading-symbols* (remove il:ilsym 
                                                                       il:*preferred-reading-symbols* 
                                                                              :test #'eq))
                                  (push il:clsym il:*preferred-reading-symbols*)
                                  il:clsym)
                           (il:return-clsym-proceed (il:condition)
                                  :test il:true :report "Just return LISP symbol" il:clsym)
                           (il:prefer-ilsym-proceed (il:condition)
                                  :test il:true :report "Return INTERLISP symbol, make it preferred"
                                  (setq il:*preferred-reading-symbols* (remove il:clsym 
                                                                       il:*preferred-reading-symbols* 
                                                                              :test #'eq))
                                  (push il:ilsym il:*preferred-reading-symbols*)
                                  il:ilsym)
                           (il:return-ilsym-proceed (il:condition)
                                  :test il:true :report "Just return INTERLISP symbol" il:ilsym))))))
      ))




(il:* il:|;;| "User friendly symbol error resolving functions")


(defun il:resolve-missing-external-symbol
 (il:name package) 
                                          "Handle missing external symbols in a package during read."
   (cerror "Create the symbol ~s externally in package ~s." 
          "External symbol ~s not found in package ~s." il:name (%package-name package))
   (export (intern il:name package)
          package))

(defun il:resolve-use-package-conflict
 (il:pkg il:cset package) "Handle a conflict from use-package."
   (il:setq il:cset (sort il:cset 'string<))
   (il:proceed-case (error "Use'ing package ~A results in name conflicts for symbols:~% ~{~S ~}~%"
                           (%package-name il:pkg)
                           il:cset
                           (%package-name package))
          (il:unintern-user-proceed (il:condition)
                 :test il:true :report (format t 
                                              "Unintern conflicting symbols from ~A (VERY DANGEROUS)"
                                              (%package-name package))
                 (dolist (il:s il:cset)
                        (il:moby-unintern il:s package)))
          (il:unintern-usee-proceed (il:condition)
                 :test il:true :report (format t 
                                              "Unintern conflicting symbols from ~A (VERY DANGEROUS)"
                                              (%package-name il:pkg))
                 (dolist (il:s il:cset)
                        (il:moby-unintern (find-symbol (symbol-name il:s)
                                                 il:pkg)
                               il:pkg)))
          (il:allow-shadow-proceed (il:condition)
                 :test il:true :report (format t 
                                       "Let symbols in package ~s shadow all others (pushdown order)"
                                              (%package-name package))
                 nil)
          (il:abort-use-package-proceed (il:condition)
                 :test il:true :report (format t "Abort using package ~s" (%package-name il:pkg))
                 (il:retfrom 'use-package nil))))

(defun il:resolve-export-conflict
 (package il:cset il:cpackages il:syms) 
                                                                "Handle a conflict raised by export."
   (il:setq il:cset (sort il:cset 'string<))
   (il:setq il:cpackages (sort il:cpackages (il:function (lambda (il:a il:b)
                                                                (string< (%package-name il:a)
                                                                       (%package-name il:b))))))
   (il:proceed-case (error "Exporting these symbols from the ~A package:~%~{~S ~}~% results in name conflicts with package(s):~%~{~A ~}~%"
                           (%package-name package)
                           il:cset
                           (mapcar (il:function %package-name)
                                  il:cpackages))
          (il:unintern-proceed (il:condition)
                 :test il:true :report 
                 "Unintern conflicting symbols in package(s)~*~*~{~S ~}~%(VERY DANGEROUS)"
                 (dolist (il:p il:cpackages)
                        (dolist (il:sym il:cset)
                               (il:moby-unintern il:sym il:p)))
                 (nset-difference il:syms il:cset))
          (il:abort-export-proceed (il:condition)
                 :test il:true :report (format t "Abort exporting the symbols from package ~s"
                                              (%package-name package))
                 (il:retfrom 'export nil))))

(defun il:resolve-export-missing
 (package il:missing) "Handle missing symbols needed to export."
   (il:setq il:missing (sort il:missing 'string<))
   (il:proceed-case (error "These symbols are not available in the ~A package:~%~{~S ~}~%"
                           (%package-name package)
                           il:missing)
          (il:import-proceed (il:condition)
                 :test il:true :report "Import these symbols" (import il:missing package))
          (il:abort-export-proceed (il:condition)
                 :test il:true :report (format t "Abort export to package ~s" (%package-name package)
                                              )
                 (il:retfrom 'import nil))))

(defun il:resolve-import-conflict
 (package il:cset) 
                   "Handle conflict signalled by import.  Returning from here does shadowing import."
   (il:setq il:cset (sort il:cset 'string<))
   (il:proceed-case (error 
                     "Importing these symbols into the ~A package causes a name conflict:~%~{~S ~}~%"
                           (%package-name package)
                           il:cset)
          (il:shadowing-import-proceed (il:condition)
                 :test il:true :report "Import symbols with shadowing-import" nil)
          (il:abort-import-proceed (il:condition)
                 :test il:true :report (format t "Abort import into package ~s" (%package-name 
                                                                                       package))
                 (il:retfrom 'import nil))))

(defun il:resolve-unintern-conflict
 (symbol il:cset package) "Handle a conflict noted by unintern."
   (il:setq il:cset (sort il:cset 'string<))
   (il:proceed-case (error 
                         "Uninterning symbol ~S causes name conflict among these symbols:~%~{~S ~}~%" 
                           symbol il:cset)
          (il:shadowing-import-proceed (il:condition)
                 :test il:true :report "Shadowing import a symbol"
                 (loop (let ((il:sym (il:menu (il:create il:menu il:title il:_ 
                                                     "Choose symbol to shadowing-import" il:items 
                                                     il:_ il:cset il:centerflg il:_ t))))
                            (when (il:fmemb il:sym il:cset)
                                  (shadowing-import il:sym package)
                                  (il:retfrom 'unintern t)))))
          (il:abort-unintern-proceed (il:condition)
                 :test il:true :report (format t "Abort unintern of symbol ~s from package ~s" symbol
                                              (%package-name package))
                 (il:retfrom 'unintern nil))))




(il:* il:|;;| "Symbol inspector")


(defun il:symbol-inspect-fetchfn
 (il:object il:property) (case il:property (il:name (symbol-name
                                                                                     il:object))
                                                               (il:value (if (boundp il:object)
                                                                             (symbol-value il:object)
                                                                             'il:nobind))
                                                               (il:plist (symbol-plist il:object))
                                                               (package (symbol-package il:object))))

(defun il:symbol-inspect-storefn
 (il:object il:property il:value) (case il:property
                                                                        (il:name (il:promptprint
                                                                                  
                                                                              "Can't set symbol name"
                                                                                  ))
                                                                        (il:value (setf (symbol-value
                                                                                         il:object)
                                                                                        il:value))
                                                                        (il:plist (setf (symbol-plist
                                                                                         il:object)
                                                                                        il:value))
                                                                        (package (setf (
                                                                                       symbol-package
                                                                                        il:object)
                                                                                       il:value))))

(let ((il:form '((il:function symbolp)
                 (il:name il:value il:plist package)
                 il:symbol-inspect-fetchfn il:symbol-inspect-storefn nil nil nil "Symbol inspector"))
      )
     (cond ((not (il:member il:form il:inspectmacros))
            (il:|push| il:inspectmacros il:form))))



(il:* il:|;;| "Package inspector")


(defun il:package-inspect-fetchfn
 (il:object il:property) (case il:property (il:name (%package-name
                                                                                      il:object))
                                                                (il:nicknames (%package-nicknames
                                                                               il:object))
                                                                (il:use-list (%package-use-list
                                                                              il:object))
                                                                (il:internal-symbols (
                                                                            %package-internal-symbols
                                                                                      il:object))
                                                                (il:external-symbols (
                                                                            %package-external-symbols
                                                                                      il:object))
                                                                (il:shadowing-symbols (
                                                                           %package-shadowing-symbols
                                                                                       il:object))))

(defun il:package-inspect-storefn
 (il:object il:property il:value) (il:promptprint 
                                                                  "Can't set the fields of a package"
                                                                          ))

(let ((il:form '((il:function packagep)
                 (il:name il:nicknames il:use-list il:internal-symbols il:external-symbols 
                        il:shadowing-symbols)
                 il:package-inspect-fetchfn il:package-inspect-storefn nil nil nil 
                 "Package inspector")))
     (cond ((not (il:member il:form il:inspectmacros))
            (il:|push| il:inspectmacros il:form))))



(il:* il:|;;| "Package-hashtable inspector")


(defun il:package-hashtable-inspect-fetchfn
 (il:object il:property) (case il:property
                                                                          (il:size (
                                                                               package-hashtable-size
                                                                                    il:object))
                                                                          (il:free (
                                                                               package-hashtable-free
                                                                                    il:object))
                                                                          (il:deleted (
                                                                            package-hashtable-deleted
                                                                                       il:object))
                                                                          (il:contents (
                                                                              package-hashtable-table
                                                                                        il:object))))

(defun il:package-hashtable-inspect-storefn
 (il:object il:property il:value) (il:promptprint 
                                                        "Can't set the fields of a package-hashtable"
                                                                                    ))

(let ((il:form '((il:function package-hashtable-p)
                 (il:size il:free il:deleted il:contents)
                 il:package-hashtable-inspect-fetchfn il:package-hashtable-inspect-storefn)))
     (cond ((not (il:member il:form il:inspectmacros))
            (il:|push| il:inspectmacros il:form))))

(il:putprops il:cmlpackage il:filetype
 compile-file)

(il:putprops il:cmlpackage il:makefile-environment
 (:readtable "XCL" :package "LISP"))
(il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars 

(il:addtovar il:nlama
 )

(il:addtovar il:nlaml
 )

(il:addtovar il:lama
 )
)
(il:putprops il:cmlpackage il:copyright ("Xerox Corporation" 1986))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop