(FILECREATED "21-Feb-86 18:21:59" {ERIS}<LISPCORE>SOURCES>ADVISE.;5 16123
changes to: (VARS ADVISECOMS ADVISETEMPLATE)
(FNS ADDRULE ADVISE)
previous date: "14-Aug-84 19:27:31" {ERIS}<LISPCORE>SOURCES>ADVISE.;1)
(* Copyright (c) 1978, 1984, 1986 by Xerox Corporation. All rights reserved. The following program was
created in 1978 but has not been published within the meaning of the copyright law, is furnished
under license, and may not be used, copied and/or disclosed except in accordance with the terms of
said license.)
(PRETTYCOMPRINT ADVISECOMS)
(RPAQQ ADVISECOMS ((FNS ADVISE ADVISE1 UNADVISE ADVISEDUMP READVISE READVISE0 READVISE1 ADDRULE
CADVICE)
(INITVARS (ADVISEDFNS)
(ADVINFOLST))
(VARS (ADVISETEMPLATE (QUOTE (ADV-PROG (!VALUE)
(ADV-SETQ !VALUE (ADV-PROG NIL
(ADV-RETURN DEF)))
(ADV-RETURN !VALUE)))))
(P (MAP2C (QUOTE (PROG SETQ RETURN))
(QUOTE (ADV-PROG ADV-SETQ ADV-RETURN))
(FUNCTION MOVD)))
(GLOBALVARS ADVISEDFNS BROKENFNS ADVINFOLST DWIMFLG USERWORDS FILEPKGFLG
ADVISETEMPLATE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA READVISE UNADVISE)
(NLAML)
(LAMA)))))
(DEFINEQ
(ADVISE
(LAMBDA (FN WHEN WHERE WHAT) (* lmm
"21-Feb-86 17:57")
(PROG (X Y D)
TOP (COND
((NLISTP FN)
(SETQ FN (FNCHECK FN)))
((EQ (CADR FN)
(QUOTE IN))
(SETQ Y (CADDR FN))
(RETURN (COND
((NLISTP (SETQ X (CAR FN)))
(COND
((NLISTP Y)
(ADVISE1 X Y))
(T (MAPCAR Y (FUNCTION (LAMBDA (Y)
(ADVISE1 X Y T)))))))
((NLISTP Y)
(MAPCAR X (FUNCTION (LAMBDA (X)
(ADVISE1 X Y T)))))
(T (MAPCONC X (FUNCTION (LAMBDA (X)
(MAPCAR Y (FUNCTION (LAMBDA (Y)
(ADVISE1 X Y T))))))))))
)
(T (RETURN (MAPCAR FN (FUNCTION (LAMBDA (X)
(ADVISE X (COPY WHEN)
(COPY WHERE)
(COPY WHAT))))))))
(COND
((OR WHAT (NULL WHEN))
(* E.g. ADVISE (FOO), the simplest form, means just set up function for
advising and exit, or ADVISE (FOO BEFORE/AFTER where ADVICE) the full
form.)
NIL)
((NULL WHERE) (* E.g. ADVISE
(FOO advice) equivalent
to ADVISE (FOO BEFORE
NIL advice))
(SETQ WHAT WHEN)
(SETQ WHEN (QUOTE BEFORE)))
(T (* E.g. ADVISE
(FOO AFTER advice)
equivalent to ADVISE
(FOO AFTER NIL advice))
(SETQ WHAT WHERE)
(SETQ WHERE NIL)))
(RESTORE FN (QUOTE BROKEN))
(COND
((NULL (SETQ D (GETD FN)))
(HELP (CONS FN (QUOTE (NOT DEFINED)))))
((OR (NULL (EXPRP D))
(NULL (GETP FN (QUOTE ADVISED))))
(SETQ Y (SAVED FN (QUOTE ADVISED)
D))
(/PUTD FN (LIST (CAR Y)
(CADR Y)
(SETQ Y (SUBPAIR (QUOTE (DEF))
(LIST (COND
((CDR (SETQ Y (CDDR Y)))
(CONS (QUOTE PROGN)
Y))
(T (CAR Y))))
(COPY ADVISETEMPLATE))))) (* The SUBPAIR is so
that DEF is not copied.)
)
(T (SETQ Y (CADDR D))))
(/SETATOMVAL (QUOTE ADVISEDFNS)
(CONS FN (/DREMOVE FN ADVISEDFNS))) (* So FN is moved to
the front of ADVISEDFNS
if it is already there.)
(SETQ X WHEN)
LP (SELECTQ X
(NIL (* E.g. ADVISE
(FOO) means set up
advising and return.)
(RETURN FN))
(BEFORE (SETQ Y (CDDR (CADDR (CADDR Y)))))
(AFTER (SETQ Y (CDDDR Y)))
(AROUND (SETQ Y (CAR (LAST (CADDR (CADDR Y)))))
(COND
((NEQ (CAR Y)
(QUOTE ADV-RETURN))
(GO ERROR)))
(/RPLACA (CDR Y)
(SUBPAIR (QUOTE (*))
(LIST (CADR Y))
WHAT))
(GO EXIT))
(BIND (/NCONC (CADR Y)
(COND
((NLISTP WHAT)
(LIST WHAT))
(T (APPEND WHAT))))
(GO EXIT))
(GO ERROR))
(COND
((NULL WHERE) (* Most common case.)
(/ATTACH WHAT (FLAST Y)))
(T (ADDRULE Y WHAT WHERE T)))
EXIT
(/ADDPROP FN (QUOTE ADVICE)
(LIST WHEN WHERE WHAT))
(AND FILEPKGFLG (MARKASCHANGED FN (QUOTE ADVICE)))
(RETURN FN)
ERROR
(ERROR (LIST (QUOTE ADVISE)
WHEN
(QUOTE ?))))))
(ADVISE1
[LAMBDA (X Y FLG)
(PROG (Z)
(COND
([NOT (ATOM (SETQ Z (CHNGNM Y (FNCHECK X NIL T]
(* CHNGNM checks to see if name already changed, so that
user can always ADVISE with either atomic or list form
for aliases.)
(RETURN Z))
(FLG (* Will be done more than once.)
(ADVISE Z (COPY WHEN)
(COPY WHERE)
(COPY WHAT)))
(T (ADVISE Z WHEN WHERE WHAT)))
(RETURN Z])
(UNADVISE
[NLAMBDA X (* lmm "14-Aug-84 19:15")
(COND
[(EQ (CAR (SETQ X (NLAMBDA.ARGS X)))
T) (* Just UNADVISE last function.)
(SETQ X (LIST (CAR ADVISEDFNS]
((NULL X)
(SETQ X (REVERSE ADVISEDFNS))
(/SETATOMVAL (QUOTE ADVISEDFNS)
NIL)
(/SETATOMVAL (QUOTE ADVINFOLST)
NIL)))
(MAPCONC X (FUNCTION (LAMBDA (FN)
(MAPCAR (PACK-IN- FN)
(FUNCTION (LAMBDA (FN)
(PROG [(ADVICE (GETP FN (QUOTE ADVICE)))
(ALIAS (GETP FN (QUOTE ALIAS)))
(READVICE (GETP FN (QUOTE READVICE]
[COND
((AND DWIMFLG (NULL (FMEMB FN ADVISEDFNS))
(NULL (FNTYP FN)))
(SETQ FN (OR (FIXSPELL FN 70 ADVISEDFNS)
(FIXSPELL FN 70 USERWORDS NIL NIL
(FUNCTION FNTYP))
FN]
(/REMPROP FN (QUOTE BROKEN))
(/SETATOMVAL (QUOTE BROKENFNS)
(/DREMOVE FN BROKENFNS))
(/SETATOMVAL (QUOTE ADVISEDFNS)
(/DREMOVE FN ADVISEDFNS))
(COND
(ALIAS (CHNGNM (CAR ALIAS)
(CDR ALIAS)
T)))
[COND
((AND ADVICE READVICE)
(* The advice for FN is to be permanently saved, as indicated by the presence of the property 'READVICE'.
The advice on 'ADVICE' dominates that on 'READVICE' since the user may have added new pieces of advice.)
(/PUT FN (QUOTE READVICE)
(CONS ALIAS ADVICE]
(/SETATOMVAL (QUOTE ADVINFOLST)
(CONS (CONS FN (CONS ALIAS ADVICE))
ADVINFOLST))
(* Adds to front so READVISE
(T) will get last function unadvised.)
(/REMPROP FN (QUOTE ADVICE))
(RETURN (PROG1 (RESTORE FN (QUOTE ADVISED))
(COND
(ALIAS (PUTD FN])
(ADVISEDUMP
[LAMBDA (X FLG) (* FLG is T for 'ADVISE' and NIL for 'ADVICE')
[SETQ X (MAPCONC X (FUNCTION (LAMBDA (FN)
(MAPCAR (PACK-IN- FN)
(FUNCTION (LAMBDA (FN)
(PROG (Y)
[COND
((SETQ Y (GETP FN (QUOTE ADVICE)))
(PUT FN (QUOTE READVICE)
(CONS (GETP FN (QUOTE ALIAS))
(APPEND Y]
(RETURN FN]
(MAKEDEFLIST X (QUOTE READVICE))
(COND
(FLG (PRINTDEF1 (CONS (QUOTE READVISE)
X])
(READVISE
[NLAMBDA X (* lmm "14-Aug-84 19:15")
(* ADVISE, UNADVISE, and READVISE work similarly to BREAK, UNBREAK, and REBREAK, except that once readvised, a
function's advice is permanently saved on its property list under the property 'READVICE'.
Subsequent calls to UNADVISE update the property 'READVICE' so that the sequence READVISE, ADVISE, UNADVISE,
causes the augmented advice to become permanent. note that the sequence READVISE, ADVISE, READVISE, removes the
intermediate advice by restoring the function to its earlier state.)
(PROG (SPLST)
(RETURN (COND
((NULL X)
(MAPCAR (REVERSE ADVINFOLST)
(FUNCTION READVISE1)))
((EQ (CAR (SETQ X (NLAMBDA.ARGS X)))
T)
(READVISE1 (CAR ADVINFOLST)))
(T (SETQ SPLST (INTERSECTION [SETQ SPLST (APPEND ADVISEDFNS
(MAPCAR ADVINFOLST
(FUNCTION CAR]
SPLST))
(MAPCONC X (FUNCTION (LAMBDA (FN)
(MAPCAR (PACK-IN- FN)
(FUNCTION READVISE0])
(READVISE0
[LAMBDA (FN)
(PROG (Y)
LP [SETQ Y (OR (GETP FN (QUOTE READVICE))
(COND
((SETQ Y (GETP FN (QUOTE ADVICE)))
(CONS (GETP FN (QUOTE ALIAS))
Y)))
(CDR (FASSOC FN ADVINFOLST]
(RETURN (COND
(Y (READVISE1 Y FN))
([AND DWIMFLG (NULL (FNTYP FN))
(SETQ Y (OR (FIXSPELL FN 70 SPLST)
(FIXSPELL FN 70 USERWORDS NIL NIL (FUNCTION FNTYP]
(SETQ FN Y)
(GO LP))
(T (CONS FN (QUOTE (- no advice saved])
(READVISE1
[LAMBDA (LST FN) (* wt: "28-NOV-77 02:15")
(PROG (ALIAS)
[COND
((NULL FN)
(SETQ FN (CAR LST))
(SETQ LST (CDR LST]
(/PUT FN (QUOTE READVICE)
LST)
[COND
((SETQ ALIAS (CAR LST))
(CHNGNM (CAR ALIAS)
(CDR ALIAS]
(/REMPROP FN (QUOTE ADVICE))
(RESTORE FN (QUOTE BROKEN))
(RESTORE FN (QUOTE ADVISED))
(/SETATOMVAL (QUOTE ADVISEDFNS)
(/DREMOVE FN ADVISEDFNS))
(SETQ LST (CDR LST))
LP (APPLY (QUOTE ADVISE)
(CONS FN (CAR LST))) (* Want to do it at least once, even if CDR LST is NIL.)
(COND
((SETQ LST (CDR LST))
(GO LP)))
[COND
|
(ALIAS (* see comment in advise1)
|
(RELINK (CAR ALIAS]
|
(RETURN FN])
(ADDRULE
(LAMBDA (LST NEW WHERE FLG) (* lmm
"21-Feb-86 18:14")
(PROG (X Y)
LP (COND
((NLISTP WHERE)
(RETURN (SELECTQ WHERE
((LAST BOTTOM END NIL)
(COND
(FLG (/ATTACH NEW (FLAST LST))
LST)
(T (/NCONC LST (LIST NEW)))))
((FIRST TOP)
(/ATTACH NEW LST))
(GO BAD))))
((NULL (CDR WHERE))
(SETQ WHERE (CAR WHERE))
(GO LP)))
(COND
((NULL FLG))
((SETQ X (NLEFT LST 2)) (* There is an extra
expression at the end
of RULES. It is
temporarily removed
before calling editor
to avoid conflict.)
(SETQ FLG (CDR X))
(/RPLACD X NIL))
(T (GO BAD)))
(AND (PROG1 (NLSETQ (EDITE LST (LIST (CONS (QUOTE LC)
(CDR WHERE))
(QUOTE (BELOW ↑))
(LIST (CAR WHERE)
NEW))))
(AND FLG (/NCONC LST FLG)))
(RETURN LST))
BAD (PRINT (CONS WHERE (QUOTE (not found)))
T T)
(ERROR!))))
(CADVICE
[LAMBDA (FNS)
[MAPC FNS (FUNCTION (LAMBDA (X)
(CHANGEPROP X (QUOTE ADVISED)
(QUOTE CADVISED))
(CHANGEPROP X (QUOTE EXPR)
(QUOTE ORIGEXPR]
(COMPILE FNS)
[MAPC FNS (FUNCTION (LAMBDA (X)
(CHANGEPROP X (QUOTE CADVISED)
(QUOTE ADVISED))
(REMPROP X (QUOTE EXPR))
(CHANGEPROP X (QUOTE ORIGEXPR)
(QUOTE EXPR]
FNS])
)
(RPAQ? ADVISEDFNS )
(RPAQ? ADVINFOLST )
(RPAQQ ADVISETEMPLATE (ADV-PROG (!VALUE)
(ADV-SETQ !VALUE (ADV-PROG NIL (ADV-RETURN DEF)))
(ADV-RETURN !VALUE)))
(MAP2C (QUOTE (PROG SETQ RETURN))
(QUOTE (ADV-PROG ADV-SETQ ADV-RETURN))
(FUNCTION MOVD))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS ADVISEDFNS BROKENFNS ADVINFOLST DWIMFLG USERWORDS FILEPKGFLG ADVISETEMPLATE)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA READVISE UNADVISE)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS ADVISE COPYRIGHT ("Xerox Corporation" T 1978 1984 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1745 15421 (ADVISE 1755 . 7416) (ADVISE1 7418 . 7988) (UNADVISE 7990 . 9922) (
ADVISEDUMP 9924 . 10460) (READVISE 10462 . 11571) (READVISE0 11573 . 12072) (READVISE1 12074 . 13043)
(ADDRULE 13045 . 15027) (CADVICE 15029 . 15419)))))
STOP