(FILECREATED "21-NOV-78 23:21:05" <NEWLISP>ADVISE.;2 11935
changes to: ADVISECOMS ADVISEBLOCKS
previous date: "18-SEP-78 23:24:32" <LISP>ADVISE.;9)
(PRETTYCOMPRINT ADVISECOMS)
(RPAQQ ADVISECOMS ((FNS * ADVISEFNS)
(VARS (ADVISEDFNS)
(ADVINFOLST))
(P (MAP2C (QUOTE (PROG SETQ RETURN))
(QUOTE (ADV-PROG ADV-SETQ ADV-RETURN))
(FUNCTION MOVD)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA READVISE UNADVISE)
(NLAML)
(LAMA)))
(BLOCKS * ADVISEBLOCKS)))
(RPAQQ ADVISEFNS (ADVISE ADVISE1 UNADVISE ADVISEDUMP READVISE READVISE0 READVISE1 ADDRULE CADVICE))
(DEFINEQ
(ADVISE
[LAMBDA (FN WHEN WHERE WHAT) (* wt: "18-SEP-78 21:31")
(PROG (X Y D)
TOP [COND
((ATOM FN)
(SETQ FN (FNCHECK FN)))
[(EQ (CADR FN)
(QUOTE IN))
(SETQ Y (CADDR FN))
(RETURN (COND
[(ATOM (SETQ X (CAR FN)))
(COND
((ATOM Y)
(ADVISE1 X Y))
(T (MAPCAR Y (FUNCTION (LAMBDA (Y)
(ADVISE1 X Y T]
[(ATOM 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 (QUOTE (ADV-PROG (!VALUE)
(ADV-SETQ !VALUE
(ADV-PROG
NIL
(ADV-RETURN DEF)))
(ADV-RETURN !VALUE]
(* 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
((ATOM 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
(COND
[(EQ (CAR 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
(* 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 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)
(PROG (X Y)
LP (COND
[(ATOM 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 NIL)
(RPAQ ADVINFOLST NIL)
(MAP2C (QUOTE (PROG SETQ RETURN))
(QUOTE (ADV-PROG ADV-SETQ ADV-RETURN))
(FUNCTION MOVD))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA READVISE UNADVISE)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(RPAQQ ADVISEBLOCKS ((NIL ADVISE (GLOBALVARS ADVISEDFNS FILEPKGFLG))
|
(NIL UNADVISE (GLOBALVARS ADVISEDFNS BROKENFNS ADVINFOLST DWIMFLG USERWORDS))
|
(NIL READVISE READVISE0 READVISE1 (GLOBALVARS ADVINFOLST DWIMFLG USERWORDS
|
ADVISEDFNS))))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL ADVISE (GLOBALVARS ADVISEDFNS FILEPKGFLG))
(BLOCK: NIL UNADVISE (GLOBALVARS ADVISEDFNS BROKENFNS ADVINFOLST DWIMFLG USERWORDS))
(BLOCK: NIL READVISE READVISE0 READVISE1 (GLOBALVARS ADVINFOLST DWIMFLG USERWORDS ADVISEDFNS))
]
(DECLARE: DONTCOPY
(FILEMAP(NIL (678 10996 (ADVISE 690 . 4130) (ADVISE1 4134 . 4704) (UNADVISE 4708 . 6571) (ADVISEDUMP 6575 . 7111) (READVISE 7115 . 8119) (READVISE0 8123 . 8622) (READVISE1 8626 . 9595) (ADDRULE 9599 . 10600) (CADVICE 10604 . 10994)))))
STOP
OP