(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "25-Jan-98 14:36:09" ("compiled on " |{DSK}<lispcore>sources>INSPECT-CLOSURE.;1|) 
"30-Mar-95 20:33:04" |bcompl'd| |in| "Medley 14-Aug-95 ..." |dated| "14-Aug-95 15:27:48")
(FILECREATED "16-May-90 18:23:44" |{DSK}<usr>local>lde>lispcore>sources>INSPECT-CLOSURE.;2| 5126 
|changes| |to:| (VARS INSPECT-CLOSURECOMS) |previous| |date:| " 3-Feb-88 15:15:04" 
|{DSK}<usr>local>lde>lispcore>sources>INSPECT-CLOSURE.;1|)
(PRETTYCOMPRINT INSPECT-CLOSURECOMS)
(RPAQQ INSPECT-CLOSURECOMS ((* |;;;| "A nicer inspector for lexical closures.") (FUNCTIONS 
INSPECT-CLOSURE CLOSURE-PROPERTIES CLOSURE-FETCHFN CLOSURE-STOREFN) (ADDVARS (INSPECTMACROS ((FUNCTION
 CLOSURE-P) . INSPECT-CLOSURE)))))
(CL:DEFUN INSPECT-CLOSURE (CLOSURE TYPE WHERE) (INSPECTW.CREATE CLOSURE (CLOSURE-PROPERTIES CLOSURE) (
QUOTE CLOSURE-FETCHFN) (QUOTE CLOSURE-STOREFN) NIL NIL NIL NIL NIL NIL (CL:FUNCTION (CL:LAMBDA (PROP 
DATUM) (CL:IF (NULL (CDR PROP)) NIL (CAR PROP))))))
(CL:DEFUN CLOSURE-PROPERTIES (CLOSURE) "Make up a property description for a closure." (* |;;| 
"Does not list fields that aren't present in the closure.  Tags the fields present with a dummy field, which the inspect module is kind enough to provide."
) (LIST* (QUOTE ("function" FUNCTION)) (* \; "The function in the closure.") (CL:MAPCAN (* \; 
"Here we compute the properties from the environment.") (CL:FUNCTION (CL:LAMBDA (SUB-ENV-NAME 
SUB-ENV-GET &OPTIONAL (SUB-ENV (CL:FUNCALL SUB-ENV-GET (CLOSURE-ENVIRONMENT CLOSURE)))) (CL:WHEN 
SUB-ENV (* \; "Only display if there's something in this part of the environment.") (LIST* (BQUOTE ((
\\\, (CL:STRING-DOWNCASE (CL:SYMBOL-NAME SUB-ENV-NAME))))) (* \; "Dummy field printed in middle.") (
CL:DO ((PLIST SUB-ENV (CDDR PLIST)) (PROP-SPECS NIL)) ((NULL PLIST) PROP-SPECS) (CL:PUSH (BQUOTE ((
\\\, (CL:FIRST PLIST)) (\\\, SUB-ENV-NAME))) PROP-SPECS)))))) (QUOTE (VARS FUNCTIONS BLOCKS TAGBODIES)
) (QUOTE (ENVIRONMENT-VARS ENVIRONMENT-FUNCTIONS ENVIRONMENT-BLOCKS ENVIRONMENT-TAGBODIES)))))
(CL:DEFUN CLOSURE-FETCHFN (CLOSURE PROP) (COND ((NULL (CDR PROP)) (CAR PROP)) ((EQ (CADR PROP) (QUOTE 
FUNCTION)) (CLOSURE-FUNCTION CLOSURE)) (T (LET (ACCESSOR) (CL:IF (SETQ ACCESSOR (CDR (CL:ASSOC (CADR 
PROP) (QUOTE ((VARS . ENVIRONMENT-VARS) (FUNCTIONS . ENVIRONMENT-FUNCTIONS) (BLOCKS . 
ENVIRONMENT-BLOCKS) (TAGBODIES . ENVIRONMENT-TAGBODIES))) :TEST (QUOTE EQ)))) (CL:GETF (CL:FUNCALL 
ACCESSOR (CLOSURE-ENVIRONMENT CLOSURE)) (CAR PROP)))))))
(CL:DEFUN CLOSURE-STOREFN (CLOSURE PROP VALUE) (COND ((NULL (CDR PROP)) NIL) ((EQ (CADR PROP) (QUOTE 
FUNCTION)) (CL:SETF (CLOSURE-FUNCTION CLOSURE) VALUE)) (T (LET (ACCESSOR) (CL:IF (SETQ ACCESSOR (CDR (
CL:ASSOC (CADR PROP) (QUOTE ((VARS . ENVIRONMENT-VARS) (FUNCTIONS . ENVIRONMENT-FUNCTIONS) (BLOCKS . 
ENVIRONMENT-BLOCKS) (TAGBODIES . ENVIRONMENT-TAGBODIES))) :TEST (QUOTE EQ)))) (LET ((PLIST (CL:FUNCALL
 ACCESSOR (CLOSURE-ENVIRONMENT CLOSURE)))) (CL:SETF (CL:GETF PLIST (CAR PROP)) VALUE)))))))
(ADDTOVAR INSPECTMACROS ((FUNCTION CLOSURE-P) . INSPECT-CLOSURE))
(PUTPROPS INSPECT-CLOSURE COPYRIGHT ("Venue & Xerox Corporation" 1988 1990))
NIL