(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 8-Oct-87 09:51:53" |{POGO:AISNORTH:XEROX}<CUTTING>LISP>FILEPKG-PATCH.;2| 18405
previous date%: " 6-Oct-87 16:17:44" |{POGO:AISNORTH:XEROX}<CUTTING>LISP>FILEPKG-PATCH.;1|)
(* "
Copyright (c) 1987 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT FILEPKG-PATCHCOMS)
(RPAQQ FILEPKG-PATCHCOMS ((* ;;; "patches to Lyric FILEPKG to make things work with the new WHERE-IS") (* ;;; "make this file by:") (* ;; " (loadvars 'filepkg-patchcoms 'filepkg-patch)") (* ;; " (loadfns (filefnslst 'filepkg-patch) '{eris}<lispcore>sources>filepkg 'prop)") (* ;; " (makefile 'filepkg-patch 'new)") (* ;;; "compile with:") (* ;; " (brecompile 'filepkg-patch '{eris}<lispcore>sources>filepkg.lcom)") (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) FILEPKG)) (FNS WHEREIS HASDEF EDITDEF DEFAULT.EDITDEF TYPESOF GETDEFSAVED INFILECOMS? INFILECOMTAIL) (BLOCKS (INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG) INFILECOMSPROP) (GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE GETDEFSAVED (RETFNS GETDEFCOM) (NOLINKFNS . T) (GLOBALVARS NOT-FOUNDTAG))))
)
(* ;;; "patches to Lyric FILEPKG to make things work with the new WHERE-IS")
(* ;;; "make this file by:")
(* ;; " (loadvars 'filepkg-patchcoms 'filepkg-patch)")
(* ;; " (loadfns (filefnslst 'filepkg-patch) '{eris}<lispcore>sources>filepkg 'prop)")
(* ;; " (makefile 'filepkg-patch 'new)")
(* ;;; "compile with:")
(* ;; " (brecompile 'filepkg-patch '{eris}<lispcore>sources>filepkg.lcom)")
(DECLARE%: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP) FILEPKG)
)
(DEFINEQ
(WHEREIS
[LAMBDA (NAME TYPE FILES FN) (* ; "Edited 24-Jul-87 10:44 by cutting")
(COND
((EQ NAME T) (* ;
"T as a NAME has a special meaning to INFILECOMS? so don't pass through.")
NIL)
(FN (* ;
"TYPE is coerced by the innards of INFILECOMS?")
(for FILE in (OR (LISTP FILES)
FILELST) when (INFILECOMS? NAME TYPE (FILECOMS FILE))
do (APPLY* FN NAME FILE)))
(T (UNION [SUBSET (OR (LISTP FILES)
FILELST)
(FUNCTION (LAMBDA (FILE)
(INFILECOMS? NAME TYPE (FILECOMS FILE]
(CL:IF (AND (EQ FILES T)
(CL:FBOUNDP 'XCL::HASH-FILE-WHERE-IS))
(CL:MAPCAR #'(CL:LAMBDA (FILE-NAME)
(MKATOM (U-CASE FILE-NAME))) (XCL::HASH-FILE-WHERE-IS
NAME
(GETFILEPKGTYPE TYPE])
(HASDEF
[LAMBDA (NAME TYPE SOURCE SPELLFLG) (* ; "Edited 31-Aug-87 18:02 by drc:")
(* ;; "is NAME the name of something of type TYPE? NIL SOURCE means 0, not ?")
(DECLARE (SPECVARS TYPE))
(COND
[[OR (LISTP TYPE)
(LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE] (* ; "ignore SPELLFLG")
(for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE))
(RETURN $$VAL]
(T
(PROG [(NODEF (fetch NULLDEF of TYPE))
(OPTS '(NODWIM NOCOPY NOERROR HASDEF]
(COND
((NULL SOURCE)
(SETQQ SOURCE CURRENT)))
(RETURN
(SELECTQ SOURCE
((CURRENT 0)
[COND
([OR
(MEMBER NAME (fetch CHANGED of TYPE))
(LET ((TM (fetch HASDEF of TYPE)))
(COND
(TM (APPLY* TM NAME TYPE SOURCE))
[(NOT (LITATOM NAME))
(SELECTQ TYPE
(PROPS (AND (LISTP NAME)
(GETPROP (CAR NAME)
(CADR NAME))))
((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS
FIELDS USERMACROS FILEVARS FILEPKGCOMS)
NIL)
(NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
(T
(* ;; "symbol definitions")
(SELECTQ TYPE
(FILES (LET ((SYMBOL (CL:FIND-SYMBOL (CONCAT NAME "COMS")
"INTERLISP")))
(AND SYMBOL (BOUNDP SYMBOL))))
(TEMPLATES (GETTEMPLATE NAME))
(MACROS (GETLIS NAME MACROPROPS))
(LISPXMACROS (OR (FASSOC NAME LISPXMACROS)
(FASSOC NAME LISPXHISTORYMACROS)))
(VARS (AND (NOT (CL:KEYWORDP NAME))
(NEQ (GETTOPVAL NAME)
'NOBIND)))
(RECORDS (RECLOOK NAME))
(I.S.OPRS [PROG [(TEM (GETPROP NAME 'CLISPWORD]
(RETURN (AND TEM (EQ (CAR TEM)
'FORWORD)
(GETPROP (CDR TEM)
'I.S.OPR])
(FNS (AND (OR (AND (GETD NAME)
(EXPRP (GETD NAME)))
(GET NAME 'EXPR))
(NOT (HASDEF NAME 'FUNCTIONS SOURCE))))
(FIELDS (RECORDFIELD? NAME))
(USERMACROS (FASSOC NAME USERMACROS))
(FILEVARS)
((PROPS ALISTS DEFS EXPRESSIONS)
NIL)
(FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST)
(FMEMB NAME FILEPKGTYPES)))
(NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
(OR NAME T))
(SPELLFLG (CL:WHEN (CL:SYMBOLP NAME)
(FIXSPELL NAME NIL
(SELECTQ TYPE
(FILES FILELST)
(FILEPKGCOMS (UNION FILEPKGCOMSPLST
FILEPKGTYPES))
(FIELDS (for X in USERRECLST
join (APPEND (RECORDFIELDNAMES
X))))
(RECORDS (for X in USERRECLST
when (LITATOM (CADR X))
collect (CADR X)))
(LISPXMACROS LISPXCOMS)
(I.S.OPRS I.S.OPRLST)
(USERMACROS (MAPCAR USERMACROS
(FUNCTION CAR)))
USERWORDS)
NIL
(LISTP SPELLFLG)
[FUNCTION (LAMBDA (X)
(HASDEF X TYPE 'CURRENT]
NIL T])
(? (OR (HASDEF NAME TYPE 'CURRENT)
(AND (LITATOM NAME)
(HASDEF NAME TYPE 'SAVED SPELLFLG))
(WHEREIS NAME TYPE T)))
((SAVED T)
(NEQ NODEF (GETDEF NAME TYPE 'SAVED OPTS)))
(NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS])
(EDITDEF
[LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)
(DECLARE (LOCALVARS . T)
(SPECVARS SOURCE)) (* ; "Edited 27-Jul-87 11:04 by cutting")
(* ;; "lets you edit anything. Given name and type, call editor on the definition (loading it in from SOURCE if necessary). If you change it, then the definition gets unsaved. OPTIONS is passed through from ED to the editor.")
(SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
(COND
((AND (fetch EDITDEF of TYPE)
(APPLY* (fetch EDITDEF of TYPE)
NAME TYPE SOURCE EDITCOMS OPTIONS)))
((AND (EQ TYPE 'FNS)
(NULL SOURCE)) (* ;
"special hack for EDITDEF of FNS because of ability to EDITLOADFNS")
(EDITDEF.FNS NAME EDITCOMS OPTIONS))
(T (DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS)))
NAME])
(DEFAULT.EDITDEF
[LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS) (* ; "Edited 27-Aug-87 15:22 by cutting")
(PROG [(DEF (COND
[SOURCE (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY]
[(GETDEF NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR]
[(GETDEF NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR]
(T (LET ((FILES (WHEREIS NAME TYPE T)))
(CL:IF (NULL FILES)
(CL:FORMAT T "~S has no ~S definition.~%%" NAME TYPE)
(LET [(FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%%"
NAME FILES)
(CL:IF (CL:ENDP (CDR FILES))
(CL:IF (CL:Y-OR-N-P
"Shall I load this file PROP? "
)
(CAR FILES))
(ASKUSER NIL NIL
"indicate which file to load PROP: "
(MAKEKEYLST FILES)
T]
(CL:WHEN FILE (LOAD FILE 'PROP)
(GETDEF NAME TYPE '? '(EDIT NOCOPY]
(* ;; "the EDIT option says to return a COPY if editing this structure isn't enough, and some installation is necessary.")
(DECLARE (SPECVARS RETRY))
(* ;; "what is RETRY ???")
(SETQ RETRY)
(CL:WHEN DEF (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG)
(* ;
"this function is called when there were changes made")
(MARKASCHANGED NAME TYPE
'CHANGED)
(PUTDEF NAME TYPE DEF]
OPTIONS])
(TYPESOF
(LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE FILTER) (* ; "Edited 8-Oct-87 09:38 by drc:") (* ;; "return list of all known types which NAME names") (LET* ((FILTERED-POSSIBLE-TYPES (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES) when (AND (LITATOM TYPE) (NOT (EQMEMB TYPE IMPOSSIBLETYPES)) (OR (NULL FILTER) (CL:FUNCALL FILTER TYPE))) collect TYPE)) (IN-CORE-TYPES (for TYPE IN FILTERED-POSSIBLE-TYPES when (SELECTQ SOURCE ((? NIL) (OR (HASDEF NAME TYPE (QUOTE CURRENT)) (CL:IF (LITATOM NAME) (HASDEF NAME TYPE (QUOTE SAVED))) (CL:IF (fetch CANFILEDEF of TYPE) (WHEREIS NAME TYPE)))) (HASDEF NAME TYPE SOURCE)) collect TYPE)) (HASH-FILE-TYPES (CL:UNLESS (CL:EQUAL IN-CORE-TYPES FILTERED-POSSIBLE-TYPES) (* ;; "if we're not going to find anything new in the hash file, don't bother looking.") (SELECTQ SOURCE ((? NIL) (CL:WHEN (CL:FBOUNDP (QUOTE XCL::HASH-FILE-TYPES-OF)) (* ;; "go look in hash file") (XCL::HASH-FILE-TYPES-OF NAME FILTERED-POSSIBLE-TYPES))) (QUOTE NIL)))) (TYPES (UNION IN-CORE-TYPES HASH-FILE-TYPES))) (for X in SHADOW-TYPES when (FMEMB (CAR X) TYPES) do (SETQ TYPES (LDIFFERENCE TYPES (CDR X)))) TYPES))
)
(GETDEFSAVED
[LAMBDA (NAME TYPE OPTIONS) (* ; "Edited 11-Aug-87 18:14 by cutting")
(* ;
"Gets the `saved' definition--source=T")
(SELECTQ TYPE
(FNS (OR (GETPROP NAME 'EXPR)
(GETDEFERR NAME TYPE OPTIONS "no saved definition for")))
(VARS (* ;
"The value of a variable is never substituted into and never COPIED")
(for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X)
'VALUE)
do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS
"no saved value for "))))
(OR (CDR (SASSOC NAME (FASSOC TYPE SAVEDDEFS)))
(GETDEFERR NAME TYPE OPTIONS "no saved definition for "])
(INFILECOMS?
[LAMBDA (NAME TYPE COMS ONFILETYPE) (* ; "Edited 6-Oct-87 15:46 by drc:")
(* ;; "Returns T if NAME is 'CONTAINED' in COMS. If NAME is NIL, then value is a list of all of the functions contained in COMS. If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL (this feature is used for deciding whether or not (and how) to compile files.) Called by FILEFNSLST (which is used by BRECOMPILE) and by NEWFILE1. while elements are the subset of NAME which are on the file in other case")
(* ;; "if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS? returns the dotted pair of (literals . elements) where literals are those which are `literally' on the file (e.g. (VARS (X 3))) --- if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on the file literally and which are not subparts of other types are returned")
(PROG (VAL LITERALS ORIGFLG)
(SETQ TYPE (GETFILEPKGTYPE TYPE))
(SELECTQ ONFILETYPE
(EDIT (SELECTQ TYPE
(FILEVARS (RETURN))
NIL))
NIL)
[COND
((LITATOM COMS)
(SELECTQ TYPE
((VARS FILEVARS) (* ; "the COMS of a file are also on it")
(INFILECOMSVAL COMS))
NIL)
(SETQ COMS (EVALV COMS]
(INFILECOMS COMS)
(SETQ VAL (DREVERSE VAL))
(RETURN (COND
((EQ ONFILETYPE 'UPDATE)
(CONS LITERALS VAL))
(T VAL])
(INFILECOMTAIL
[LAMBDA (COM FLG) (* ; "Edited 6-Oct-87 15:46 by drc:")
[SETQ COM (COND
((EQ (CADR COM)
'*)
(COND
[(LITATOM (CADDR COM))
(LISTP (EVALV (CADDR COM]
(T [RESETVARS (DWIMLOADFNSFLG)
(NLSETQ (SETQ COM (EVAL (CADDR COM]
COM)))
(T (CDR COM]
(if (NOT FLG)
then [SUBSET COM (FUNCTION (LAMBDA (X)
(OR (NLISTP X)
(NEQ (CAR X)
COMMENTFLG]
else COM])
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK%: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG) INFILECOMSPROP)
(BLOCK%: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE GETDEFSAVED (RETFNS GETDEFCOM) (NOLINKFNS . T) (GLOBALVARS NOT-FOUNDTAG))
)
(PUTPROPS FILEPKG-PATCH COPYRIGHT ("Xerox Corporation" 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1870 17861 (WHEREIS 1880 . 3221) (HASDEF 3223 . 9649) (EDITDEF 9651 . 10647) (
DEFAULT.EDITDEF 10649 . 13125) (TYPESOF 13127 . 14271) (GETDEFSAVED 14273 . 15351) (INFILECOMS? 15353
. 17093) (INFILECOMTAIL 17095 . 17859)))))
STOP