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

(filecreated "31-Oct-86 22:41:31" {eris}<lispcore>sources>cmldeffer.\;38
 27991  

      |changes| |to:|  (functions \\define-type-save-defn)

      |previous| |date:| "31-Oct-86 17:05:48" {eris}<lispcore>sources>cmldeffer.\;37)


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

(prettycomprint cmldeffercoms)

(rpaqq cmldeffercoms
 ((* |;;;| 
   "DEF-DEFINE-TYPE and DEFDEFINER -- Your One-Stop Providers of Customized File Manager Facilities."
                         )
                      (* |;;| "BE VERY CAREFUL CHANGING ANYTHING IN THIS FILE!!!  It is heavily self-referential and thick with bootstrapping problems.  All but the most trivial changes (and some of those) are very tricky to make without blowing yourself out of the water...  You have been warned."
                         )
                      (initvars (filepkgflg nil))
                      (* |;;| "The definer data structures and manipulation functions")
                      (variables *definition-hash-table*)
                      (functions pprint-definer remove-comments)
                      (variables *remove-interlisp-comments*)
                      (functions \\define-type-deldef \\define-type-getdef \\define-type-save-defn)
                      (* |;;| "Prototype definition facility")
                      (variables xcl::*definition-prototypes*)
                      (functions xcl::add-prototype-fn xcl::prototype-defn-types 
                             xcl::prototype-definers-for-type xcl::make-prototype)
                      (* |;;| "The groundwork for bootstrapping")
                      (define-types define-types functions variables)
                      (* |;;| "DefDefiner itself and friends")
                      (functions si::expansion-function si::macro-funcall)
                      (functions defdefiner \\delete-definer def-define-type without-filepkg)
                      (* |;;| "The most commonly-used definers")
                      (functions cl:defun definline defmacro)
                      (functions cl:defvar cl:defparameter cl:defconstant defglobalvar 
                             defglobalparameter)
                      (* |;;| "Don't note changes to these properties/variables")
                      (prop proptype macro-fn undefiners definer-for defined-by)
                      (* |;;| "Arrange for the correct compiler to be used.")
                      (prop filetype cmldeffer)))



(* |;;;| 
"DEF-DEFINE-TYPE and DEFDEFINER -- Your One-Stop Providers of Customized File Manager Facilities.")





(* |;;| 
"BE VERY CAREFUL CHANGING ANYTHING IN THIS FILE!!!  It is heavily self-referential and thick with bootstrapping problems.  All but the most trivial changes (and some of those) are very tricky to make without blowing yourself out of the water...  You have been warned."
)



(rpaq? filepkgflg
 nil)



(* |;;| "The definer data structures and manipulation functions")


(defglobalvar *definition-hash-table*
 (* |;;;| "This is the repository for all DEFDEFINERs' definitions.  It is a two-level hash-table.  The first level hashes on the name of the type of the definition, using an EQ test.  Each type maps to another hash-table that, in turn, maps the names of items into their definitions.  The second-level hash-tables use an EQUAL test so as to allow non-atomic ``names''."
                                         ) 
       (* |;;| 

            "HASHARRAY is used here instead of MAKE-HASH-ARRAY because it's earlier in the loadup...")

   (hasharray 20))

(cl:defun pprint-definer
 (define-expression)
   (cond
      ((cl:atom (cdr define-expression))
          (* \; "Handle the cases (defun) and (defun . foo)")

       (printout nil "(" |.P2| (car define-expression))
       (cl:unless (null (cdr define-expression))
              (printout nil " . ")
              (printdef (cdr define-expression)
                     t t))
       (prin1 ")" nil)
       nil)
      (t (let ((definer (|pop|
 define-expression))
               (defined (|pop|
 define-expression))
               (current (dspxposition))
               (\#rpars))
              (declare
 (specvars \#rpars))
              (printout nil "(" |.P2| definer \,)
              (|if|
 (listp defined)
                  |then|
 (printout nil "(" .font prettycomfont |.P2| (car defined)
                                .font defaultfont \, \# (printdef (cdr defined)
                                                               t t t)
                                ")")
                |else|
 (printout nil .font prettycomfont |.P2| defined .font defaultfont))
              (|if|
 (listp (car define-expression))
                  |then|
 (spaces 1)
                        (printdef (|pop|
 define-expression)
                               t nil))
              (|if|
 (or (stringp (car define-expression))
                        (eq (car (listp (car define-expression)))
                            commentflg))
                  |then|
 (spaces 1)
                        (printdef (|pop|
 define-expression)
                               t t))
              (|if|
 (not (fitp define-expression t t))
                  |then|
 (terpri)
                        (dspxposition current)
                        (spaces 3)
                |else|
 (spaces 1))
              (printdef define-expression t t t)
              (prin1 ")" nil)
              (terpri nil)))))

(cl:defun remove-comments
 (x) 
                    (* |;;;| 

                                        "Removes SEdit-style comments from the given list structure.")

   (cond
      ((nlistp x)
       x)
      ((and (eq (caar x)
                '*)
            (or (fmemb (cadar x)
                       '(\; |;;| |;;;|))
                     (* \; "a sedit comment")

                (eq *remove-interlisp-comments* t)
           (* \; "always strip")

                (progn (|if|
 (eq *remove-interlisp-comments* ':warn)
                           |then|
 (cl:warn "Possible comment not stripped ~S" x))
                       nil)))
       (remove-comments (cdr x)))
      (t (prog ((a (remove-comments (car x)))
                (d (remove-comments (cdr x))))
               (return (cond
                          ((and (eq a (car x))
                                (eq d (cdr x)))
                           x)
                          (t (cons a d))))))))

(cl:defvar *remove-interlisp-comments*
 ':warn 
                                         "Either NIL (don't) T (always do) or :WARN (don't and warn)"
   )

(cl:defun \\define-type-deldef
 (name type) 
       (* |;;| 

                                                 "DELETE definition of definer-defined NAME as TYPE ")

   (let* ((ht (cl:gethash type *definition-hash-table*)))
         (and ht (remhash name ht))
         (for
 fn in
 (get type 'undefiners) do
 (cl:funcall fn name))
         name))

(cl:defun \\define-type-getdef
 (name type options) 

                                                  (* |;;| "GETDEF method for all definers.  The EDIT is so that when you say EDITDEF you get a copy & can know when you made edits.")

   (let* ((cl:hash-table (cl:gethash type *definition-hash-table*))
          (defn (and cl:hash-table (cl:gethash name cl:hash-table))))
         (cl:if (eqmemb 'edit options)
                (cl:copy-tree defn)
                defn)))

(cl:defun \\define-type-save-defn
 (name type definition)
   (let ((cl:hash-table (cl:gethash type *definition-hash-table*)))
        (cl:when (null cl:hash-table)
               (cl:warn "Couldn't find a hash-table for ~S definitions.~%One will be created." type)
               (setq cl:hash-table (cl:setf (cl:gethash type *definition-hash-table*)
                                          (cl:make-hash-table :test 'cl:equal :size 50 :rehash-size 
                                                 50))))
        (let ((old-definition (cl:gethash name cl:hash-table)))
             (cl:unless (cl:equal definition old-definition)
                    (cl:when (and old-definition (neq dfnflg t))
                           (cl:format *terminal-io* "~&New ~A definition for ~S" type name))
                    (cl:setf (cl:gethash name cl:hash-table)
                           definition)
                    (markaschanged name type (cl:if old-definition 'changed 'defined))))))




(* |;;| "Prototype definition facility")


(defglobalvar xcl::*definition-prototypes*
 nil 
   (* |;;| "An association list mapping file-manager types to association lists from definer-names to prototype-functions")

)

(cl:defun xcl::add-prototype-fn
 (type cl::definer cl::prototype-fn)
   (let* ((cl::lookup-type (cl:assoc type xcl::*definition-prototypes*))
          (cl::lookup-definer (cl:assoc cl::definer (cdr cl::lookup-type))))

                                                  (* |;;| "If this definer didn't already have a PROTOTYPE-FN, add one.  If it already had one, change it to the new one.")

         (cl:if (null cl::lookup-definer)
                (cl:push (cons cl::definer cl::prototype-fn)
                       (cdr cl::lookup-type))
                (cl:setf (cdr cl::lookup-definer)
                       cl::prototype-fn))))

(cl:defun xcl::prototype-defn-types
 nil 
          (* |;;;| 

 "Return a list of the file-manager types for which some definer can provide a prototype definition.")

                                        (for
 x on
 xcl::*definition-prototypes*
                                           when
 (cadr x) collect
 (car x)))

(cl:defun xcl::prototype-definers-for-type
 (type) 
(* |;;;| "Return a list of the definers that claim to be able to provide a prototype definition of the given type.")

   (for
 x on
 (cl:getf xcl::*definition-prototypes* type) by
 cddr when
 (cadr x)
      collect
 (car x)))

(cl:defun xcl::make-prototype
 (cl::name type cl::definer) (let ((cl::prototype-fn (cl:getf
                                                                                   (cl:getf 
                                                                         xcl::*definition-prototypes* 
                                                                                          type)
                                                                                   cl::definer)))
                                                               (and cl::prototype-fn
                                                                    (cl:funcall cl::prototype-fn 
                                                                           cl::name type cl::definer)
                                                                    )))




(* |;;| "The groundwork for bootstrapping")


(def-define-type define-types
 "Definition type" )

(def-define-type functions
 "functions or macros" :undefiner cl:fmakunbound)

(def-define-type variables
 "Common Lisp variables" )




(* |;;| "DefDefiner itself and friends")


(cl:defun si::expansion-function
 (si::name si::arg-list si::body) 

                                                  (* |;;;| "Shared code between DEFMACRO and DEFDEFINER.  Takes the parts of a DEFMACRO and returns two values: a LAMBDA form for the expansion function, and the documentation string found, if any.")

   (cl:multiple-value-bind (si::parsed-body si::parsed-declarations si::parsed-docstring)
          (parse-defmacro si::arg-list 'si::$$macro-form si::body si::name nil :environment
                 'si::$$macro-environment)
          (cl:values `(cl:lambda (si::$$macro-form si::$$macro-environment)
                             ,@si::parsed-declarations
                             (cl:block ,si::name ,si::parsed-body)) si::parsed-docstring)))

(defmacro si::macro-funcall
 (si::expansion-function si::macro-call si::env) 

                                                  (* |;;;| "Used by DEFDEFINER as a mechanism for delaying macro-expansion until after checking the value of DFNFLG.  The arguments (unevaluated) are a macro-expansion function and a call on that macro.  The call to MACRO-FUNCALL should expand into the result of expanding the given macro-call.")

   (cl:funcall si::expansion-function si::macro-call si::env))

(defdefiner (defdefiner
 (:name (cl:lambda (cl::whole)
                                      (let ((cl::name (cl:second cl::whole)))
                                           (cl:if (cl:consp cl::name)
                                                  (car cl::name)
                                                  cl::name))))
                        (:prototype (cl:lambda (cl::name)
                                           (and (cl:symbolp cl::name)
                                                `(defdefiner (\\\,
 cl::name) "Type" ("Arg-list")
                                                                                    "Body")
)))
                        (:undefiner cl::\\delete-definer))
   functions
   (cl::name type cl::arg-list &body cl::body)
   (let*
    ((cl::options (cond
                     ((cl:consp cl::name)
                      (prog1 (cdr cl::name)
                             (cl:setq cl::name (car cl::name))))
                     (t nil)))
     (cl::name-fn 'cl:second)
     (cl::undefiner nil)
     (cl::prototype-fn nil))
    (for
 cl::opt-list in
 cl::options do
 (case (car cl::opt-list)
                                              ((:undefiner)
                                               (cl:setq cl::undefiner (cadr cl::opt-list)))
                                              ((:name)
                                               (cl:setq cl::name-fn (cadr cl::opt-list)))
                                              ((:prototype)
                                               (cl:setq cl::prototype-fn (cadr cl::opt-list)))
                                              (cl:otherwise (cl:cerror "Ignore the bogus option" 
                                                              "Unrecognized option to DefDefiner: ~S" 
                                                                   cl::opt-list))))
    (cl:multiple-value-bind
     (cl::expansion-fn cl::doc)
     (si::expansion-function cl::name cl::arg-list cl::body)
     `(progn (cl:setf (get ',cl::name 'definer-for)
                    ',type)
             (cl:pushnew ',cl::name (get ',type 'defined-by))
             (defmacro (\\\,
 cl::name) (&whole cl::original-macro-call &environment cl::env)
                (let* ((cl::macro-call-without-comments (remove-comments cl::original-macro-call))
                       (cl::defined-object-name (,cl::name-fn cl::macro-call-without-comments)))
                      `(progn (without-filepkg 
   (* |;;| "The ,#',FOO is really just like ,',FOO (which is used simply to get the evaluation of FOO to happen in the outer back-quote's context).  In this case, however, rather than simply preventing further evaluation (using QUOTE), we want to encourage the compiler to compile the LAMDA-expression that is the value of EXPANSION-FN.  Thus, we use #' instead of '.")

                                     (si::macro-funcall ,#',cl::expansion-fn ,
                                            cl::macro-call-without-comments ,cl::env))
                              (cl:eval-when (cl:eval)
                                     (cl:unless (null filepkgflg)
                                            (\\define-type-save-defn
                                             ',cl::defined-object-name
                                             ',',type
                                             ',cl::original-macro-call)))
                              ',cl::defined-object-name)))

             (cl:pushnew '(,cl::name . pprint-definer) prettyprintmacros :test 'equal)
             ,@(and cl::undefiner `((cl:pushnew ',cl::undefiner (get ',cl::name 'undefiners))))
             ,@(and cl::prototype-fn `((xcl::add-prototype-fn ',type ',cl::name
                                              (function ,cl::prototype-fn))))
             ,@(and cl::doc `((cl:setf (cl:documentation ',cl::name 'cl:function)
                                     ,cl::doc)))))))

(cl:defun \\delete-definer
 (name) (and (cl:symbolp name)
                                       (let ((type (get name 'definer-for)))
                                            (/remprop name 'definer-for)
                                            (cl:when type 

                                                   (* |;;| "need to remove the prototype function!")

                                                   (/putprop type 'defined-by
                                                          (remove name (get type 'defined-by)))))))

(defdefiner (def-define-type
 (:prototype (lambda (name)
                                           (and (cl:symbolp name)
                                                `(def-define-type (\\\,
 name) "Description string"
                                                    )
)))) define-types
     (name description &key undefiner &aux (changelst (cl:intern (cl:concatenate 'string "CHANGED"
                                                                        (string name)
                                                                        "LST")
                                                             (cl:symbol-package name))))
     "Define NAME as a new definition type"
       (* |;;| "This definition is a clean interface to a hokey implementation.  It works even before the file package is loaded.")

     `(progn (cl:setf (cl:documentation ',name 'define-types)
                    ',description)
             (cl:pushnew '(,name x (p *
 (mapcar 'x (function (lambda (item)
                                                               (cl:do
                                                                ((def (getdef item
                                                                             ',name)))
                                                                (def def)
                                                                (cl:cerror "Re-fetch the definition" 
                                                                       "No ~S definition for ~S"
                                                                       ',name item))))))) 
                    prettydefmacros :test 'equal)
 (* |;;| "the information about a type in the file package is split up into a number of different places. PRETTYTYPELST contains a random amount: the changelist is the variable whose top level value contains the list of changed items, and the description is a string used by files? This is duplicated in the CL:DOCUMENTATION mechanism")

             (cl:pushnew '(,changelst ,name ,description) prettytypelst :test 'equal)
             (defglobalvar (\\\,
 changelst) nil)

                                                  (* |;;| "the definition hash table is where the definitions are really stored. Create an entry for this type. Note that definitions are compared using CL:EQUAL so that names can be strings, lists, etc.")

             (cl:unless (cl:gethash ',name *definition-hash-table*)
                    (cl:setf (cl:gethash ',name *definition-hash-table*)
                           (cl:make-hash-table :test 'cl:equal :size 50 :rehash-size 50)))
             (cl:pushnew ',name filepkgtypes)
             (cl:setf (get ',name 'getdef)
                    '\\define-type-getdef)
             (cl:setf (get ',name 'deldef)
                    '\\define-type-deldef)
             (cl:setf (get ',name 'filepkgcontents)
                    'nill)
             (cl:pushnew (cons ',name nil)
                    xcl::*definition-prototypes* :key 'car)
             ,@(cl:when undefiner `((cl:pushnew ',undefiner (get ',name 'undefiners))))))

(defmacro without-filepkg
 (&body body) `(progn (cl:eval-when (cl:load)
                                                      ,@body)
                                               (cl:eval-when (cl:eval)
                                                      (cl:unless (or (eq dfnflg 'prop)
                                                                     (eq dfnflg 'allprop))
                                                             (let (filepkgflg (dfnflg t))
                                                                  ,@body)))))




(* |;;| "The most commonly-used definers")


(defdefiner (cl:defun
 (:prototype (cl:lambda (cl::name)
                                         (and (cl:symbolp cl::name)
                                              `(cl:defun (\\\,
 cl::name) ("Arg List") "Body" )
)))) functions (cl::name cl::args &body (cl::body cl::decls cl:documentation))
           `(progn (cl:setf (cl:symbol-function ',cl::name)
                          #'(cl:lambda ,cl::args ,@cl::decls (cl:block ,cl::name ,@cl::body)))
                   ,@(and cl:documentation `((cl:setf (cl:documentation ',cl::name 'cl:function)
                                                    ,cl:documentation)))))

(defdefiner (definline
 (:prototype (lambda (name)
                                     (and (cl:symbolp name)
                                          `(definline (\\\,
 name) ("Arg List") "Body" )
)))) functions (name arglist &body body &environment env)

                                                  (* |;;;| "This is an INTERIM version of DEFINLINE.  Eventually, this will just turn into a DEFUN and a PROCLAIM INLINE.  (It says so right here.)  If you're using this one, DO NOT make any recursive calls in the body of the DEFINLINE.  If you do, the compiler will run forever trying to expand the optimizer...  Once the INLINE version gets working (in the PavCompiler only) that restriction will be lifted.")

           (cl:multiple-value-bind (code decls doc)
                  (parse-body body env t)
                  (let ((new-lambda `(cl:lambda ,arglist ,@decls (cl:block ,name ,@code))))
                       `(progn (cl:defun (\\\,
 name) ,arglist ,@body)

                               (defoptimizer ,name ,(xcl:pack (list "definline-" name)
                                                           (cl:symbol-package name)) (&rest args)
                                      (cons ',new-lambda args))))))

(defdefiner (defmacro
 (:prototype (cl:lambda (cl::name)
                                         (and (cl:symbolp cl::name)
                                              `(defmacro (\\\,
 cl::name) (cl::arg-list) "Body" )
)))) functions (name defmacro-args &body defmacro-body)

                                                  (* |;;| "The EVAL-WHEN below should be a PROGN as soon as the old ByteCompiler/COMPILE-FILE hack is done away with.  The PavCompiler understands DEFMACRO's correctly and doesn't side-effect the environment.")

           (cl:unless (and name (cl:symbolp name))
                  (cl:error "Illegal name used in DEFMACRO: ~S" name))
           (let ((cmacroname (xcl:pack (list "expand-" name)
                                    (cl:symbol-package name))))
                (cl:multiple-value-bind
                 (expansion-fn doc-string)
                 (si::expansion-function name defmacro-args defmacro-body)
                 `(cl:eval-when (cl:eval cl:compile cl:load)
                         (cl:setf (cl:symbol-function ',cmacroname)
                                #',expansion-fn)
                         (cl:setf (cl:macro-function ',name)
                                ',cmacroname)
                         ,@(and doc-string `((cl:setf (cl:documentation ',name 'cl:function)
                                                    ,doc-string)))))))

(defdefiner (cl:defvar
 (:prototype (cl:lambda (cl::name)
                                          (and (cl:symbolp cl::name)
                                               `(cl:defvar (\\\,
 cl::name) )
)))) variables (cl::name &optional (cl::initial-value nil cl::ivp)
                      cl:documentation)
           `(progn (cl:proclaim '(cl:special ,cl::name))
                   ,@(and cl::ivp `((or (boundp ',cl::name)
                                        (setq ,cl::name ,cl::initial-value))))
                   ,@(and cl:documentation `((cl:setf (cl:documentation ',cl::name 'cl::variable)
                                                    ,cl:documentation)))))

(defdefiner (cl:defparameter
 (:prototype (cl:lambda (cl::name)
                                                (and (cl:symbolp cl::name)
                                                     `(cl:defparameter (\\\,
 cl::name) "Value" 
                                                                               "Documentation string")
)))) variables (cl::name cl::initial-value &optional cl:documentation)
           `(progn (cl:proclaim '(cl:special ,cl::name))
                   (setq ,cl::name ,cl::initial-value)
                   ,@(and cl:documentation `((cl:setf (cl:documentation ',cl::name 'cl::variable)
                                                    ,cl:documentation)))))

(defdefiner (cl:defconstant
 (:prototype (cl:lambda (cl::name)
                                               (and (cl:symbolp cl::name)
                                                    `(cl:defconstant (\\\,
 cl::name) "Value" 
                                                                               "Documentation string")
)))) variables (cl::name cl::value &optional cl:documentation)
           `(progn (setq ,cl::name ,cl::value)
                   (puthash ',cl::name '(constant ,cl::name) compvarmacrohash)
                   ,@(and cl:documentation `((cl:setf (cl:documentation ',cl::name 'cl::variable)
                                                    ,cl:documentation)))))

(defdefiner (defglobalvar
 (:prototype (cl:lambda (cl::name)
                                             (and (cl:symbolp cl::name)
                                                  `(defglobalvar (\\\,
 cl::name) )
)))) variables (cl::name &optional (cl::initial-value nil cl::ivp)
                      cl:documentation)
           `(progn (cl:proclaim '(global ,cl::name))
                   ,@(and cl::ivp `((or (boundp ',cl::name)
                                        (setq ,cl::name ,cl::initial-value))))
                   ,@(and cl:documentation `((cl:setf (cl:documentation ',cl::name 'cl::variable)
                                                    ,cl:documentation)))))

(defdefiner (defglobalparameter
 (:prototype (cl:lambda (cl::name)
                                                   (and (cl:symbolp cl::name)
                                                        `(defglobalparameter (\\\,
 cl::name) "Value"
                                                            "Documentation string")
)))) variables (cl::name cl::initial-value &optional cl:documentation)
           `(progn (cl:proclaim '(global ,cl::name))
                   (setq ,cl::name ,cl::initial-value)
                   ,@(and cl:documentation `((cl:setf (cl:documentation ',cl::name 'cl::variable)
                                                    ,cl:documentation)))))




(* |;;| "Don't note changes to these properties/variables")



(putprops macro-fn proptype
 functions)

(putprops undefiners proptype
 ignore)

(putprops definer-for proptype
 ignore)

(putprops defined-by proptype
 ignore)



(* |;;| "Arrange for the correct compiler to be used.")



(putprops cmldeffer filetype
 cl:compile-file)
(putprops cmldeffer copyright ("Xerox Corporation" 1986 1900))
(declare\: dontcopy
  (filemap (nil)))
stop