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

(il:filecreated "14-Jun-90 17:33:55" il:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLPACKAGE.;3|
 22253  

      il:|previous| il:|date:| "16-May-90 14:12:37" il:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLPACKAGE.;2|
)


; Copyright (c) 1986, 1987, 1988, 1990 by Venue & 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:setfs symbol-package) (il:functions il:dwim-symbol-package escape-colons-proceed make-external-proceed make-internal-proceed ugly-symbol-proceed) (il:declare\: il:donteval@load il:docopy (il:addvars (il:dwimuserforms (il:dwim-symbol-package)))) (il:* il:|;;| "User friendly symbol error resolving functions") (il:structures read-conflict missing-external-symbol missing-package) (il:variables *preferred-reading-symbols*) (il:functions il:resolve-reader-conflict il:resolve-missing-external-symbol il:resolve-missing-package) (il:structures package-error symbol-conflict use-conflict export-conflict export-missing import-conflict unintern-conflict) (il:functions il:resolve-use-package-conflict il:resolve-export-conflict il:resolve-export-missing il:resolve-import-conflict il:resolve-unintern-conflict) (il:structures symbol-colon-error) (il:functions il:\\invalid.symbol (il:* il:\; "Also defined (w/o the error condition or proceed case) in LLREAD.")) (il:* il:|;;| "Symbol inspector") (il:functions il:symbol-inspect-fetchfn il:symbol-inspect-storefn) (il:p (let ((il:form (quote ((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 (quote ((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 (quote ((il:function lisp::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:* il:|;;| "Package's Prefix accessor and setfs (Edited by TT 14-June-90 for AR#11112)") (il:functions package-prefix setf-package-prefix) (il:setfs package-prefix) (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"
)



(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) (quote 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)))))))

(define-proceed-function escape-colons-proceed :condition symbol-colon-error :report "Treat the extra colon(s) as if they were escaped")

(define-proceed-function make-external-proceed :condition missing-external-symbol :report "Return a new external symbol by that name" (condition *current-condition*))

(define-proceed-function make-internal-proceed :condition missing-external-symbol :report "Return a new internal symbol by that name")

(define-proceed-function ugly-symbol-proceed :condition missing-package)
(il:declare\: il:donteval@load il:docopy 

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



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



(define-condition read-conflict (read-error) (name packages) (:report (lambda (condition stream) (quote (format stream "Symbols named ~a exist in packages:~{~a ~}" (read-conflict-name condition) (mapcar (function package-name) (read-conflict-packages condition)))) (format stream "Symbols named ~A exists in packages:" (read-conflict-name condition)) (dolist (pkg (read-conflict-packages condition)) (princ " " stream) (princ (package-name pkg) stream)))))

(define-condition missing-external-symbol (read-error) (name package) (:report (lambda (condition stream) (format stream "External symbol ~a not found in package ~a" (missing-external-symbol-name condition) (package-name (missing-external-symbol-package condition))))))

(define-condition missing-package (read-error) (package-name symbol-name external) (:report (lambda (condition stream) (format stream "Can't find package ~a to look up symbol ~a" (missing-package-package-name condition) (missing-package-symbol-name condition)))))

(defvar *preferred-reading-symbols* (quote (il:append il:apply il:apropos il:array il:arrayp il:assoc il:atan il:atom il:block il:break il:char il:character il:close il:common il:compile il:compile-file il:cos il:count il:defstruct il:delete il:describe il:directory il:do il:documentation il:elt il:equal il:error il:eval il:every il:exp il:expt il:fill-pointer il:find il:first il:floatp il:floor il:format il:function il:gcd il:gensym il:gethash il:if il:intersection il:keyword il:labels il:lambda il:ldiff il:length il:listp il:load il:locally il:log il:loop il:map il:mapc il:mapcar il:mapcon il:maphash il:maplist il:member il:merge il:mismatch il:mod il:namestring il:notany il:notevery il:nth il:number il:numberp il:numerator il:pop il:position il:prin1 il:print il:push il:pushnew il:rational il:read il:readtable il:remove il:replace il:rest il:reverse il:search il:second il:setq il:signed-byte il:simple-string il:sin il:some il:sort il:sqrt il:stringp il:structure il:sublis il:subseq il:subst il:symbol il:tan il:terpri trace il:union il:unless il:values il:variable il:vector il:when il:zerop il:* il:***)) "List of symbols whose lookup is preferred by the litatom to symbol converter.  Initially it contains a list of symbols which are conflicting but are always qualified in old sources.")

(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 *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 ((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 *preferred-reading-symbols* :test (quote eq))) (il:clpreferred (member il:clsym *preferred-reading-symbols* :test (quote eq)))) (cond ((and il:ilpreferred (not il:clpreferred)) il:ilsym) ((and il:clpreferred (not il:ilpreferred)) il:clsym) (t (il:* il:\; "Raise the signal") (restart-case (error (quote read-conflict) :name (symbol-name il:ilsym) :packages (list (find-package "LISP") (find-package "INTERLISP"))) (prefer-clsym-proceed nil :condition read-conflict :report (lambda (stream) (format stream "Return the LISP symbol ~A; make it preferred" il:clsym)) il:clsym) (prefer-ilsym-proceed nil :condition read-conflict :report (lambda (stream) (format stream "Return the INTERLISP symbol ~A; make it preferred" il:ilsym)) (setq *preferred-reading-symbols* (remove il:clsym *preferred-reading-symbols* :test (function eq))) (push il:ilsym *preferred-reading-symbols*) il:ilsym) (return-ilsym-proceed nil :condition read-conflict :report (lambda (stream) (format stream "Just return the INTERLISP symbol ~A" il:ilsym)) il:ilsym))))))))

(defun il:resolve-missing-external-symbol (il:name package) "Handle missing external symbols in a package during read." (let ((il:my-condition (make-condition (quote missing-external-symbol) :name il:name :package package))) (flet ((il:filter nil (eq *current-condition* il:my-condition))) (restart-case (error il:my-condition) (make-external-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return a new external symbol in package ~A named ~A" (package-name package) il:name)) (let ((il:symbol (intern il:name package))) (export il:symbol package) il:symbol)) (make-internal-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return a new internal symbol in package ~A named ~A" (package-name package) il:name)) (intern il:name package))))))

(defun il:resolve-missing-package (package-name symbol-name externalp) (let ((il:my-condition (make-condition (quote missing-package) :package-name package-name :symbol-name symbol-name :external externalp))) (flet ((il:filter nil (eq *current-condition* il:my-condition))) (restart-case (error il:my-condition) (new-package-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return new symbol named ~A made in new package ~A" symbol-name package-name)) (let* ((package (make-package (missing-package-package-name il:my-condition))) (symbol (intern (missing-package-symbol-name il:my-condition) package))) (when (missing-package-external il:my-condition) (export symbol package)) symbol)) (ugly-symbol-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return new ugly symbol |~a~a~a| made in current package ~a" package-name (if externalp ":" "::") symbol-name (package-name *package*))) :interactive (lambda nil (list *package*)) (intern (il:concat (missing-package-package-name il:my-condition) (if (missing-package-external il:my-condition) ":" "::") (missing-package-symbol-name il:my-condition)) *package*))))))

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

(define-condition symbol-conflict (package-error) (symbols))

(define-condition use-conflict (symbol-conflict) (used-package) (:report (lambda (condition *standard-output*) (format t "Package ~a using ~a results in name conflicts for symbols:~%~{~s ~}" (package-name (use-conflict-package condition)) (package-name (use-conflict-used-package condition)) (use-conflict-symbols condition)))))

(define-condition export-conflict (symbol-conflict) (exported-symbols packages) (:report (lambda (condition *standard-output*) (format t "Exporting these symbols from the ~a package:~%~{~s ~}~%results in name conflicts with package(s):~%~{~a ~}~%" (package-name (export-conflict-package condition)) (export-conflict-symbols condition) (mapcar (function package-name) (export-conflict-packages condition))))))

(define-condition export-missing (package-error) (symbols) (:report (lambda (condition *standard-output*) (format t "These symbols aren't in package ~a; can't export them from it:~%~{~s ~}" (package-name (export-missing-package condition)) (export-missing-symbols condition)))))

(define-condition import-conflict (symbol-conflict) nil (:report (lambda (condition *standard-output*) (format t "Importing these symbols into package ~a causes a name conflict:~%~{~s ~}" (package-name (import-conflict-package condition)) (import-conflict-symbols condition)))))

(define-condition unintern-conflict (symbol-conflict) (symbol) (:report (lambda (condition *standard-output*) (format t "Uninterning symbol ~s causes a name conflict among these symbols:~%~{~s ~}" (unintern-conflict-symbol condition) (unintern-conflict-symbols condition)))))

(defun il:resolve-use-package-conflict (used-package symbols package) "Handle a conflict from use-package." (setq symbols (sort symbols (quote string<))) (let ((my-condition (make-condition (quote use-conflict) :package package :symbols symbols :used-package used-package))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (shadow-use-conflicts-proceed nil :filter filter :report (lambda (stream) (format stream "Shadow conflicting symbols from ~A in ~A" (package-name used-package) (package-name package))) (dolist (symbol symbols) (shadow symbol package))) (unintern-user-proceed nil :filter filter :report (lambda (stream) (format stream "Unintern all conflicting symbols from ~A (DANGEROUS)" (package-name package))) (dolist (symbol symbols) (il:moby-unintern symbol package))) (unintern-usee-proceed nil :filter filter :report (lambda (stream) (format stream "Unintern all conflicting symbols from ~A (VERY DANGEROUS)" (package-name used-package))) (dolist (symbol symbols) (il:moby-unintern (find-symbol (symbol-name symbol) used-package) used-package))) (abort nil :filter filter :report (lambda (stream) (format stream "Abort making package ~a use ~a" (package-name package) (package-name used-package))) (il:retfrom (quote use-package) nil))))))

(defun il:resolve-export-conflict (package symbols packages exported-symbols) "Handle a conflict raised by export." (il:setq symbols (sort symbols (quote string<))) (setq packages (sort packages (function (lambda (a b) (string< (package-name a) (package-name b)))))) (let ((my-condition (make-condition (quote export-conflict) :package package :symbols symbols :exported-symbols exported-symbols :packages packages))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (unintern-proceed nil :filter filter :report (lambda (stream) (format stream "Unintern all conflicting symbols in package~P~{ ~a~} (DANGEROUS)" (if (null (rest packages)) 0 1) (mapcar (function package-name) packages))) (dolist (package packages exported-symbols) (dolist (symbol symbols) (il:moby-unintern (find-symbol (symbol-name symbol) package) package)))) (abort nil :filter filter :report (lambda (stream) (format stream "Abort exporting the symbols from package ~a" (package-name package))) (il:retfrom (quote export) nil))))))

(defun il:resolve-export-missing (package symbols) "Handle missing symbols needed to export." (setq symbols (sort symbols (quote string<))) (let ((my-condition (quote export-missing) :package package :symbols symbols (make-condition))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (import-proceed nil :filter filter :report (lambda (stream) (format stream "Import missing symbols into ~A, then export them" package)) (import symbols package)) (abort nil :filter filter :report (lambda (stream) (format stream "Abort export from package ~A" package)) (il:retfrom (quote export) nil))))))

(defun il:resolve-import-conflict (package symbols) "Handle conflict signalled by import.  Returning from here does shadowing import." (setq symbols (sort symbols (quote string<))) (let ((my-condition (make-condition (quote import-conflict) :package package :symbols symbols))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (shadowing-import-proceed nil :filter filter :report (lambda (stream) (format stream "Import symbols into ~S with ~S instead" (package-name package) (quote shadowing-import))) nil) (abort nil :filter filter :report (lambda (stream) (format stream "Abort import into package ~S" (package-name package))) (il:retfrom (quote import) nil))))))

(defun il:resolve-unintern-conflict (symbol symbols package) "Handle a conflict noted by unintern." (setq symbols (sort symbols (quote string<))) (let ((my-condition (make-condition (quote unintern-conflict) :symbol symbol :symbols symbols :package package))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (shadowing-import-proceed (symbol-to-import) :filter filter :report (lambda (stream) (format stream "Choose symbol and ~S it to hide conflicts in package ~S" (quote shadowing-import) (package-name package))) :interactive (lambda nil (loop (let ((symbol (il:menu (il:create il:menu il:title il:_ "Choose symbol to shadowing-import" il:items il:_ symbols il:centerflg il:_ t)))) (when (member symbol symbols :test (function eq)) (return (list symbol)))))) (shadowing-import symbol-to-import package) (il:retfrom (quote il:resolve-unintern-conflict) t)) (abort nil :filter filter :report (lambda (stream) (format stream "Abort unintern of symbol ~s from package ~s" symbol (package-name package))) (il:retfrom (quote unintern) nil))))))

(define-condition symbol-colon-error (read-error) (name) (:report (lambda (condition *standard-output*) (format t "Invalid symbol syntax in \"~A\"" (symbol-colon-error-name condition)))))

(defun il:\\invalid.symbol (base len ncolons package extrasegments) (il:* il:|;;;| "Called when scanning a symbol that has more than 2 colons, or more than 1 non-consecutive colon.  If return from here, will read the symbol as though the extra colons were escaped.") (declare (special il:\\fatpnamestringp) (il:* il:\; "This ain't my fault, honest.")) (let ((my-condition (make-condition (quote symbol-colon-error) :name (il:concat (if (and package (not (eq package il:*keyword-package*))) (if (stringp package) package (package-name package)) "") (case ncolons (1 ":") (2 "::") (t "")) (il:\\getbasestring base 0 len il:\\fatpnamestringp))))) (restart-case (error my-condition) (escape-colons-proceed nil :filter (lambda nil (eq *current-condition* my-condition)) :report "Treat the extra colon(s) as if they were escaped" 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) (quote 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 (quote ((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 (lisp::%package-name il:object)) (il:nicknames (lisp::%package-nicknames il:object)) (il:use-list (lisp::%package-use-list il:object)) (il:internal-symbols (lisp::%package-internal-symbols il:object)) (il:external-symbols (lisp::%package-external-symbols il:object)) (il:shadowing-symbols (lisp::%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 (quote ((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 (lisp::package-hashtable-size il:object)) (il:free (lisp::package-hashtable-free il:object)) (il:deleted (lisp::package-hashtable-deleted il:object)) (il:contents (lisp::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 (quote ((il:function lisp::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:* il:|;;| "Package's Prefix accessor and setfs (Edited by TT 14-June-90 for AR#11112)")



(defun package-prefix (package) (il:* il:\; "Edited by TT (14-June-90 : for AR#111122)") (lisp::%package-namesymbol (il:\\packagify package)))

(defun setf-package-prefix (package prefix) (il:* il:\; "Edited by TT (14-June-90 : for AR#111122)") (if (symbolp prefix) (setf (lisp::%package-namesymbol (il:\\packagify package)) prefix) (if (stringp prefix) (setf (lisp::%package-namesymbol (il:\\packagify package)) (intern prefix)) (error "~S must be symbol or string." prefix))))

(defsetf package-prefix setf-package-prefix)

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

(il:putprops il:cmlpackage il:makefile-environment
 (:readtable "XCL" :package "XCL"))
(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 ("Venue & Xerox Corporation" 1986 1987 1988 1990))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop