From a86e440056bf5033aaefcb37bd47ed660a591cfc Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Wed, 3 Mar 2021 14:15:51 -0800 Subject: [PATCH] Why wasn't MACRO-FN in MSMACROPROPS? --- library/MASTERSCOPE | 2 +- library/MASTERSCOPE.DFASL | Bin 70313 -> 70195 bytes library/MSANALYZE | 2 +- library/MSANALYZE.DFASL | Bin 23234 -> 23245 bytes 4 files changed, 2 insertions(+), 2 deletions(-) diff --git a/library/MASTERSCOPE b/library/MASTERSCOPE index ca13170e..0e33ca60 100644 --- a/library/MASTERSCOPE +++ b/library/MASTERSCOPE @@ -1 +1 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Sep-2020 09:54:51"  {DSK}kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;4 194460 changes to%: (VARS MSCOMPILETIME MASTERSCOPECOMS) previous date%: "24-Oct-2018 16:25:58" {DSK}kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;2) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1994, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MASTERSCOPECOMS) (RPAQQ MASTERSCOPECOMS [ (* ;; "Main file for MASTERSCOPE.") (FILES MSPARSE MSANALYZE) (PROP FILETYPE MASTERSCOPE) (COMS * MSDATABASECOMS) (COMS * MSAUXCOMS) (COMS * MSDBCOMS) (COMS * MSCHECKBLOCKSCOMS) (COMS * MSPATHSCOMS) [COMS (FNS MSFIND MSEDITF MSEDITE EDITGETDEF) (VARS MSBLIP) (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE.") [INITVARS (MSFNTYPES '((FNS FNS GETDEF] (COMS (* ; "SCRATCHASH") (INITVARS (MSCRATCHASH)) (DECLARE%: DONTCOPY (MACROS SCRATCHASH] (COMS (* ; "marking changed") (FNS MSMARKCHANGED CHANGEMACRO CHANGEVAR CHANGEI.S. CHANGERECORD MSNEEDUNSAVE UNSAVEFNS ) (ADDVARS (COMPILE.TIME.CONSTANTS)) (VARS (RECORDCHANGEFN 'CHANGERECORD)) (INITVARS (CHECKUNSAVEFLG T) (MSNEEDUNSAVE))) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS GETWORDTYPE)) (COMS (* ; "interactive routines") [VARS * (LIST (LIST 'MASTERSCOPEDATE (DATE (DATEFORMAT NO.TIME] (ADDVARS (HISTORYCOMS %.)) (FNS %. MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC) (* ; "Interpreting commands") (FNS MSINTERPRETSET MSINTERPA MSGETBLOCKDEC LISTHARD MSMEMBSET MSLISTSET MSHASHLIST MSHASHLIST1 CHECKPATHS ONFILE) (FNS MSINTERPRET VERBNOTICELIST MSOUTPUT MSCHECKEMPTY CHECKFORCHANGED MSSOLVE) (DECLARE%: DONTCOPY (RECORDS GETHASH INRELATION PATHOPTIONS MSANALYZABLE))) (FILES MSCOMMON) (DECLARE%: DONTCOPY (COMS * MSCOMPILETIME)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA %.) (NLAML) (LAMA MSEDITE MSEDITF MSEDITF]) (* ;; "Main file for MASTERSCOPE.") (FILESLOAD MSPARSE MSANALYZE) (PUTPROPS MASTERSCOPE FILETYPE :COMPILE-FILE) (RPAQQ MSDATABASECOMS ((FNS UPDATEFN MSEDITF MSGETDEF MSNOTICEFILE MSSHOWUSE MSUPDATEFN1 MSUPDATE MSNLAMBDACHECK MSCOLLECTDATA) (FNS UPDATECHANGED UPDATECHANGED1) (VARS TABLE.TO.NOTICED) (FNS MSCLOSEFILES) (VARS (MSFILELST) (MSOPENFILES)) (VARS (MSPRINTFLG '%.) (MSPRINTCNT 0)) (ADDVARS (MSHASHFILE) (ANALYZEUSERFNS)))) (DEFINEQ (UPDATEFN [LAMBDA (FN EVENIFVALID IFCANT TYPE) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Update the analysis of a particular function -  this is a "user" entry) (PROG NIL (OR (AND FN (LITATOM FN)) (RETURN)) (MSINIT) (COND ((AND (NOT EVENIFVALID) (NOT (GETHASH FN MSCHANGEDARRAY)) (TESTRELQ KNOWN FN)) (* Previous valid analysis --  return) (RETURN))) [SETQ DEF (MSGETDEF FN TYPE (SELECTQ IFCANT (0 'CURRENT) '?) '(NOERROR NOCOPY MASTERSCOPE] (COND ((NULL DEF) (* No definition can be found --  look at IFCANT) (SELECTQ IFCANT (ERROR (ERROR FN "can't be analyzed " T)) ((NIL PRINT) (printout T "Sorry, the function " |.P2| FN " can't be analyzed!" T)) NIL) (COND ((TESTRELQ KNOWN FN) (MSERASE (LIST FN))) (T (PUTHASH FN NIL MSCHANGEDARRAY))) (RETURN))) (MSUPDATEFN1 FN DEF]) (MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) (MSGETDEF [LAMBDA (NAME TYPE SOURCE OPTIONS) (* ;  "Edited 23-Jun-93 10:21 by sybalsky:mv:envos") (* ;;; "Take a whack at getting the definition of NAME. Masterscope assumes a bijection between names and analyzable things; it caches that relationship in the FPTYPE table") (LET (TABLEFPTYPE REALDEF) (COND ([SETQ TABLEFPTYPE (CAR (GETRELATION NAME (PARSERELATION 'FPTYPE] (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of (ASSOC TABLEFPTYPE MSFNTYPES)) NAME TABLEFPTYPE SOURCE OPTIONS)) (T (for FPTYPE in MSFNTYPES bind RESULT when (CL:MULTIPLE-VALUE-SETQ (RESULT REALDEF) (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of FPTYPE) NAME TYPE SOURCE OPTIONS)) do (PUTTABLE NAME (LIST (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (CADR (FASSOC 'FPTYPE MSDATABASELST))) (* ;; "Look up active editors, and use the edited defn, if there is one:") (SETQ REALDEF (OR (EDITGETDEF NAME TYPE) REALDEF)) (RETURN (CL:VALUES RESULT REALDEF)) finally NIL]) (MSNOTICEFILE [LAMBDA (FILE) (* ; "Edited 8-Apr-88 12:00 by jrb:") (DECLARE (GLOBALVARS MSHASHFILE LOADDBFLG)) (PROG (FULL COMS TEM) LP (COND ((SETQ TEM (FASSOC FILE MSFILELST)) (* already noticed) (RETURN TEM))) (OR COMS (SETQ COMS (FILECOMS FILE))) (SETQ FULL (FINDFILE FILE T)) [COND ((NOT (FMEMB FILE FILELST)) (* two possibilities%: either FILE is something like FOO or it has not  been loaded yet) [COND ((AND (NOT FULL) (EQ FILE (NAMEFIELD FILE T))) (COND ((LISTP (GETATOMVAL COMS)) (* dummy or new file since COMS set but not on filelst) (GO DUMMY] (* either the file has never been loaded, or an explicit was given) (OR FULL (ERROR FILE "not found")) [SETQ COMS (FILECOMS (SETQ FILE (NAMEFIELD FULL T] (OR (AND [EQ FULL (CDAR (GETPROP FILE 'FILEDATES] (LISTP (EVALV COMS))) (COND ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "should I LOADFROM" FULL))) (RESETVARS [(LOADDBFLG (COND (MSHASHFILE LOADDBFLG) (T 'NO] (* Should bring the hashfile up-to-date if we are noticing the file) (LOADFROM FULL))) (T (ERROR!] [COND ((EQ [CDAR (SETQ TEM (GETPROP FILE 'FILE] 'Compiled) (* If only the compiled version of the file has been loaded, still want to  know about GLOBALVARS or other things) (LOADVARS '((DECLARE%: -- DONTCOPY --)) (OR (AND (SETQ FULL (GETP FILE 'FILEDATES)) (INFILEP (CDAR FULL))) FILE)) (/RPLACD (CAR TEM) 'COMPILED] DUMMY (RETURN (OR (FASSOC FILE MSFILELST) (CAR (SETQ MSFILELST (CONS (CONS FILE COMS) MSFILELST]) (MSSHOWUSE [LAMBDA (SHOWFN SHOWTYPE SHOWSET SHOWEDIT IFCANT EDITCOMS) (* ;  "Edited 23-Jun-93 09:40 by sybalsky:mv:envos") (* ;; "Show/Edit where SHOWFN uses/etc. a pattern.") (PROG (DEF REALDEF ANYFOUND) (COND ([OR [CL:MULTIPLE-VALUE-SETQ (DEF REALDEF) (MSGETDEF SHOWFN (AND (fetch (MSSETPHRASE KNOWN) of SHOWSET) (fetch (MSSETPHRASE TYPE) of SHOWSET)) (COND ((EQ SHOWEDIT 'SHOW) '?) (T 'CURRENT NIL)) '(NOERROR NODWIM NOCOPY] (SETQ DEF (AND (EQ SHOWEDIT 'EDIT) (LET ((FILE (EDITLOADFNS? SHOWFN))) (COND (FILE (LOADFNS SHOWFN FILE 'PROP) (GETPROP SHOWFN 'EXPR] (* ;  "was (MSGETDEF SHOWFN IFCANT (EQ SHOWEDIT (QUOTE SHOW)))") (* ;  "The SHOW command does not need to save") (MSUPDATEFN1 SHOWFN DEF (LIST SHOWTYPE [FUNCTION (LAMBDA (ITEM SS SE PRNT INCLISP) (COND ((MSMEMBSET ITEM SS) (COND ((NOT ANYFOUND) (TAB 0 0 T) (PRIN2 SHOWFN) (PRIN1 " : "))) (SETQ ANYFOUND (CONS (CONS PRNT (AND INCLISP (NOT (MSFIND INCLISP PRNT)) INCLISP)) ANYFOUND)) (COND ([AND (EQ SE 'SHOW) (NOT (FASSOC PRNT (CDR ANYFOUND] (* ;; "The EDIT command works by collecting a list of the expressions, and then doing a (*ORF* (= . lst1) (= . lst2)) --- if within a CLISP translation (determined by the binding of the INCLISP variable) then want to point at the CLISP if the expression is not actually embedded in the expression") (SPACES 3) (LVLPRINT PRNT (OUTPUT) 2) (COND ((CDAR ANYFOUND) (* ; "This is under a clisp") (PRIN1 " {under ") (LVLPRIN2 INCLISP (OUTPUT) 2) (PRIN1 "} "] SHOWSET SHOWEDIT))) (T (printout T "Can't find a definition for " SHOWFN "!" T) (RETURN))) (COND ((NOT ANYFOUND) (RETURN)) ((EQ SHOWEDIT 'EDIT) [MAPC ANYFOUND (FUNCTION (LAMBDA (X) (FRPLNODE X '== (OR (CDR X) (CAR X] (SETQ ANYFOUND (CONS '*ANY* ANYFOUND)) (PRINT [APPLY* 'MSEDITE SHOWFN (OR REALDEF DEF) (ASSOC [CAR (GETRELATION SHOWFN (PARSERELATION 'FPTYPE] MSFNTYPES) (LIST 'BIND '(E (SETQ %#1) T) (LIST 'F ANYFOUND T) (LIST 'LPQ (LIST 'IF '(NEQ (%##) %#1) [LIST '(ORR (P) NIL) '(S %#1) (COND (EDITCOMS (CONS 'BIND EDITCOMS)) (T 'TTY%:] NIL) (LIST 'F ANYFOUND 'N] T T))) (RETURN T]) (MSUPDATEFN1 [LAMBDA (FN DEF EACHTIME DOSUBFNS) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Subfunction of UPDATEFN -- notices all of the "new" functions called by FN) (MSUPDATE FN DEF EACHTIME) (AND DOSUBFNS (for X in (GETRELQ (CALL NOTERROR) FN) when (NOT (TESTRELQ KNOWN X)) do (PROG (DEF) (AND [SETQ DEF (MSGETDEF X NIL 'CURRENT '(NOCOPY NODWIM NOERROR MASTERSCOPE] (MSUPDATEFN1 X DEF EACHTIME T]) (MSUPDATE [LAMBDA (FNNAME FNDEF EACHTIME) (* lmm "22-Jul-86 18:24") (* This is the main internal entry to the analysis routines.) (PROG (VARS ERS TEM PRFLG DATA) (* VARS is used to mark the CURRENT variables bound.  INCLISP and EACHTIME need to be bound by ADDTO which checks to see if we are  in a SHOW or EDIT) (MSNLAMBDACHECK FNNAME) [COND ((EQ (CAR FNDEF) 'CL:LAMBDA)) ([OR (EQ DWIMIFYCOMPFLG T) (EQ CLISPIFYPRETTYFLG T) (EQ (CAR (SETQ TEM (CADDR FNDEF))) 'CLISP%:) (AND (EQ (CAR TEM) COMMENTFLG) (EQ (CADR TEM) 'DECLARATIONS%:)) (NOT (FMEMB (CAR FNDEF) '(LAMBDA NLAMBDA] (* Check if the whole definition  needs to be DWIMIFIED) (LET (VARS) (DECLARE (CL:SPECIAL VARS)) (MSPRGDWIM FNDEF FNNAME FNDEF] [COND ((NOT EACHTIME) (COND ((OR (EQ MSPRINTFLG T) (AND (FIXP MSPRINTFLG) (NOT (IGREATERP (SETQ MSPRINTCNT (SUB1 MSPRINTCNT)) 0)) (SETQ MSPRINTCNT MSPRINTFLG))) (SETQ PRFLG (PRIN2 FNNAME T))) ((EQ MSPRINTFLG '%.) (PRIN1 '%. T] (SETQ DATA (ALLCALLS FNDEF 'ARG NIL FNNAME T EACHTIME)) (for F in ANALYZEUSERFNS do (SETQ DATA (APPLY* F FNNAME FNDEF DATA))) [SETQ ERS (FMEMB MSERRORFN (CDR (FASSOC 'ERRORS DATA] [SELECTQ MSPRINTFLG (NIL) (%. (AND ERS (PRIN1 '? T))) (PROGN [OR PRFLG (COND ((OR ERS (AND EACHTIME (NOT ANYFOUND))) (SETQ PRFLG (PRIN2 FNNAME T] (* always print if errors) (COND (ERS (PRIN1 " (CALLS ppe)" T))) (AND PRFLG (PRIN1 '", " T] (MSSTOREDATA FNNAME DATA]) (MSNLAMBDACHECK [LAMBDA (FN) (* lmm "22-DEC-78 13:11") (COND ((AND (NOT (TEMPLATE FN T)) [SETQ FN (COND [(NLAMBDAFNP FN) (SUBSET (GETRELQ (CALL DIRECTLY) FN T) (FUNCTION (LAMBDA (FN2) (* the set of functions which call this one, but don't call it as an nlambda) (NOT (FMEMB FN (GETRELQ (CALL NLAMBDA) FN2] (T (* someone calls it as an NLAMBDA) (GETRELQ (CALL NLAMBDA) FN T] (MSMARKCHANGE1 FN]) (MSCOLLECTDATA [LAMBDA (TNAME FLG) (* lmm "30-OCT-80 10:00") (COND ((LISTP TNAME) (SELECTQ (CAR TNAME) (- (LDIFFERENCE (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (+ (UNION (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (SHOULDNT 2))) (T (PROG NIL (RETURN (MSCOLLECTDATA (CADR (OR (AND (NULL FLG) (FASSOC TNAME TABLE.TO.NOTICED)) (RETURN (CDR (FASSOC TNAME FNDATA]) ) (DEFINEQ (UPDATECHANGED [LAMBDA NIL (* lmm "16-JUL-78 05:07") (* Update all functions marked as  changed) (MSINIT) (MAPHASH MSCHANGEDARRAY (FUNCTION UPDATECHANGED1)) NIL]) (UPDATECHANGED1 [LAMBDA (VAL KEY) (* ; "Edited 27-Jan-88 16:49 by jrb:") (COND [(OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ([SETQ VAL (MSGETDEF KEY NIL '? '(NOERROR NOCOPY MASTERSCOPE] (MSUPDATEFN1 KEY VAL NIL T)) (T (printout T KEY " disappeared!" T) (MSERASE (LIST KEY] (T (PUTHASH KEY NIL MSCHANGEDARRAY]) ) (RPAQQ TABLE.TO.NOTICED ((BIND (- (- (- (- (+ BIND ARG) REF) SMASH) SET) TEST)) (REFFREE (- (- (- REFFREE SETFREE) SMASHFREE) TESTFREE)) (REF (- (- (- REF SET) SMASH) TEST)) (PREDICATE (- PREDICATE CALL)) (EFFECT (- (- EFFECT CALL) PREDICATE)) (CALL (- CALL NLAMBDA)) (0 TYPE) (APPLY (+ APPLY STACK)) (ARGS ARG))) (DEFINEQ (MSCLOSEFILES [LAMBDA NIL (* lmm "24-JUN-78 17:18") (* this is RESETSAVE'd from MSGETDEF to close any files that MSGETDEF leaves  open) (for X in MSOPENFILES when (AND (NOT (CADR X)) (OPENP (CADDR X))) do (CLOSEF (CADDR X))) (SETQ MSOPENFILES]) ) (RPAQQ MSFILELST NIL) (RPAQQ MSOPENFILES NIL) (RPAQQ MSPRINTFLG %.) (RPAQQ MSPRINTCNT 0) (ADDTOVAR MSHASHFILE ) (ADDTOVAR ANALYZEUSERFNS ) (RPAQQ MSAUXCOMS ((COMS (FNS MSDESCRIBE MSDESCRIBE1 FMAPRINT) (ADDVARS (DESCRIBELST)) (GLOBALVARS DESCRIBELST)) (COMS (FNS MSPRINTHELPFILE) (VARS MSHELPFILE)) (COMS (FNS TEMPLATE GETTEMPLATE SETTEMPLATE) (FILEPKGCOMS TEMPLATES)) (COMS (FNS ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (INITVARS (MSCHECKFNS NIL)) (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES)))) (DEFINEQ (MSDESCRIBE [LAMBDA (FN SN) (* lmm "22-Jul-85 18:16") (* Prints function name, arguments,  local and free variables.  etc) (DECLARE (SPECVARS FN)) (* Make FN available to user  DESCRIBELST forms) (PROG (GLOBALS FREES ARGS LINE) [SETQ ARGS (COND ((SETQ ARGS (GETRELQ ARGS FN)) (* The args in the argtable have precedence, even if the function is  resident, cause they correspond to what was actually analyzed.) (* T is for an arglist of NIL) (AND (NEQ ARGS T) ARGS)) ((GETD FN) (SMARTARGLIST FN] (printout NIL "(" .FONT BOLDFONT |.P2| FN .FONT DEFAULTFONT) (FMAPRINT ARGS NIL " " ")") (OR (TESTRELQ KNOWN FN) (PRIN1 " (not analyzed)" T)) (COND ([AND [OR (HARRAYP SN) (HARRAYP (CAR (LISTP SN] (SMALLP (SETQ LINE (GETHASH FN SN] (TAB 45 T) (PRIN1 " {line ") (PRIN1 (ABS LINE)) (PRIN1 "}"))) (TERPRI) (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN) '"calls: ") (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN T) '"called by:") (MSDESCRIBE1 (for VAR in (GETRELQ BIND FN) when (NOT (EQMEMB VAR ARGS)) collect VAR) '"binds: ") [for VAR in (GETRELQ (USE FREELY) FN) do (COND ((OR (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR)) (SETQ GLOBALS (CONS VAR GLOBALS))) (T (SETQ FREES (CONS VAR FREES] (MSDESCRIBE1 FREES '"uses free:") (MSDESCRIBE1 GLOBALS '"globals: ") (MSDESCRIBE1 (GETRELQ (USE FIELDS) FN) '"fields: ") (for D L in DESCRIBELST when (SETQ L (EVAL (CADR D))) do (MSDESCRIBE1 L (CAR D))) (TERPRI]) (MSDESCRIBE1 [LAMBDA (LST STR) (* lmm " 9-AUG-77 04:45") (* lmm%: 15 NOV 75 2248) (COND (LST (SPACES 2) (PRIN1 STR) (SPACES 1) (PROG (LL P) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) (SETQ LL (LINELENGTH)) (SETQ P (POSITION)) LP (COND ((IGREATERP (IPLUS (POSITION) 5 (NCHARS (CAR LST))) LL) (TAB P))) (PRIN2 (CAR LST)) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 '%,) (GO LP) EXIT (TERPRI]) (FMAPRINT [LAMBDA (LST FILE LEFT RIGHT SEP) (* lmm%: 28 OCT 75 757) (PROG NIL (AND LEFT (PRIN1 LEFT FILE)) (OR SEP (SETQ SEP '% )) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) LP (PRIN2 (CAR LST) FILE) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 SEP FILE) (GO LP) EXIT (AND RIGHT (PRIN1 RIGHT FILE]) ) (ADDTOVAR DESCRIBELST ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DESCRIBELST) ) (DEFINEQ (MSPRINTHELPFILE [LAMBDA NIL (* lmm "20-JAN-79 13:48") (PROG (FL) [SETQ FL (OR (INFILEP MSHELPFILE) (RETURN (PROGN (printout T "Sorry, HELP file not available!" T) NIL] (SETQ FL (INPUT (INFILE FL))) (RESETSAVE NIL (LIST 'CLOSEF FL)) (COPYBYTES FL T 0 (GETEOFPTR FL]) ) (RPAQQ MSHELPFILE MASTERSCOPE.SYNTAX) (DEFINEQ (TEMPLATE [LAMBDA (FN TEMPLATE FLG) (* lmm "23-DEC-78 14:06") (* MSTEMPLATES is the hash table for pre-defined templates.  USERTEMPLATES contains user defined templates.  The split is so that DUMPDATABASE can dump the templates as well -  check for MSDATABASE is so CALLS doesn't need to init database) (PROG [(OLD (OR (GETHASH FN USERTEMPLATES) (GETHASH FN MSTEMPLATES] (COND ((EQ OLD T) (SETQ OLD))) (COND ((AND (NOT (EQUAL TEMPLATE OLD)) (NEQ TEMPLATE T)) [COND ((NOT FLG) [AND FILEPKGFLG (MARKASCHANGED FN 'TEMPLATES (NOT (NULL OLD] (AND MSDATABASELST (MSMARKCHANGED (GETRELATION FN '(CALL DIRECTLY) T) 'FNS] (PUTHASH FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (MACRO TEMPLATE) (NIL (AND (GETHASH FN MSTEMPLATES) T)) (ERROR TEMPLATE "Invalid template"))) (T TEMPLATE)) USERTEMPLATES))) (RETURN OLD]) (GETTEMPLATE [LAMBDA (FN) (* lmm " 9-AUG-77 06:20") (SETTEMPLATE FN T]) (SETTEMPLATE [LAMBDA (FN TEMPLATE) (* lmm "16-FEB-78 14:56") (PROG ([OLD (COPY (TEMPLATE FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (EVAL '(CALL |..| EVAL)) ((NIL T MACRO) TEMPLATE) (ERROR TEMPLATE "Invalid template"))) (T (SELECTQ (CAR TEMPLATE) (MACRO TEMPLATE) (! (CDR TEMPLATE)) (CONS 'CALL (AND (OR (CAR TEMPLATE) (CDR TEMPLATE)) TEMPLATE] VAL) [SETQ VAL (COND ((NLISTP OLD) OLD) (T (SELECTQ (CAR OLD) (MACRO OLD) (CALL (OR (CDR OLD) (CONS))) (CONS '! OLD] [OR (EQ TEMPLATE T) (AND LISPXHIST (UNDOSAVE (LIST 'SETTEMPLATE FN OLD] (RETURN VAL]) ) (PUTDEF (QUOTE TEMPLATES) (QUOTE FILEPKGCOMS) '((COM MACRO [X (P * (MAPCAR 'X (FUNCTION (LAMBDA (FN) (LIST 'SETTEMPLATE (KWOTE FN) (KWOTE (GETTEMPLATE FN] CONTENTS NILL) (TYPE DESCRIPTION "masterscope templates"))) (DEFINEQ (ADDTEMPLATEWORD [LAMBDA (WORD) (* smL "27-Nov-85 17:49") (* * Add a new word that can be used in TEMPLATES.  This really means add a new MasterScope table.) (MSINIT) (if (NOT (ASSOC WORD MSFNDATA)) then (PUTASSOC WORD NIL MSFNDATA)) (if (NOT (ASSOC WORD MSDATABASELST)) then (PUTASSOC WORD (CONS (MAKETABLE 2) (MAKETABLE 2)) MSDATABASELST)) (if (NOT (ASSOC WORD MSDATABASEINIT)) then (PUTASSOC WORD (CONS 2 2) MSDATABASEINIT]) (MSADDANALYZE [LAMBDA (PLURAL SINGLE FILETYPE GETDEF-FN MARKCHANGED-FN) (* ; "Edited 16-Jun-88 10:35 by jrb:") (* * Defines a new MasterScope datatype) [for word in (LIST PLURAL SINGLE) do (LET ((oldDef (GETHASH word MSWORDS))) (if oldDef then (PUTASSOC 'TYPE PLURAL oldDef) else (PUTHASH word (LIST (CONS 'TYPE PLURAL)) MSWORDS] (* ;;  "MSANALYZEFNS is bogus and is hereby removed. (PUTHASH PLURAL ANALYZEFN MSANALYZEFNS)") (* ;; "JRB - ") (if FILETYPE then (LET ((oldEntry (ASSOC FILETYPE MSFNTYPES))) (if oldEntry then (replace (MSANALYZABLE SETNAME) oldEntry PLURAL) (replace (MSANALYZABLE GETDEF-FN) oldEntry GETDEF-FN) (replace (MSANALYZABLE MARKCHANGED-FN) oldEntry MARKCHANGED-FN) else (push MSFNTYPES (create MSANALYZABLE FILEPKGNAME _ FILETYPE SETNAME _ PLURAL GETDEF-FN _ GETDEF-FN MARKCHANGED-FN _ MARKCHANGED-FN]) (MSADDMODIFIER [LAMBDA (RELATION MODIFIERS TABLES) (* smL "16-Dec-85 15:39") (* * Define a new modifier to a MasterScope relation, telling what tables  should be combined to determine the modified relation) (SETQ TABLES (MKLIST TABLES)) (SETQ MODIFIERS (MKLIST MODIFIERS)) (MSINIT) (for adverb in MODIFIERS bind oldWordDef do (SETQ oldWordDef (ASSOC 'V (GETHASH adverb MSWORDS))) (if oldWordDef then (PUTASSOC 'V [CONS adverb (CONS RELATION (MKLIST (CDDR oldWordDef] (GETHASH adverb MSWORDS)) else (PUTHASH adverb (CONS (CONS 'V (LIST adverb RELATION)) (GETHASH adverb MSWORDS)) MSWORDS))) (PUTHASH RELATION (CONS (CONS MODIFIERS TABLES) (GETHASH RELATION MSUSERVBTABLES)) MSUSERVBTABLES) (for table in TABLES do (ADDTEMPLATEWORD table]) (MSADDRELATION [LAMBDA (RELATION TABLES) (* smL "16-Dec-85 14:55") (* * Let the user define a new MasterScope relation.  -  RELATION is a list of ROOT PRESENT PARTICIPLE and PAST conjugations of the  new relation. They can then be used in MasterScope commands to specify  relations. -  TABLES is a list of new MasterScope database tables.  These tables can then be used in MasterScope templates.  TABLES defaults to the ROOT of the relation.) (LET ((ROOT (CAR RELATION))) (MSSETUP (LIST RELATION)) [MSADDMODIFIER ROOT '(NIL) (MKLIST (MKLIST (OR TABLES ROOT] ROOT]) (MSADDTYPE [LAMBDA (TYPE TABLES HOWUSED SYNONYMS) (* smL "16-Dec-85 15:35") (* * Defines the TYPE as the union of the TABLES so you can use phrases like  "USE foo AS A " or "USE THE foo") [SETQ HOWUSED (MKLIST (OR HOWUSED 'USE] (SETQ SYNONYMS (MKLIST SYNONYMS)) (SETQ TABLES (MKLIST TABLES)) (MSINIT) (for typeWord in (CONS TYPE SYNONYMS) bind oldWordDef do (SETQ oldWordDef (GETHASH typeWord MSWORDS)) (if oldWordDef then (PUTASSOC 'TYPE TYPE oldWordDef) else (SETQ oldWordDef (LIST (CONS 'TYPE TYPE))) (PUTHASH typeWord oldWordDef MSWORDS)) (PUTASSOC 'AS [CONS TYPE (APPEND HOWUSED (CDDR (ASSOC 'AS oldWordDef] oldWordDef)) (MSADDMODIFIER 'USE TYPE TABLES]) ) (RPAQ? MSCHECKFNS NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES) ) (RPAQQ MSDBCOMS [(FNS MSMARKCHANGE1 MSINIT GETVERBTABLES MSSTOREDATA STORETABLE) (ADDVARS (MSCHANGEDARRAY) (MSDATABASELST)) (INITVARS (MSDBEMPTY T)) (VARS MSDATABASEINIT NODUMPRELATIONS) (FNS PARSERELATION PARSERELATION1 GETRELATION MAPRELATION TESTRELATION) (COMS (FNS ADDHASH SUBHASH MAKEHASH MSREHASH EQMEMBHASH) [P (MAPC '((GETHASH GETTABLE) (GETHASH TESTTABLE) (PUTHASH PUTTABLE) (ADDHASH ADDTABLE) (SUBHASH SUBTABLE) (MAPHASH MAPTABLE) (MAKEHASH MAKETABLE) (EQMEMBHASH EQMEMBTABLE)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X] (FNS MSVBTABLES MSUSERVBTABLES) (INITVARS (MSUSERVBTABLES (MAKETABLE 2)) (MSANALYZEFNS (MAKETABLE 2))) (FNS BUILDGETRELQ BUILDTESTRELQ) (DECLARE%: DONTCOPY (MACROS GETRELQ TESTRELQ))) (COMS (FNS MSERASE)) (COMS (FNS DUMPDATABASE DUMPDATABASE1 READATABASE) (VARS DATABASECOMS)) (ADDVARS (GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE]) (DEFINEQ (MSMARKCHANGE1 [LAMBDA (FNS FLG) (* rmk%: "19-FEB-81 14:53") (* mark the selected functions as "changed" -  FLG=T in MSCHANGEDARRAY means to complain if the definition can't be found, 0  means give up quietly.) (OR FLG (SETQ FLG T)) (for FN inside FNS do (PUTHASH FN FLG MSCHANGEDARRAY)) (* This isn't undone by simply restoring the pevious entry in the hash array  because the user might have asked a question that caused the functions to be  reanalyzed. Against this possibility, we "undo" by re-marking the functions  for reanalysis.) (UNDOSAVE (LIST (FUNCTION MSMARKCHANGE1) FNS FLG]) (MSINIT (LAMBDA (DATABASE) (* ; "Edited 12-Jun-90 20:45 by teruuchi") (* ;; "lmm %"29-Jul-85 21:06%"") (* ;; "This function should be called at the beginning of any function which accesses the data base") (COND ((OR (NULL MSDATABASELST) (LISTP DATABASE)) (SETQ MSDATABASELST) (pushnew MARKASCHANGEDFNS (QUOTE MSMARKCHANGED)) (SETQ MSCHANGEDARRAY (HASHARRAY 128)) (* ;; "MSDATABASEINIT is a pattern for how the data base list should look. The data base is stored in multiple hash tables. These hash tables are pointed to both by a list, MSDATABASELST which is an a-list of (TableName ForwardTable . BackTable) while the array, MSDATABASE, is an array of the same length as the list, with ELT's the forward htables, and ELTD's the back tables.") (OR DATABASE (SETQ MSDBEMPTY)) (SETQ MSDATABASELST (for X in MSDATABASEINIT collect (CONS (CAR X) (CONS (OR (CADR (ASSOC (CAR X) DATABASE)) (SELECTQ (CAR X) (USERTEMPLATES USERTEMPLATES) (MAKETABLE (CADR X) (CAR X)))) (COND ((FIXP (CDDR X)) (OR (CDDR (ASSOC (CAR X) DATABASE)) (MAKETABLE (CDDR X) (CAR X) T))) (T (CDDR X))))) finally (SETQ MSFILETABLE (ASSOC (QUOTE FILE) $$VAL)) (SETQ MSARGTABLE (ASSOC (QUOTE ARGS) $$VAL)))) T))) ) (GETVERBTABLES [LAMBDA (ROOT MODIFIER) (* lmm "28-FEB-79 16:08") (for Y in (OR (MSVBTABLES ROOT MODIFIER) (SHOULDNT 3)) collect (COND [(LISTP Y) (LIST (CDDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) (MSSTOREDATA [LAMBDA (FNNAME FNDATA) (* lmm " 1-JUN-81 23:19") (PROG [NEWREL (KWN (PARSERELATION 'KNOWN] (SETQ MSDBEMPTY NIL) (* Database for FNNAME about to become inconsistant -  mark it as changed) (PUTHASH FNNAME T MSCHANGEDARRAY) (* * Now update the database) (for TAB in MSDATABASELST when (AND (NOT (FMEMB (CAR TAB) NODUMPRELATIONS)) (NEQ (CDDR TAB) T)) do (SETQ NEWREL (MSCOLLECTDATA (CAR TAB))) (STORETABLE FNNAME TAB NEWREL)) [OR (TESTRELATION FNNAME KWN) (PUTTABLE FNNAME T (CADR (FASSOC 'NOBIND MSDATABASELST] (* Table NOBIND is for those functions which don't do very much.  The idea is that the test that a function has been analyzed is whether it  binds variables are calls functions, etc.  However, for those functions which have no such entries,  (e.g. their definition is (LAMBDA NIL NIL)) need to still be able to know  that they were.) (PUTHASH FNNAME NIL MSCHANGEDARRAY]) (STORETABLE [LAMBDA (KEY TABLST VALUE) (* lmm "10-APR-81 08:46") (PROG [(OLDREL (GETTABLE KEY (CADR TABLST] (PUTTABLE KEY VALUE (CADR TABLST)) (COND ((CDDR TABLST) (for Z in VALUE do (* Used to test here (NOT (EQMEMB Z OLDREL)) but occasionally found the data  base was out of synch & A calls B but B doesn't show being called by A;  thus we always add KEY to Z's back pointers  (nothing will be done if it is already there)) (ADDTABLE Z KEY (CDDR TABLST))) (for Z in OLDREL do (* However, we must rely on the previous value to tell who values must be  DELETED from) (AND (NOT (FMEMB Z VALUE)) (SUBTABLE Z KEY (CDDR TABLST]) ) (ADDTOVAR MSCHANGEDARRAY ) (ADDTOVAR MSDATABASELST ) (RPAQ? MSDBEMPTY T) (RPAQQ MSDATABASEINIT ((CALL 25 . 50) (BIND 10 . 10) [NLAMBDA 10 . 10] (NOBIND 10) (RECORD 20 . 10) (CREATE 2 . 2) (FETCH 10 . 10) (REPLACE 10 . 10) (REFFREE 10 . 1) (REF 10 . 25) (SETFREE 1 . 1) (SET 20 . 30) (SMASHFREE 1 . 1) (SMASH 1 . 1) (PROP 1 . 1) (TEST 1 . 1) (TESTFREE 1 . 1) (PREDICATE 10 . 10) (EFFECT 10 . 10) (CLISP 10 . 10) (SPECVARS 10 . 10) (LOCALVARS 10 . 10) (APPLY 10 . 10) (ERROR 10 . 10) (LOCALFREEVARS 10 . 10) (CONTAINS 10 . 10) (FILE 10) (ARGS 10) (USERTEMPLATES NIL . T) (0 10 . 10) (FPTYPE 10 . 10) (KEYACCEPT 2 . 2) (KEYSPECIFY 2 . 2) (KEYCALL 2 . 2) (FLET 2 . 2) (LABEL 2 . 2) (MACROLET 2 . 2) (COMPILER-LET 2 . 2) (SENDNOTSELF 2 . 2) (SENDSELF 2 . 2) (IMPLEMENT 2 . 2) (GETNOTSELF 2 . 2) (GETSELF 2 . 2) (GETCVSELF 2 . 2) (GETCVNOTSELF 2 . 2) (PUTNOTSELF 2 . 2) (PUTSELF 2 . 2) (PUTCVSELF 2 . 2) (PUTCVNOTSELF 2 . 2) (OBJECT 2 . 2))) (RPAQQ NODUMPRELATIONS (CONTAINS FILE)) (DEFINEQ (PARSERELATION [LAMBDA (RELATION) (* lmm "11-Jul-86 15:50") (MSINIT) (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (CONS 'TABLES (for Y in (PARSERELATION1 RELATION) collect (COND [(LISTP Y) (CDR (CDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) (PARSERELATION1 [LAMBDA (ROOT MOD TAIL) (* lmm "30-DEC-78 17:06") (COND [TAIL (APPLY* (SELECTQ (CAR TAIL) (ANDNOT (FUNCTION LDIFFERENCE)) (AND (COND ((EQ (CADR TAIL) 'NOT) (SETQ TAIL (CDR TAIL)) (FUNCTION LDIFFERENCE)) (T (FUNCTION INTERSECTION)))) (OR (FUNCTION UNION)) (ERROR TAIL '?)) (PARSERELATION1 ROOT MOD) (PARSERELATION1 (CADR TAIL) (CDDR TAIL] ((LISTP ROOT) (PARSERELATION1 (CAR ROOT) (CDR ROOT))) [(LISTP MOD) (SELECTQ (CAR MOD) ((A AS AN FOR) (PARSERELATION1 ROOT (CDR MOD))) ((AND OR ANDNOT) (PARSERELATION1 ROOT NIL MOD)) (PARSERELATION1 ROOT (CAR MOD) (CDR MOD] (T (OR (MSVBTABLES ROOT MOD) [MSVBTABLES (GETWORDTYPE ROOT 'S) (CAR (OR (GETWORDTYPE MOD 'V) (GETWORDTYPE MOD 'AS) (GETWORDTYPE MOD 'FOR) (ERROR MOD '?] (ERROR ROOT '?]) (GETRELATION [LAMBDA (ITEM RELATION INVERTED) (* lmm "11-Jul-86 15:51") (PROG (VAL) (for TABLE in [CDR (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (PARSERELATION RELATION] do (SETQ VAL (UNION [GETTABLE ITEM (COND (INVERTED (COND ((LITATOM (CDR TABLE)) (ERROR RELATION "CAN'T BE INVERTED"))) (CDR TABLE)) (T (CAR TABLE] VAL))) (RETURN VAL]) (MAPRELATION [LAMBDA (RELATION MAPFN) (* lmm "21-SEP-78 04:20") (DECLARE (SPECVARS MAPZ MAPW MAPFN2 MAPFN)) (PROG ((MAPZ (NARGS MAPFN)) (MAPW (PARSERELATION RELATION))) (MAP (CDR MAPW) (FUNCTION (LAMBDA (MAPFN2) (MAPTABLE (CAAR MAPFN2) (FUNCTION (LAMBDA (DUMMY MAPX) (OR [SOME (CDR MAPFN2) (FUNCTION (LAMBDA (HT2) (TESTTABLE MAPX (CAR HT2] (COND ((EQ MAPZ 1) (APPLY* MAPFN MAPX)) (T (MAPC (GETRELATION MAPX MAPW) (FUNCTION (LAMBDA (Z) (APPLY* MAPFN MAPX Z]) (TESTRELATION [LAMBDA (ITEM RELATION ITEM2 INVERTED) (* lmm "25-JUN-78 01:16") (AND [SOME [CDR (COND ((EQ (CAR RELATION) 'TABLES) RELATION) (T (PARSERELATION RELATION] (FUNCTION (LAMBDA (TABLE) (COND [ITEM2 (FMEMB ITEM2 (GETTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] (T (TESTTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] T]) ) (DEFINEQ (ADDHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (* Add VAL to the hash-key of ITEM  in ARRAY) (PROG ((OV (GETHASH ITEM ARRAY))) (COND (OV (OR (FMEMB VAL OV) (NCONC1 OV VAL))) (T (PUTHASH ITEM (LIST VAL) ARRAY]) (SUBHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (PROG ((OV (GETHASH ITEM ARRAY))) (AND OV (OR (DREMOVE VAL OV) (PUTHASH ITEM NIL ARRAY]) (MAKEHASH [LAMBDA (N) (* rmk%: " 3-Jan-84 21:31") (HASHARRAY N (FUNCTION MSREHASH]) (MSREHASH [LAMBDA (HA) (* rmk%: "30-Dec-83 11:45") (* The hash tables in the database rehash using this algorithm;  they increase size by 25% + 50 This insures that even though some tables  start out small (e.g. 1 or 2 elements) they will rehash to larger ones.) (IPLUS (IQUOTIENT (ITIMES 5 (HARRAYSIZE HA)) 4) 50]) (EQMEMBHASH [LAMBDA (X V H) (* rmk%: "10-JUN-79 21:00") (* Provided in case MSHASH is loaded  without MSSWAP) (MEMB V (GETHASH X H]) ) [MAPC '((GETHASH GETTABLE) (GETHASH TESTTABLE) (PUTHASH PUTTABLE) (ADDHASH ADDTABLE) (SUBHASH SUBTABLE) (MAPHASH MAPTABLE) (MAKEHASH MAKETABLE) (EQMEMBHASH EQMEMBTABLE)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X] (DEFINEQ (MSVBTABLES [LAMBDA (VERB MOD) (* ; "Edited 30-Jun-87 10:32 by jrb:") (* ;; "The call to MSUSERVBTABLES checks a user hash table to allow extensions.") [COND ((LISTP VERB) (SETQ MOD (CADR VERB)) (SETQ VERB (CAR VERB] (MKLIST (OR (SELECTQ VERB (BIND (SELECTQ MOD (NIL '(BIND REF SET SMASH TEST)) (NOTUSE 'BIND) NIL)) (CALL (SELECTQ MOD (DIRECTLY '(CALL EFFECT PREDICATE NLAMBDA)) (EFFECT 'EFFECT) (INDIRECTLY 'APPLY) (NIL '(APPLY CALL EFFECT ERROR PREDICATE NLAMBDA)) (NOTERROR '(APPLY CALL EFFECT PREDICATE NLAMBDA)) (PREDICATE 'PREDICATE) (TESTING 'PREDICATE) (VALUE '(CALL NLAMBDA)) (NLAMBDA 'NLAMBDA) NIL)) (CREATE (SELECTQ MOD (NIL 'CREATE) NIL)) (DECLARE (SELECTQ MOD (CL:LOCALLY 'LOCALVARS) (LOCALVARS 'LOCALVARS) (NIL '(LOCALVARS SPECVARS)) (SPECVARS 'SPECVARS) NIL)) (FETCH (SELECTQ MOD (NIL 'FETCH) NIL)) (IS (SELECTQ MOD (FIELDS '((FETCH) (REPLACE))) (FNS '(CALL NOBIND REF (CALL) (APPLY))) (KNOWN '(CALL NOBIND REF)) (NIL '(CALL NOBIND REF (CALL) (BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (RECORDS) (FETCH) (REPLACE) (PROP) (APPLY) (TEST) (TESTFREE))) (PROPS '((PROP))) (RECORDS '((RECORD) (CREATE))) (VARS '((BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (TEST) (TESTFREE))) (TYPE '((0))) NIL)) (KNOWN (SELECTQ MOD (NIL '(CALL NOBIND REF)) NIL)) (PROG (SELECTQ MOD (NIL 'PROG) NIL)) (REFERENCE (SELECTQ MOD (FIELDS 'FETCH) (FREELY '(REFFREE TESTFREE SMASHFREE)) (CL:LOCALLY '(REF TEST SMASH)) (NIL '(REF REFFREE TEST TESTFREE SMASH SMASHFREE)) NIL)) (REPLACE (SELECTQ MOD (NIL 'REPLACE) NIL)) (SET (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SETFREE) (CL:LOCALLY 'SET) (NIL '(SET SETFREE)) NIL)) (SMASH (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SMASHFREE) (CL:LOCALLY 'SMASH) (NIL '(SMASH SMASHFREE)) NIL)) (TEST (SELECTQ MOD (FREELY 'TESTFREE) (CL:LOCALLY 'TEST) (NIL '(TEST TESTFREE)) NIL)) (USE (SELECTQ MOD (FIELDS '(FETCH REPLACE)) (FREELY '(REFFREE SETFREE SMASHFREE TESTFREE)) (I.S.OPRS 'CLISP) (INDIRECTLY 'LOCALFREEVARS) (CL:LOCALLY '(REF SET SMASH TEST)) (NIL '(REF REFFREE SET SETFREE SMASH SMASHFREE TEST TESTFREE)) (PREDICATE '(TEST TESTFREE)) (PROPNAMES 'PROP) (RECORDS '(CREATE RECORD)) (TESTING '(TEST TESTFREE)) (VALUE '(REF REFFREE SMASH SMASHFREE)) (TYPE '0) NIL)) NIL) (MSUSERVBTABLES VERB MOD]) (MSUSERVBTABLES [LAMBDA (VERB MOD) (* smL "20-Dec-85 17:03") (* * Find the relation tables for a user-defined relation) (OR [AND (BOUNDP 'MSUSERVBTABLES) (HASHARRAYP MSUSERVBTABLES) (CDR (for modifier in (GETHASH VERB MSUSERVBTABLES) thereis (EQMEMB MOD (CAR modifier] VERB]) ) (RPAQ? MSUSERVBTABLES (MAKETABLE 2)) (RPAQ? MSANALYZEFNS (MAKETABLE 2)) (DEFINEQ (BUILDGETRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:36 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM F1) [for REL in (MSVBTABLES (CAR X)) do [SETQ F1 (LIST 'GETTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE REL) 'MSDATABASELST] (SETQ FORM (COND (FORM (LIST 'UNION F1 FORM)) (T F1] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) (BUILDTESTRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:41 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM) [SETQ FORM (CONS 'OR (for R in (MSVBTABLES (CAR X)) collect (LIST 'TESTTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE R) 'MSDATABASELST] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS GETRELQ MACRO (X (BUILDGETRELQ X))) (PUTPROPS TESTRELQ MACRO (X (BUILDTESTRELQ X))) ) ) (DEFINEQ (MSERASE [LAMBDA (ATOMS) (* lmm " 1-JUN-81 22:56") (DECLARE (SPECVARS ERASESET)) (COND ((EQ ATOMS T) (SETQ MSCHANGEDARRAY) (SETQ MSDATABASELST) (SETQ MSFILETABLE) (SETQ MSARGTABLE) (SETQ MSDBEMPTY T)) (T (for AT in ATOMS do (MSSTOREDATA AT]) ) (DEFINEQ (DUMPDATABASE [LAMBDA (FNLST) (* lmm "12-APR-81 15:57") (PROG (DUMPEDFLG) (DECLARE (SPECVARS DUMPEDFLG DUMPTABLE)) (COND (FNLST (MAPC FNLST (FUNCTION UPDATEFN))) (T (UPDATECHANGED))) (PRINT '(READATABASE)) (PRIN1 '%() (TERPRI) [for DUMPTABLE in MSDATABASELST when (NOT (MEMB (CAR DUMPTABLE) NODUMPRELATIONS)) do (SETQ DUMPEDFLG NIL) [COND ((OR (NOT FNLST) (EQ (CDDR DUMPTABLE) T)) (* either dumping everything, or this is a permanent table which should be  dumped in entirity (e.g. templates)) (MAPTABLE (CADR DUMPTABLE) (FUNCTION DUMPDATABASE1))) (T (MAPC FNLST (FUNCTION (LAMBDA (FN) (DUMPDATABASE1 (GETTABLE FN (CADR DUMPTABLE)) FN] (COND (DUMPEDFLG (PRINT] (TERPRI) (PRIN1 '%)) (TERPRI]) (DUMPDATABASE1 [LAMBDA (VALUE FN) (* rmk%: "24-OCT-79 10:02") (COND (FN (COND ((NOT DUMPEDFLG) (SETQ DUMPEDFLG (PRIN2 (CAR DUMPTABLE))) (SPACES 1))) (PRIN2 FN) (SPACES 1) (PRIN2 VALUE) (SPACES 1]) (READATABASE [LAMBDA NIL (* ; "Edited 3-Jun-88 12:34 by jrb:") [SELECTQ (RATOM) ((%[ %()) (HELP '(BAD DATABASE] (MSINIT) (SETQ MSDBEMPTY) (PROG (TAB FN NEWREL NAME) (while (SETQ NAME (READ)) do (SELECTQ NAME (USERTEMPLATES (while (SETQ FN (READ)) do (TEMPLATE FN (READ) T))) (COND ((SETQ TAB (FASSOC NAME MSDATABASELST)) (while (SETQ FN (READ)) do (PUTHASH FN T MSCHANGEDARRAY) (SETQ NEWREL (MKLIST (READ))) (STORETABLE FN TAB NEWREL) (PUTHASH FN NIL MSCHANGEDARRAY))) (T (LISPXPRINT "*** incompatible MASTERSCOPE data base" T T) (while (READ]) ) (RPAQQ DATABASECOMS ((E (DUMPDATABASE)))) (ADDTOVAR GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE))) (RPAQQ MSCHECKBLOCKSCOMS ((FNS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE GLOBALVARP PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT) (BLOCKS (MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) (NOLINKFNS . T) (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS DONTCOMPILEFNS ENTRIES) (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) GLOBALVARP)))) (DEFINEQ (MSCHECKBLOCKS [LAMBDA (FILES) (* ; "Edited 2-Jun-88 13:45 by jrb:") (PROG ((LOCALVARS SYSLOCALVARS) (SPECVARS T) FNS BLOCKS NOBLOCKFNS TEM) [COND ((NULL FILES) (SETQ FILES FILELST)) ((NLISTP FILES) (SETQ FILES (OR (GETP FILES 'FILEGROUP) (LIST FILES] [for FL in FILES do (MSNOTICEFILE FL) (SETQ BLOCKS (NCONC (FILECOMSLST FL 'BLOCKS) BLOCKS)) (* ;;  "JRB - Check now gathers everything analyzable, not just FNS") (MAPC [SETQ TEM (for FT in MSFNTYPES join (FILECOMSLST FL (ffetch (MSANALYZABLE FILEPKGNAME) of FT] (FUNCTION UPDATEFN)) (SETQ FNS (NCONC TEM FNS)) (COND ((SETQ TEM (FILECOMSLST FL 'LOCALVARS)) (APPLY (FUNCTION LOCALVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'SPECVARS)) (APPLY (FUNCTION SPECVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'GLOBALVARS)) (* ;; "Ordinarily a noop, since noticing the file sets up GLOBALVARS (unlike SPECVARS and LOCALVARS, which are EVAL@COMPILE); however, user might have edited coms since then") (APPLY (FUNCTION ADDTOVAR) (CONS 'GLOBALVARS TEM] (UPDATECHANGED) (TAB 0 0) (COND ((SETQ NOBLOCKFNS (for FN in FNS unless [OR (MEMB FN DONTCOMPILEFNS) (for BLOCK in BLOCKS thereis (MEMB FN (CDR BLOCK] collect FN)) (MSCHECKBLOCK (CONS (COND [BLOCKS (APPEND '("no block - ") (COND [(CDDDDR NOBLOCKFNS) (APPEND (LDIFF NOBLOCKFNS (CDDDDR NOBLOCKFNS )) '("--"] (T NOBLOCKFNS] (T (CONS "File" FILES))) NOBLOCKFNS) FNS BLOCKS))) (for BLOCK in BLOCKS do (MSCHECKBLOCK BLOCK FNS BLOCKS]) (MSCHECKBLOCK [LAMBDA (BLOCK FNS BLOCKS) (* ; "Edited 3-Jun-88 10:50 by jrb:") (LET ((SPECVARS SPECVARS) (LOCALVARS LOCALVARS) (BLKNAME (CAR BLOCK)) BLKAPPLYFNS ENTRIES LOCALFREEVARS BLKFNS FREEVARS TEM TEM2 BOUNDFREE BLKAPPLYCALLERS ERRORS SHOULDBESPECVARS (GLOBALVARS GLOBALVARS) (RETFNS RETFNS) (BLKLIBRARY BLKLIBRARY) (NOLINKFNS NOLINKFNS) (LINKFNS LINKFNS) (DONTCOMPILEFNS DONTCOMPILEFNS)) (DECLARE (SPECVARS GLOBALVARS RETFNS BLKLIBRARY NOLINKFNS LINKFNS DONTCOMPILEFNS)) (COND ((LISTP BLKNAME) (SETQ BLKNAME NIL))) [COND (BLKNAME (SETQ LOCALVARS T) (SETQ SPECVARS (COND ((NEQ SPECVARS T) (UNION SYSSPECVARS SPECVARS)) (T SYSSPECVARS] [for X in (CDR BLOCK) do (* ; "set up declarations and BLKFNS") (COND ((LISTP X) [SETQ TEM (COND ((EQ (CADR X) '*) (EVAL (CADDR X))) (T (CDR X] (SET (CAR X) (COND ((NLISTP (CDR X)) (CDR X)) ([LISTP (SETQ TEM2 (EVALV (CAR X] (APPEND TEM TEM2)) (T TEM))) (* ;; "ASSERT: ((REMOTE EVAL) SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)") (SELECTQ (CAR X) (SPECVARS (COND ((EQ TEM T) (SETQ LOCALVARS SYSLOCALVARS)))) (LOCALVARS (COND ((EQ TEM T) (SETQ SPECVARS SYSSPECVARS)))) ((LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)) (DOERROR (CAR X) "unrecognized item in block declaration"))) ((MEMB X BLKFNS) (DOERROR X "on block twice")) (T (SETQ BLKFNS (CONS X BLKFNS] (COND (BLKNAME (MSCHECKBLOCKBASIC BLOCK BLKNAME)) (T (COND (BLKAPPLYFNS (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but not a real block" NIL T))) (SETQ BLKLIBRARY NIL))) (for FN in BLKFNS do (OR (FMEMB FN FNS) (FMEMB FN BLKLIBRARY) (DOERROR FN "not on the file")) (COND (BLKNAME (* ; "a real block") (MSCHECKFNINBLOCK FN BLOCK BLOCKS))) [for VAR in (UNION (SETQ TEM (GETRELQ (BIND NOTUSE) FN)) (GETRELQ (USE CL:LOCALLY) FN)) do [OR (FMEMB VAR BOUNDFREE) (FMEMB VAR SYSSPECVARS) (GLOBALVARP VAR) (COND ((TESTRELQ (USE FREELY) VAR T) (* ;  "i.e. it is bound in this block, and used freely by someone else") (SETQ BOUNDFREE (CONS VAR BOUNDFREE))) ((SPECVARP VAR FN) (AND (NEQ SPECVARS T) (UNECCSPEC FN VAR))) ((FMEMB VAR TEM) (DOERROR FN "binds and never uses" VAR T] (COND ((AND (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (NOT (SPECVARP VAR FN))) (DOERROR VAR "should be SPECVAR (used in functional arg) in" FN T] (SETQ FREEVARS (UNION (GETRELQ (USE FREELY) FN) FREEVARS))) (MSCHECKBOUNDFREE BOUNDFREE BLKNAME) [for VAR in FREEVARS unless (OR (FMEMB VAR SHOULDBESPECVARS) (FMEMB VAR SYSSPECVARS) (FMEMB VAR (LISTP SPECVARS)) (FMEMB VAR LOCALFREEVARS) (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR) (CL:CONSTANTP VAR) (GET VAR 'GLOBALLY-SPECIAL)) do (COND ((NULL (SETQ TEM (for FN in (GETRELQ (USE FREELY) VAR T) when (FMEMB FN BLKFNS) collect FN))) (* ; "Nobody uses it??") ) ((TESTRELQ BIND VAR T) (DOERROR VAR "not declared, used freely by " TEM 0)) ((NOT (BOUNDP VAR)) (DOERROR VAR "not declared, never bound, no top-level value, used freely by" TEM T)) (T (DOERROR VAR "not bound, not a GLOBALVAR, used freely by" TEM T] (for DEC in BLOCK when (LISTP DEC) do (SELECTQ (CAR DEC) ((SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS) (for VAR in (CDR DEC) unless (OR (FMEMB VAR BOUNDFREE) (FMEMB VAR FREEVARS) (for FN in (GETRELQ BIND VAR T) thereis (FMEMB FN BLKFNS))) do (DOERROR VAR "not mentioned in block, but on" (CAR DEC) T))) NIL)) (COND (ERRORS (OR (ZEROP (POSITION)) (TERPRI)) (TERPRI) (PRIN1 "<<<<< In "))) [MSMSGPRINT (OR (CAR BLOCK) (CONS NIL (NCONC (for X in (CDR BLOCK) collect X repeatuntil (NLISTP X)) '(--] (COND (ERRORS (PRIN1 ": >>>>>") (MAPC (SETQ ERRORS (DREVERSE ERRORS)) (FUNCTION PRINTERROR)) (PRIN1 "---------------- ")) (T (PRIN1 ", "]) (MSCHECKFNINBLOCK [LAMBDA (FN BLOCK BLOCKS) (* bvm%: "26-Mar-84 12:02") (* * Checks things related to FN in a real block) (PROG (INDIRECTCALLERS MACRODEF ISCALLEDP) (COND ([AND (SETQ MACRODEF (GETPROP FN 'MACRO)) (OR (NULL (CAR MACRODEF)) (LISTP (CAR MACRODEF))) (NOT (FMEMB FN ENTRIES)) (NOT (MSFIND MACRODEF 'IGNOREMACRO] (* no point in having it in the block, since all of the other block fns would  get the -  however, computed macros might return IGNOREMACRO) (DOERROR FN "internal block function with MACRO property" NIL T))) (COND ((AND (NOT (FMEMB FN ENTRIES)) (NOT (FMEMB FN BLKLIBRARY))) (* Check that internal FN is not called from outside the block) (SETQ ISCALLEDP NIL) [for FN2 in (UNION (SETQ INDIRECTCALLERS (GETRELQ (CALL INDIRECTLY) FN T)) (GETRELQ (CALL DIRECTLY) FN T)) do (* FN2 calls FN) (COND ((AND (NEQ FN2 FN) (FMEMB FN2 BLKFNS)) (* is called by somebody in the  block) (SETQ ISCALLEDP T))) (COND [(NOT (FMEMB FN2 BLKFNS)) (COND ([NOT (for OTHERBLOCK in BLOCKS thereis (AND (NEQ OTHERBLOCK BLOCK) (MEMB FN (CDR OTHERBLOCK)) (OR (NULL (CAR OTHERBLOCK)) (MEMB FN2 (CDR OTHERBLOCK] (* called by FN2 outside the block, and FN is not also a member of a block  containing FN2) (DOERROR FN "not an entry, called from outside the block by" FN2] ((FMEMB FN2 INDIRECTCALLERS) (* called indirectly) (OR (FMEMB FN RETFNS) (FMEMB FN BLKAPPLYFNS) (DOERROR FN "not an entry or on RETFNS or BLKAPPLYFNS, called indirectly by" FN2] (COND ((AND (NOT ISCALLEDP) (NOT (FMEMB FN BLKAPPLYFNS))) (DOERROR FN "not an entry, not called from inside the block"]) (MSCHECKBLOCKBASIC [LAMBDA (BLOCK BLKNAME) (* bvm%: "26-Mar-84 11:45") (* check for things having to do  with real blocks) [COND ((AND (NULL ENTRIES) (MEMB BLKNAME BLKFNS)) (COND ((NEQ BLKNAME (CADR BLOCK)) (DOERROR BLKNAME "must also be the FIRST function in the block"] [COND ((AND (EQ BLKNAME (CAR ENTRIES)) (NULL (CDR ENTRIES)) (NULL BLKAPPLYFNS)) (* MKENTRIES treats the case of ENTRIES=NIL specially by not setting up a  separate BLOCK.) (SETQ ENTRIES NIL)) ((AND (NULL ENTRIES) BLKAPPLYFNS) (* Above caper only works if no  BLKAPPLYFNS) (SETQ ENTRIES (LIST BLKNAME] (COND ((MEMB BLKNAME ENTRIES) (DOERROR BLKNAME "can't be both entry and block name"))) (for X in [APPEND BLKAPPLYFNS (OR ENTRIES (SETQ ENTRIES (LIST BLKNAME] do (OR (MEMB X BLKFNS) (DOERROR X "on ENTRIES or BLKAPPLYFNS but not in block"))) (for FN in BLKLIBRARY when (AND [NOT (FMEMB FN '(EQUAL GETPROP GETP NTH TAILP MEMBER] (for Y in (GETRELQ (CALL NOTERROR) FN T) thereis (FMEMB Y BLKFNS))) do (COND ((NULL (GETPROP FN 'BLKLIBRARYDEF)) (DOERROR FN "on BLKLIBRARY but no BLKLIBRARYDEF property" NIL T))) (SETQ BLKFNS (NCONC1 BLKFNS FN))) (COND ([AND BLKAPPLYFNS (NOT (SETQ BLKAPPLYCALLERS (for X in '(BLKAPPLY BLKAPPLY*) join (for Y in (GETRELQ (CALL NOTERROR) X T) when (FMEMB Y BLKFNS) collect Y] (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but no calls to BLKAPPLY in block" NIL T]) (MSCHECKBOUNDFREE [LAMBDA (BOUNDFREE BLKNAME) (* bvm%: "26-Mar-84 12:08") (for V in BOUNDFREE do (SCRATCHASH SEEN (PROG ((USERS (GETRELQ (USE FREELY) V T)) (LF (FMEMB V LOCALFREEVARS)) (BINDERS (GETRELQ BIND V T)) LF1 SFLG) (CLRHASH SEEN) (for X in USERS do (PUTHASH X -1 SEEN)) (for X in BINDERS do (PUTHASH X 1 SEEN)) (for U in USERS do (COND ((FMEMB U BLKFNS) (COND ((FMEMB U BINDERS) (NECCSPEC V U U))) (SETQ LF1 LF))) (MSCHECKVARS1 U)) (COND ((AND (NULL SFLG) (OR BLKNAME (EQ LOCALVARS T)) (NEQ SPECVARS T)) (for X in BINDERS when (FMEMB X BLKFNS) do (SELECTQ (GETHASH X SEEN) (2) (-1) (AND (SPECVARP V X) (UNECCSPEC X V]) (GLOBALVARP [LAMBDA (X) (* lmm "31-DEC-78 15:23") (OR (FMEMB X GLOBALVARS) (GETPROP X 'GLOBALVAR]) (PRINTERROR [LAMBDA (ERR) (* lmm "24-FEB-79 21:15") (PROG ((MSG (CAR ERR)) (VALS (CDDR ERR)) NEWPRS PR POS POS2 (LL (IDIFFERENCE (LINELENGTH) 30)) POS3) (SELECTQ (CAR MSG) (0 (SETQ MSG (CDR MSG)) (PRIN1 " (note) ")) (T (SETQ MSG (CDR MSG)) (PRIN1 " (possible error) ")) (PRIN1 " (probable error) ")) (COND (VALS (for X inside VALS do (PRIN2 X) (SPACES 1)) (PRIN1 '-) (for X inside MSG do (SPACES 1) (PRIN1 X)) (PRIN1 '%.) (TERPRI))) [for PRL on (DREVERSE (CADR ERR)) do [COND ([NULL (CDDR (SETQ PR (CAR PRL] (for ERR in (CDR PRL) do (COND ((EQUAL (CDR ERR) (CDR PR)) (FRPLACA ERR (CONS (CAR PR) (CAR ERR))) (FRPLACA PR NIL) (RETURN] (AND (CAR PR) (SETQ NEWPRS (CONS PR NEWPRS] (COND (NEWPRS (TAB 0 0) (SHORTLST (CAAR NEWPRS) 4) (SETQ POS (POSITION)) (PRIN1 " - ") (for X inside MSG do (PRIN1 X) (SPACES 1)) (SETQ POS2 (POSITION)) [COND ((OR (ILESSP POS2 (IDIFFERENCE POS 3)) (IGREATERP POS2 LL)) (SETQ POS2 (IPLUS POS 10] (SETQ POS3 (IDIFFERENCE (IQUOTIENT (IPLUS POS POS2) 2) 4)) (PRIN1 " -") (SHORTLST (CDAR NEWPRS) 4) (PRIN1 '". ") (MAPC (CDR NEWPRS) (FUNCTION (LAMBDA (PR) (SHORTLST (CAR PR) 4) (TAB POS T) (PRIN1 " -") (TAB POS3 T) (PRIN1 " %"%" ") (TAB POS2 T) (PRIN1 "-") (SHORTLST (CDR PR) 4) (PRIN1 ". "]) (MSCHECKVARS1 [LAMBDA (FN) (* lmm "16-Jul-84 14:54") [COND ((AND LF1 (FMEMB FN ENTRIES)) (DOERROR V [CONS "on LOCALFREEVARS" (COND ((EQ U FN) "but used freely by the entry") (T (LIST "but the entry" FN "can reach functions using it freely"] U T) (SETQ LF (SETQ LF1 NIL] (PROG ((CALLERS (GETRELQ (CALL NOTERROR) FN T)) (VAL 3)) [COND ((FMEMB FN BLKAPPLYFNS) (SETQ CALLERS (UNION BLKAPPLYCALLERS CALLERS] (* interpretation of SEEN codes -  0 recursive call -  -1 uses var -  1 binds var -  2 binds var, path from it to user -  T always bound above -  3 no callers -  4 not always bound above) (for X in CALLERS do (SELECTQ (GETHASH X SEEN) ((0 -1 4)) (3 (SETQ VAL 4)) (1 (* we have found a path from a user up to a binder -  if the path is entirely in the block, then LOCALFREEVAR is ok, -  if the path is outside the block, then it doesn't matter, otherwise SPECVAR) (COND ((FMEMB X BLKFNS) (* if the binder isn't in this  block, ignore) (* should just be SPECVAR if not entirely within the block) (NECCSPEC V X U))) (PUTHASH X 2 SEEN) (COND ((EQ VAL 3) (SETQQ VAL T)))) ((T 2) (COND ((EQ VAL 3) (SETQQ VAL T)))) (NIL (* now check recursively) (PUTHASH X 0 SEEN) (PUTHASH X (MSCHECKVARS1 X) SEEN)) (SHOULDNT 4))) (RETURN VAL]) (UNECCSPEC [LAMBDA (FN VAR) (* lmm "30-AUG-78 03:36") (OR (GLOBALVARP VAR) (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (DOERROR VAR "might not need to be a specvar in" FN T]) (NECCSPEC [LAMBDA (VAR BINDER) (* lmm "21-SEP-78 04:21") (COND ((NOT (OR SFLG (SPECVARP VAR BINDER))) (SETQ SFLG T) (SETQ SHOULDBESPECVARS (CONS VAR SHOULDBESPECVARS)) (DOERROR VAR (LIST "(used freely in)" U "is not a SPECVAR in") BINDER T]) (SPECVARP [LAMBDA (X FN) (* lmm "25-JUN-78 01:15") (COND ((FMEMB X (GETRELQ (DECLARE LOCALVARS) FN)) NIL) ((FMEMB X (GETRELQ (DECLARE SPECVARS) FN)) T) ((NEQ LOCALVARS T) (NOT (FMEMB X LOCALVARS))) (T (OR (EQ SPECVARS T) (FMEMB X SPECVARS) (FMEMB X LOCALFREEVARS) (FMEMB X GLOBALVARS) (GETP X 'GLOBALVAR]) (SHORTLST [LAMBDA (X N) (* lmm " 9-AUG-77 03:18") (COND ((NULL X) N) ((LISTP X) (SHORTLST (CDR X) (SHORTLST (CAR X) N))) (T (COND ((IGREATERP (SETQ N (SUB1 N)) 0) (SPACES 1) (PRIN2 X)) ((ZEROP N) (PRIN1 " etc"))) N]) (DOERROR [LAMBDA (AT MSG ARG QUESTIONABLE) (* lmm "21-Mar-85 08:29") [COND (QUESTIONABLE (SETQ MSG (CONS QUESTIONABLE MSG] (PROG ([L (CDR (OR (SASSOC MSG ERRORS) (CAR (SETQ ERRORS (CONS (CONS MSG (CONS)) ERRORS] (AT AT)) (COND (ARG [SETQ AT (OR (FASSOC AT (CAR L)) (CAAR (FRPLACA L (CONS (CONS AT) (CAR L] (OR (MEMBER ARG (CDR AT)) (NCONC1 AT ARG))) ((NOT (FMEMB AT (CDR L))) (FRPLACD L (CONS AT (CDR L]) (MSMSGPRINT [LAMBDA (MSG) (* ; "Edited 3-Jun-88 12:39 by jrb:") (* ;; "Prints messages Masterscope builds as lists - only atoms get prin2'ed.") (COND ((STRINGP MSG) (PRIN1 MSG)) ((CL:CONSP MSG) (PRIN1 "(") (MSMSGPRINT (pop MSG)) (while (CL:CONSP MSG) do (PRIN1 " ") (MSMSGPRINT (pop MSG))) (if MSG then (PRIN1 " . ") (MSMSGPRINT MSG)) (PRIN1 ")")) (T (PRIN2 MSG]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) (NOLINKFNS . T) (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS DONTCOMPILEFNS ENTRIES) (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) GLOBALVARP) ) (RPAQQ MSPATHSCOMS [(FNS MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN) (BLOCKS (MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING SEPARATE) (GLOBALVARS MSBLIP MSCRATCHASH) (NOLINKFNS . T]) (DEFINEQ (MSPATHS [LAMBDA (FROM TO INVERTED AVOIDING SEPARATE NOTRACE MARKING) (* ; "Edited 3-Jun-88 12:37 by jrb:") (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, or if DEPTH is exceeded -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") (SCRATCHASH SEEN (PROG (TABS (LL (LINELENGTH)) (BELOWCNT 0) (LINENUM 0) (FIRST T) X NAMED TEM (UNDONE (MSLISTSET FROM T))) (COND (INVERTED (PRINTOUT T "inverted tree" T))) [MAPC UNDONE (FUNCTION (LAMBDA (X) (PUTHASH X (COND ((AND NOTRACE (MSMEMBSET X NOTRACE)) -1) (T 0)) SEEN] (TAB 0 0) [RESETVARS ((MSPRINTFLG)) (do (COND (NAMED (OR FIRST (DASHES (GETHASH (CAR NAMED) SEEN))) (SETQ FIRST) (PUTHASH (CAR NAMED) 0 SEEN) (MSPATHS1 (CAR NAMED) NIL T) (SETQ NAMED (CDR NAMED))) (UNDONE [COND ([OR (NULL (SETQ TEM (GETHASH (CAR UNDONE) SEEN))) (EQ TEM 0) (AND (LISTP TEM) (NULL (CAR TEM] (PUTHASH (CAR UNDONE) (LIST NIL) SEEN) (SETQ NAMED (LIST (CAR UNDONE] (SETQ UNDONE (CDR UNDONE))) (T (TERPRI) (RETURN] (RETURN]) (MSPATHS1 [LAMBDA (FROM FIRST LAST) (* lmm " 4-AUG-83 23:45") (PROG (TEM THISLINE POS (XT TABS)) [COND ((NOT FIRST) (TERPRI) (SETQ LINENUM (ADD1 LINENUM)) (* if NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS) then) (PRIN1 LINENUM) (PRIN1 ".") (DOTABS (CDR TABS] (SETQ THISLINE LINENUM) (AND TABS (TAB (CAR TABS) 0)) (AND LAST (SETQ TABS (CDR TABS))) (SETQ POS (MSPATHSPRINTFN FROM)) (MSPATHS2 FROM) (COND [(NEQ (SETQ TEM (GETHASH FROM SEEN)) 0) (* Already expanded on a previous line -  or is a NOTRACE) (COND ((EQ TEM MSBLIP) (SHOULDNT 5)) ((OR (NOT (NUMBERP TEM)) (NOT (MINUSP TEM))) (PRIN1 " {") (PRIN1 (COND ((NLISTP TEM) (* Either line number or overflow  line letter) TEM) [(LISTP TEM) (* A list means that this must be a  sub-tree) (COND ((CAR TEM)) (T (FRPLACA TEM (BELOWMARKER)) (SETQ NAMED (NCONC1 NAMED FROM)) (CAR TEM] (T TEM))) (PRIN1 "}"] (T (PROG ((TABS TABS) (FIRST T) NEXTLEVEL TEM) (PUTHASH FROM (IDIFFERENCE -1 THISLINE) SEEN) (OR (SETQ NEXTLEVEL (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FROM)) (T (GETRELQ CALL FROM T))) when (MSPATHS2 Y) collect Y)) (RETURN)) (* AND (SETQ TEM (FASSOC  (QUOTE SORT) PRINTOPTIONS))  (SORT NEXTLEVEL (CDR TEM))) (COND ([AND XT (OR (SETQ TEM (AND SEPARATE (MSMEMBSET FROM SEPARATE))) (SOME NEXTLEVEL (FUNCTION (LAMBDA (FN) (IGREATERP (IPLUS (NCHARS FN) POS 6) LL] (* NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (SETQ NAMED (NCONC1 NAMED FROM)) (PRIN1 " {") [PRIN1 (COND (TEM (CAR (PUTHASH FROM (LIST (BELOWMARKER)) SEEN))) (T (PUTHASH FROM (BELOWMARKER) SEEN] (PRIN1 "}") (RETURN))) (SETQ TABS (CONS POS TABS)) (PUTHASH FROM THISLINE SEEN) (for X on NEXTLEVEL do (MSPATHS1 (CAR X) FIRST (NULL (CDR X))) (SETQ FIRST]) (MSPATHS2 [LAMBDA (FN FLG) (* lmm "20-Jul-84 14:36") (* Returns T if FN should be PRINTED -  The SEEN table contains one of the following entries for a function -  MSBLIP %: don't print the function at all -  n a number %: don't trace it, it was expanded previously -  -n %: don't trace it, it was printed earlier, though it had no sub-functions  -  0 %: yes, print and trace it -  -1 %: yes, print it, but don't trace it -  (NIL)%: it should be given a separate tree, as yet unnamed -  (letter)%: give it a separate tree with this letter name -  letter %: the function is expanded in an OVERFLOW table below) (* When below MSPATHS4 for ON PATH sets  (and CALL SOMEHOW) the SEEN table contains either 0 %: not traced yet, MSBLIP  %: don't print, -1 print, don't trace, T %: top set  (e.g. for CALLED SOMEHOW BY X, X is originally marked T) 1 already seen and  traced) (NEQ [OR (GETHASH FN SEEN) (PROGN (OR INVERTED (UPDATEFN FN NIL 0)) (COND ((AND AVOIDING (MSMEMBSET FN AVOIDING)) (* If it is avoiding, then no) (PUTHASH FN MSBLIP SEEN)) ((AND (NULL FLG) NOTRACE (MSMEMBSET FN NOTRACE)) (* Will not be traced%: entry should be either MSBLIP or -1 depending on  whether the function should be printed) (COND ((MSPATHS2 FN T) (PUTHASH FN -1 SEEN)) (T MSBLIP))) ((NULL TO) (PUTHASH FN (COND ((AND (NULL INVERTED) (GETD FN) (NOT (TESTRELQ KNOWN FN))) MSBLIP) (T 0)) SEEN)) ((MSMEMBSET FN TO) (* If it is in the TO set, then definitly YES) (PUTHASH FN 0 SEEN)) (T (* Will a path through this function eventually print out an element of TO?) (PUTHASH FN MSBLIP SEEN) (* assume not) (COND ((OR (NULL FLG) (NULL NOTRACE) (NOT (MSMEMBSET FN NOTRACE))) (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FN)) (T (GETRELQ CALL FN T))) when (MSPATHS2 Y) do (RETURN (PUTHASH FN 0 SEEN)) finally (RETURN MSBLIP))) (T MSBLIP] MSBLIP]) (MSONPATH [LAMBDA (SETREP) (* ; "Edited 15-Aug-90 11:53 by jds") (PROG ((FROM (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of SETREP))) (TO (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of SETREP))) (AVOIDING (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of SETREP) )) (NOTRACE (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of SETREP))) INVERTED (TOPFLG (fetch (PATHOPTIONS TOPFLG) of (fetch MSPATHOPTIONS of SETREP))) (SEEN (HASHARRAY 20)) TEM) (COND ((NULL FROM) (SETQ INVERTED T) (SETQ FROM TO) (SETQ TO NIL))) (SETQ TEM (MSLISTSET FROM T)) [MAPC TEM (FUNCTION (LAMBDA (X) (PUTHASH X 0 SEEN] (* 0 means yes expand, not expanded  yet) [MAPC TEM (FUNCTION (LAMBDA (X) (MSPATHS4 X TOPFLG] (RETURN SEEN]) (MSPATHS4 [LAMBDA (FROM TOP) (* lmm "25-JUN-78 01:10") (* traces paths from FROM. When done, the SEEN array will contain MSBLIP or  NIL for entries not expanded, 0 for entries which should be expanded but  weren't for some reason (probably a bug)%, 1 for entries which were below the "top"  and T for entries which were above the top only) (PROG (TEM) (COND ((MSPATHS2 FROM) (COND ((EQ (SETQ TEM (GETHASH FROM SEEN)) 0) (PUTHASH FROM (COND (TOP T) (T 1)) SEEN) (for Y in (COND (INVERTED (GETRELQ CALL FROM T)) (T (GETRELQ CALL FROM))) do (MSPATHS4 Y))) ((AND (EQ TEM T) (NOT TOP)) (PUTHASH FROM 1 SEEN]) (DASHES [LAMBDA (MARKER) (* lmm "21-JAN-79 14:28") (TERPRI) (FRPTQ (IDIFFERENCE LL 20) (PRIN1 '-)) (PRIN1 (COND ((LISTP MARKER) (* OR (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (PRIN1 "------------ ") (OR (CAR MARKER) '"")) (T (PRIN1 "--- overflow - ") MARKER]) (DOTABS [LAMBDA (LST) (* lmm%: 19 MAY 75 146) (COND ((NULL LST) NIL) (T (DOTABS (CDR LST)) (TAB (CAR LST) 0) (PRIN1 "|"]) (BELOWMARKER [LAMBDA NIL (* lmm "22-JUN-78 00:15") (* lmm%: 26 MAY 75 1751) (PROG1 [COND ((ILESSP BELOWCNT 26) (FCHARACTER (IPLUS 97 BELOWCNT))) (T (PACK* (FCHARACTER (IPLUS 97 (IREMAINDER BELOWCNT 26))) (IQUOTIENT BELOWCNT 26] (SETQ BELOWCNT (ADD1 BELOWCNT]) (MSPATHSPRINTFN [LAMBDA (FN) (* lmm "16-MAY-78 02:27") (AND MARKING (MSMEMBSET FN MARKING) (PRIN1 ">")) (PRIN2 FN) (ADD1 (POSITION]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING SEPARATE) (GLOBALVARS MSBLIP MSCRATCHASH) (NOLINKFNS . T)) ) (DEFINEQ (MSFIND [LAMBDA (IN X) (* lmm "24-JAN-79 15:16") (OR (EQ IN X) (AND (LISTP IN) (OR (MSFIND (CAR IN) X) (MSFIND (CDR IN) X]) (MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) (MSEDITE [LAMBDA ARGCOUNT (* ; "Edited 24-Oct-2018 16:25 by rmk:") (* ;  "Edited 22-Jun-93 12:14 by sybalsky:mv:envos") (* ;; "Edit something, NAME is arg 1, DEF-TO-EDIT is arg 2, FPTYPE is arg 3, TTYCOMS is args 4-n. Used when we have to fetch the definition above MSEDITF, e.g. for finding SHOW WHERE places, and it's a definer that copies when you getdef it.") (LET [(FNAME (ARG ARGCOUNT 1)) (FNDEF (ARG ARGCOUNT 2)) (FPTYPE (OR (ARG ARGCOUNT 3) 'FNS)) FPNAME (FEDITCOMS (for X from 4 to ARGCOUNT collect (ARG ARGCOUNT X] (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (COND ((EQ FPTYPE 'FNS) (APPLY 'EDITF (CONS FNAME FEDITCOMS))) (T (EDITE FNDEF FEDITCOMS FNAME FPNAME))) FPNAME]) (EDITGETDEF [LAMBDA (NAME TYPE) (* ;  "Edited 23-Jun-93 10:24 by sybalsky:mv:envos") (* ;; "This is meant to encapsulate the notion of asking the active editor, %"Are you editing the definition for this object? If so, give me the true definition you're editing%". Called from MSGETDEF to get the REALDEF for an object to be EDIT WHERE'd, so the editor == command works right.") (AND (EQ (EDITMODE) 'SEDIT:SEDIT) (bind SEDIT::WINDOW for SEDIT::CONTEXT in SEDIT::CONTEXTS when (AND NAME (CL:EQUAL NAME (fetch SEDIT::ICON-TITLE of SEDIT::CONTEXT)) (EQ TYPE (fetch SEDIT::EDIT-TYPE of SEDIT::CONTEXT))) do (* ;; "we found a context that matches, return it.") (RETURN (fetch CL:STRUCTURE of (SEDIT::SUBNODE 1 (fetch SEDIT::ROOT of SEDIT::CONTEXT]) ) (RPAQQ MSBLIP "sysout and inform Masinter@PARC") (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE." ) (RPAQ? MSFNTYPES '((FNS FNS GETDEF))) (* ; "SCRATCHASH") (RPAQ? MSCRATCHASH ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS SCRATCHASH MACRO [(ARRAYNAME . FORMS) ([LAMBDA (ARRAYNAME) (SETQ MSCRATCHASH) (PROG1 (PROGN . FORMS) (SETQ MSCRATCHASH ARRAYNAME] (COND (MSCRATCHASH (CLRHASH MSCRATCHASH) MSCRATCHASH) (T (HASHARRAY 20 (FUNCTION MSREHASH]) ) ) (* ; "marking changed") (DEFINEQ (MSMARKCHANGED [LAMBDA (NAME TYPE REASON) (* ; "Edited 8-Apr-88 10:17 by jrb:") (* ;; "Called from inside MARKASCHANGED") (* ;; "JRB - Some things need to be MARKASCHANGED strangely (FUNCTIONS that are actually DEFMACROS need to have CHANGEMACRO called, but not MSMARKCHANGE1, for instance). If there is a function in the MARKCHANGED-FN slot of the appropriate MSANALYZABLE record, and it returns non-NIL, MSMARKCHANGE1 gets called.") (AND MSDATABASELST (LET (ATYPEREC MSMCFN) (if (OR (NULL TYPE) (SETQ ATYPEREC (ASSOC TYPE MSFNTYPES))) then (COND ((EQ REASON 'DELETED) (MSERASE (LIST NAME))) ((OR (NOT (SETQ MSMCFN (fetch (MSANALYZABLE MARKCHANGED-FN) ATYPEREC))) (APPLY* MSMCFN NAME TYPE REASON)) (MSMARKCHANGE1 NAME 0))) (SELECTQ TYPE ((VARS VARIABLES T) (CHANGEVAR NAME TYPE REASON)) (MACROS (CHANGEMACRO NAME TYPE REASON)) (I.S.OPRS (CHANGEI.S. NAME TYPE REASON)) NIL]) (CHANGEMACRO [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:17 by jrb:") (* ;; "We don't do anything if the item is being defined. This is a heuristic that compensates for the fact that a database can be loaded from a file before the definitions that it knows about come in. We don't want a subsequent LOADFROM of a file to generate all sorts of probably spurious messages.") (AND MSDATABASELST (NEQ REASON 'DEFINED) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) (FILEPKGTYPE TYPE 'DESCRIPTION) (EQ (GETTEMPLATE NAME T) 'MACRO]) (CHANGEVAR [LAMBDA (NAME TYPE REASON) (* rmk%: "19-FEB-81 15:22") (DECLARE (GLOBALVARS COMPILE.TIME.CONSTANTS)) (AND MSDATABASELST (FMEMB NAME COMPILE.TIME.CONSTANTS) (MSNEEDUNSAVE (GETRELATION NAME '(USE FREELY) T) "constants"]) (CHANGEI.S. [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:18 by jrb:") (AND MSDATABASELST (SELECTQ REASON (DEFINED (* ;; "If it has a function definition, then defining it as an i.s.opr has no effect (at least for interpreted code)") (AND (NOT (GETD NAME)) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) '(i.s.oprs as functions) T))) ((CHANGED DELETED) (MSNEEDUNSAVE (UNION (GETRELATION NAME '(USE I.S.OPRS) T) (AND (U-CASEP NAME) (GETRELATION (L-CASE NAME) '(USE I.S.OPRS) T))) "i.s. oprs" T)) NIL]) (CHANGERECORD [LAMBDA (RNAME RFIELDS OLDFLG) (* ; "Edited 3-Jun-88 12:12 by jrb:") (AND MSDATABASELST OLDFLG (MSNEEDUNSAVE (PROG ((FNLIST (GETRELATION RNAME '(USE RECORDS) T))) (for F in RFIELDS do (SETQ FNLIST (UNION (GETRELATION F '(USE FIELDS) T) FNLIST))) (RETURN FNLIST)) "records" MSRECORDTRANFLG]) (MSNEEDUNSAVE [LAMBDA (FNS MSG MARKCHANGEFLG) (* rmk%: "22-MAY-81 13:23") (AND MARKCHANGEFLG (MSMARKCHANGE1 FNS)) (COND ((AND CHECKUNSAVEFLG (SETQ FNS (for FN inside FNS when (NOT (OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (FMEMB FN MSNEEDUNSAVE))) collect FN))) (COND ((EQ CHECKUNSAVEFLG '!) (UNSAVEFNS FNS)) (T (printout T "The functions " .PARA2 0 0 FNS " use " MSG " which have changed." T "Call UNSAVEFNS() to load and/or UNSAVEDEF them." T) (/SETATOMVAL 'MSNEEDUNSAVE (NCONC FNS MSNEEDUNSAVE]) (UNSAVEFNS [LAMBDA (FNS) (* ; "Edited 3-Jun-88 12:24 by jrb:") (OR FNS (SETQ FNS (APPEND MSNEEDUNSAVE))) (for FN in FNS when FN bind FNTYPE do [SETQ FNTYPE (for FNREC in MSFNTYPES when (HASDEF FN (fetch (MSANALYZABLE FILEPKGNAME) FNREC) '? '(NOERROR)) do (RETURN (fetch (MSANALYZABLE FILEPKGNAME) FNREC] [OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (PROG NIL (COND ((FGETD FN) (VIRGINFN FN T) (SAVEDEF FN))) (SELECTQ RECOMPILEDEFAULT (CHANGES (* don't mark as changed) (RESETVARS (MSDATABASELST) (* ASSERT%: ((REMOTE CALL)  MSMARKCHANGED)) (MARKASCHANGED FN FNTYPE))) (EXPRS (for FL in (WHEREIS FN FNTYPE FILELST) unless [OR (FMEMB FL NOTCOMPILEDFILES) (CDR (GETP FL 'FILE] do (/SETATOMVAL 'NOTCOMPILEDFILES (CONS FL NOTCOMPILEDFILES) ))) NIL) (COND ((HASDEF FN FNTYPE 'SAVED) (PRINTOUT T "unsaving " FN T) (UNSAVEDEF FN FNTYPE)) (T (PRINTOUT T "loading " FN T) (LOADDEF FN FNTYPE '?] (/SETATOMVAL 'MSNEEDUNSAVE (REMOVE FN MSNEEDUNSAVE))) (AND FNS (EQ RECOMPILEDEFAULT 'CHANGES) (printout T "WARNING: you must set RECOMPILEDEFAULT to EXPRS in order to have these functions recompiled automatically" T]) ) (ADDTOVAR COMPILE.TIME.CONSTANTS ) (RPAQQ RECORDCHANGEFN CHANGERECORD) (RPAQ? CHECKUNSAVEFLG T) (RPAQ? MSNEEDUNSAVE ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS GETWORDTYPE MACRO [(WORD TYPE) (CDR (FASSOC TYPE (GETHASH WORD MSWORDS]) ) ) (* ; "interactive routines") (RPAQ MASTERSCOPEDATE "19-Sep-2020") (ADDTOVAR HISTORYCOMS %.) (DEFINEQ (%. [NLAMBDA MASTERSCOPECOMMAND (* lmm "16-MAY-78 01:07") (MASTERSCOPE MASTERSCOPECOMMAND]) (MASTERSCOPE [LAMBDA (MASTERSCOPECOMMAND TOPFLG) (* ; "Edited 5-Dec-86 06:08 by lmm") (* ;; "Top level entry. If given a sentence, parse it and return; otherwise, enter into USEREXEC-like loop") (COND (MASTERSCOPECOMMAND (MSINTERPRET (MKLIST MASTERSCOPECOMMAND) (NOT TOPFLG))) (T (PRINTOUT T "Type Masterscope commands to the exec using the . command, e.g." T ". WHO CALLS 'MASTERSCOPE" T]) (MASTERSCOPE1 [LAMBDA NIL (* ; "Edited 28-Jan-88 11:28 by jrb:") (* ;  "merged from smL Loops Masterscope by JRB") (printout T "Masterscope " MASTERSCOPEDATE T) (PROG (X (*PACKAGE* (CL:FIND-PACKAGE "IL"))) ERLP [ERSETQ (PROGN (PROMPTCHAR "_. " T LISPXHISTORY) (SELECTQ (SETQ X (LISPXREAD T T)) ((E _) (LISPX (LISPXREAD T T) '_)) ((OK STOP) (RETFROM (FUNCTION MASTERSCOPE1))) (LISPX X '_ NIL (FUNCTION MASTERSCOPEXEC] (GO ERLP]) (MASTERSCOPEXEC [LAMBDA (X LINE) (* ; "Edited 17-Jun-87 16:57 by jrb:") (* Called via the LISPX in  MASTERSCOPE) (* ;  "Merged from smL Loops Masterscope by JRB") (PROG (MASTERSCOPECOMMAND) (AND [OR [COND ((NULL LINE) (* Single entry on line) (OR (NOT (LITATOM X)) (OR (NEQ (EVALV X) 'NOBIND) (STRPOSL CLISPCHARRAY X] (AND (LITATOM X) (FGETD X) (LISTP LINE) (OR [COND ((NULL (CDR LINE)) (* "EDITF ] " OR SETQ  (A B) TYPE ENTRY) (OR (NULL (CAR LINE)) (LISTP (CAR LINE] (EQ (ARGTYPE X) 3] (RETURN)) (* If MASTERSCOPEXEC returns NIL, then LISPX will handle the event as a  normal typin) (SETQ MASTERSCOPECOMMAND (CONS X LINE)) (SELECTQ (CAR MASTERSCOPECOMMAND) ((OK STOP BYE ok stop) (RETFROM 'MASTERSCOPE1 NIL T)) NIL) LISPXVALUE [AND (LISTP LISPXHIST) (FRPLACA LISPXHIST (CONS '%. (CAR LISPXHIST] (* Make sure the event shows up with a %.  in it) (SETQ LISPXVALUE (MSINTERPRET MASTERSCOPECOMMAND)) (RETURN T]) ) (* ; "Interpreting commands") (DEFINEQ (MSINTERPRETSET [LAMBDA (SET OP ARG) (* ; "Edited 15-Aug-90 11:50 by jds") (* ;; "DECLARATIONS%%: (RECORDS SENTENCE MSSETPHRASE)")  (* ; "Edited 3-Jun-88 12:42 by jrb:") (PROG (TEM TYPE (REP (fetch (MSSETPHRASE REP) of SET))) START [COND [(NLISTP REP) (OR (NULL REP) (SHOULDNT (LIST REP TEM TYPE ARG))) [COND ((fetch (MSSETPHRASE TYPE) of SET) [replace (MSSETPHRASE REP) of SET with (create INRELATION HTABLES _ (for TYPE inside (fetch (MSSETPHRASE TYPE) of SET) join (GETVERBTABLES 'IS TYPE)) OSET _ (create MSSETPHRASE DET _ 'ANY] (RETURN (MSINTERPRETSET SET OP ARG] (RETURN (SELECTQ OP (CHECK ARG) (LIST MSBLIP) (HARD (LISTHARD SET)) (MEMB T) (SHOULDNT 8] (T (RETURN (SELECTQ (fetch (SENTENCE ID) of REP) (APPLY (SELECTQ OP (CHECK ARG) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (APPLY* (fetch (APPLY PRED) of REP) ARG)) (SHOULDNT 9))) (NOT (SELECTQ OP (CHECK (MSINTERPRETSET (fetch NEGATED of REP) 'CHECK ARG)) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (NOT (MSINTERPRETSET (fetch NEGATED of REP) 'MEMB ARG))) (SHOULDNT 10))) (INRELATION (SELECTQ OP (CHECK ARG) ((LIST HARD) (* ;; "got a list of dotted pairs of hash tables and another set; want to know the set of all things which have the given relation to any in the other set") (PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) V SET2VAL) (SETQ SET2VAL (MSINTERPRETSET OTHERSET 'LIST)) [COND [(EQ SET2VAL MSBLIP) (for R in HTABS do (MAPTABLE (COND (INVERTED (CDR R)) (T (CAR R))) (FUNCTION MSINTERPA] (T (for R in HTABS do (for X in SET2VAL do (SETQ V (UNION [GETTABLE X (COND (INVERTED (CAR R)) (T (CDR R] V] (RETURN V))) (MEMB [PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP))) (RETURN (find R in HTABS suchthat (find Z in [GETTABLE ARG (COND (INVERTED (CDR R)) (T (CAR R] suchthat (MSINTERPRETSET OTHERSET 'MEMB Z]) (SHOULDNT 11))) (GETHASH (SELECTQ OP (CHECK ARG) ((LIST HARD) (PROG (V) [for X in (fetch (GETHASH HTABLE) of REP) do (SETQ V (MSHASHLIST X V NIL (fetch (GETHASH BADMARKS) of REP] (RETURN V))) (MEMB [SOME (fetch (GETHASH HTABLE) of REP) (FUNCTION (LAMBDA (H) (AND (SETQ H (GETTABLE ARG H)) (NEQ H MSBLIP) (NOT (EQMEMB H (fetch (GETHASH BADMARKS) of REP]) (SHOULDNT 12))) (QUOTE (SELECTQ OP (CHECK (COND (ARG (SETQ NEEDUPDATE (UNION NEEDUPDATE (fetch QUOTED of REP))) NIL))) ((HARD LIST) (SETQ TYPE (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET))) (COND ([AND ARG (NEQ ARG 'FILES) (NEQ TYPE 'FILES) (FMEMB (SETQ TEM (fetch QUOTED of REP)) FILELST) (COND ((EQ ARG 'KNOWN) (NOT (OR (TESTRELQ KNOWN TEM) (GETD TEM] (replace (MSSETPHRASE TYPE) of SET with (COND ((EQ ARG 'KNOWN) 'FNS) (T ARG))) (SETQ TEM (for FILE in (fetch QUOTED of REP) join (ONFILE FILE ARG))) (printout T (fetch QUOTED of REP) " => ON " (fetch QUOTED of REP) T) (replace QUOTED of (fetch (MSSETPHRASE REP) of SET) with TEM)) (T (COND ([AND (EQ TYPE 'FNS) (GETP (fetch QUOTED of REP) 'CLISPWORD) (NOT (GETD (fetch QUOTED of REP] (printout T "Warning: " (fetch QUOTED of REP) "is a CLISP word and is not treated like a function!" T))) (fetch QUOTED of REP)))) (MEMB (FMEMB ARG (fetch QUOTED of REP))) (SHOULDNT 13))) (OR (* ;; "I.e. WHO ON MYFILE OR @ EXPRP CALL X --- if either of the sets need to be KNOWN and are 'vague' then the entire world needs to be updated") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((LIST HARD) [PROG (S1 S2) (RETURN (COND ((EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) OP))) MSBLIP) ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) (OR [EQ 'QUOTE (fetch (SENTENCE ID) of (fetch (MSSETPHRASE REP) of (fetch (CSET SET1) of REP] (replace (MSSETPHRASE REP) of (fetch (CSET SET1) of REP) with (create QUOTE QUOTED _ S1))) MSBLIP) (T (UNION S1 S2]) (MEMB (OR (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 14))) (AND (* ; "I.e. WHO ON MYFILE AND @ EXPRP CALL Z -- only if both sets are vague does the world need updating") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((HARD LIST) [PROG (S1 S2) (RETURN (COND [[EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) 'LIST] (COND ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) MSBLIP) (T (SUBSET S2 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB X] (T (SUBSET S1 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB X]) (MEMB (AND (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 15))) (ANDNOT (replace (SENTENCE ID) of REP with 'AND) [replace (MSSETPHRASE REP) of (fetch SET2 of REP) with (create NOT NEGATED _ (create MSSETPHRASE using (fetch SET2 of REP) REP _ (fetch (MSSETPHRASE REP) of (fetch SET2 of REP] (GO RETRY)) (IN [SETQ REP (create QUOTE QUOTED _ (MKLIST (CL:EVAL (fetch (IN EXPRESSION) of REP] (GO RETRY)) (BLOCKS (* ; "Block set") (SELECTQ OP (CHECK [[LAMBDA (X Y) (OR X Y] (AND (fetch FNS of REP) (MSINTERPRETSET (fetch FNS of REP) 'CHECK)) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'CHECK]) (PROGN [SETQ REP (create QUOTE QUOTED _ (MSGETBLOCKDEC (fetch TYPES of REP) (fetch FNS of REP) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'HARD] (GO RETRY)))) (FIELDS (SELECTQ OP (CHECK (MSINTERPRETSET (fetch RECS of REP) OP)) (PROGN [SETQ REP (create QUOTE QUOTED _ (PROG (VAL) (for X in (MSLISTSET (fetch RECS of REP) T) do (SETQ VAL (UNION (RECORDFIELDNAMES X) VAL))) (RETURN VAL] (GO RETRY)))) (THAT (PROG (TABLES (MSVERB (fetch (THAT MSVERB) of REP)) VALUE (OS (fetch (THAT OTHERSET) of REP))) (SELECTQ (fetch (MSVERB ROOT) of MSVERB) ((AND OR ANDNOT) [SETQ REP (create CSET ID _ (fetch (CVERB C) of (fetch VPART of MSVERB)) SET1 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB1) of (fetch VPART of MSVERB))) OTHERSET _ OS)) SET2 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB2) of (fetch VPART of MSVERB))) OTHERSET _ OS] (GO RETRY)) (CALL (COND ((EQ (fetch (MSVERB MODIFIER) of MSVERB) 'SOMEHOW) [SETQ REP (create PATHS MSPATHOPTIONS _ (COND ((EQ (fetch TENSE of MSVERB) 'ED) (create PATHOPTIONS FROM _ OS TO _ (create MSSETPHRASE) TOPFLG _ T)) (T (create PATHOPTIONS TO _ OS TOPFLG _ T] (GO RETRY)))) (CONTAIN (COND ((EQ (fetch DET of OS) 'WHICH) (SHOULDNT 16))) (* ;; "JRB - Default types on files are now ignored - removed (|fetch| (MSSETPHRASE DEFAULTTYPE) |of| SET) from ORs below.") [SETQ REP (create QUOTE QUOTED _ (SELECTQ (fetch TENSE of MSVERB) (ED (ONFILE (MSINTERPRETSET OS 'HARD) (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of SET) 'ALL))) (ONFILE NIL (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of OS) 'ALL) (OR (MSINTERPRETSET OS 'HARD) T] (GO RETRY)) NIL) (SELECTQ OP (CHECK (SETQ VALUE (MSINTERPRETSET OS 'CHECK (fetch KNOWN of OS)))) NIL) (SETQ TABLES (GETVERBTABLES (fetch (MSVERB ROOT) of MSVERB ) (fetch (MSVERB MODIFIER) of MSVERB))) (replace REP of SET with (SETQ REP (create INRELATION INVERTED _ (EQ (fetch TENSE of MSVERB) 'ED) HTABLES _ TABLES OSET _ OS))) OUT (RETURN (OR (MSINTERPRETSET SET OP ARG) VALUE)))) (PATHS (COND ((EQ OP 'CHECK) (CHECKPATHS (fetch MSPATHOPTIONS of REP))) (T (SETQ REP (create GETHASH HTABLE _ (LIST (MSONPATH REP)) BADMARKS _ T)) (GO RETRY)))) (SHOULDNT 17] RETRY (replace REP of SET with REP) (GO START]) (MSINTERPA [LAMBDA (VAL KEY) (* DECLARATIONS%: (RECORDS SETPHRASE)) (* ; "Edited 12-Jan-87 01:20 by jds") (AND (NOT (FMEMB KEY V)) [COND ((AND (NULL (fetch (MSSETPHRASE TYPE) of OTHERSET)) (NULL (fetch REP of OTHERSET))) VAL) (T (find Z in VAL suchthat (MSINTERPRETSET OTHERSET 'MEMB Z] (SETQ V (CONS KEY V]) (MSGETBLOCKDEC [LAMBDA (TYPE FNSET FILES) (* lmm "24-FEB-79 20:50") (PROG (VAL) [for FILE inside (OR FILES FILELST) do ([for BLOCK in (FILECOMSLST FILE 'BLOCKS) when [OR (NULL FNSET) (SOME BLOCK (FUNCTION (LAMBDA (FILE) (AND (LITATOM FILE) (MSMEMBSET FILE FNSET] do ([SELECTQ TYPE ((BLKFNS BLOCK NIL) (for FILE in (CDR BLOCK) when (AND (LITATOM FILE) (NOT (FMEMB FILE VAL))) do (SETQ VAL (CONS FILE VAL)))) (for Y in BLOCK when (AND (LISTP Y) (EQMEMB (CAR Y) TYPE)) do (SETQ VAL (UNION (COND ((EQ (CADR Y) '*) (EVAL (CADDR Y))) (T (CDR Y))) VAL] (COND ((AND (EQ TYPE 'ENTRIES) (CAR BLOCK) (FMEMB (CAR BLOCK) (CDR BLOCK)) (NOT (FMEMB (CAR BLOCK) VAL))) (SETQ VAL (CONS (CAR BLOCK) VAL] (OR FNSET (SETQ VAL (UNION (FILECOMSLST FILE (SELECTQ TYPE (BLKFNS 'FNS) TYPE)) VAL] (RETURN VAL]) (LISTHARD [LAMBDA (SET) (* DECLARATIONS%: (RECORDS  MSSETPHRASE)) (* ; "Edited 12-Jan-87 00:59 by jds") (PROG (VAL) [for TYPE inside (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET)) do (for TABLE in (GETVERBTABLES 'IS (COND ((AND (EQ TYPE 'FNS) (fetch (MSSETPHRASE KNOWN) of SET)) 'KNOWN) (T TYPE))) do (SETQ VAL (MSHASHLIST (CAR TABLE) VAL SET] (RETURN VAL]) (MSMEMBSET [LAMBDA (ITEM SET) (* lmm%: 25-JAN-76 2 20) (MSINTERPRETSET SET 'MEMB ITEM]) (MSLISTSET [LAMBDA (SET TRYHARD TYPE) (* lmm " 8-JUL-78 02:11") (* Interpret set as List -  return list of elements in set S, or MSBLIP if can't) (MSINTERPRETSET SET (COND (TRYHARD 'HARD) (T 'LIST)) TYPE]) (MSHASHLIST [LAMBDA (HTABLE PREVVALUE OTHERSET BADMARKS) (* lmm " 8-AUG-77 15:17") (MAPTABLE HTABLE (FUNCTION MSHASHLIST1)) PREVVALUE]) (MSHASHLIST1 [LAMBDA (VAL KEY) (* lmm " 8-AUG-77 15:16") (AND (NEQ VAL MSBLIP) (NOT (EQMEMB VAL BADMARKS)) (NOT (FMEMB KEY PREVVALUE)) (OR (NULL OTHERSET) (MSMEMBSET KEY OTHERSET)) (SETQ PREVVALUE (CONS KEY PREVVALUE]) (CHECKPATHS [LAMBDA (OPTIONS VAL) (* lmm "20-DEC-78 20:03") (PROG (VAL) (for PR in OPTIONS when (FMEMB (CAR PR) '(FROM TO AVOIDING NOTRACE MARKING SEPARATE)) do (AND (MSINTERPRETSET (CDR PR) 'CHECK (EQ (CAR PR) 'FROM)) (SETQ VAL T))) (RETURN (OR VAL (NULL (FASSOC 'FROM OPTIONS]) (ONFILE [LAMBDA (FILES TYPES FINDITEMS) (* ; "Edited 2-Jun-88 11:19 by jrb:") (* ;  "MSHASHFILE uses cause GETRELATION barfs if CONTAINS table doesn't exist.") (PROG (VAL) (* ;; "JRB - TYPES of 'ALL means gather all types Masterscope knows about") [AND (EQ TYPES 'ALL) (SETQ TYPES (for FT in MSFNTYPES collect (fetch (MSANALYZABLE FILEPKGNAME) of FT] [for FILE (FNSONLY _ (AND MSHASHFILE (SELECTQ (COND ((AND (LISTP TYPES) (NULL (CDR TYPES)) (CAR TYPES))) (T TYPES)) ((FNS KNOWN NIL) T) NIL))) inside (OR FILES FILELST) do (* ;  "Don't notice the file if we only care about FNS and the file is known to the database.") (COND [(AND FNSONLY (NOT (MEMB FILE FILELST)) (GETRELATION FILE 'CONTAINS] (T (MSNOTICEFILE FILE))) (for TYPE inside TYPES do (SETQ TYPE (SELECTQ TYPE ((FNS KNOWN NIL) 'FNS) TYPE)) (COND [FINDITEMS (OR (FMEMB FILE VAL) (AND (find X inside FINDITEMS suchthat (INFILECOMS? X TYPE (FILECOMS FILE))) (SETQ VAL (CONS FILE VAL] (T (SETQ VAL (UNION (FILECOMSLST FILE TYPE) VAL] [COND ((AND MSHASHFILE (NULL VAL) (find TYPE inside TYPES suchthat (SELECTQ TYPE ((FNS KNOWN NIL) T) NIL))) (* ;  "Didn't find it in core; perhaps the CONTAINS table knows") (COND [FILES (for FILE inside FILES do (COND (FINDITEMS (for X inside FINDITEMS when (TESTRELATION X 'CONTAINS FILE T) do (pushnew VAL FILE))) (T (SETQ VAL (UNION (GETRELATION FILE 'CONTAINS) VAL] (FINDITEMS (* ;; "No files: should use all known files, but that information isn't explicitly kept by MSHASH. Soooo, we'll only do the case where FINDITEMS is given") (for X inside FINDITEMS do (SETQ VAL (UNION (GETRELATION X 'CONTAINS T) VAL] (RETURN VAL]) ) (DEFINEQ (MSINTERPRET [LAMBDA (COMMAND SUBROUTINE) (* ; "Edited 15-Aug-90 11:54 by jds") (RESETLST [PROG (VAL EDITQUIETFLG) (SELECTQ (CAR COMMAND) ((; * -) (RETURN)) NIL) (SETQ VAL (MSPARSE COMMAND)) (COND ((EQ MSPRINTFLG T) (PRINT VAL T))) (COND ((EQ (CAR VAL) 'OUTPUT) (MSOUTPUT (CADR VAL)) (SETQ VAL (CDDR VAL)) (MAPRINT COMMAND NIL ". " " "))) (* ;; "Now to interpret") [COND ((AND (EQ (CAR VAL) 'ERASE) (NULL (CDR VAL))) (MSERASE T) (RETURN 'ok] (MSINIT) (RETURN (SELECTQ (fetch (SENTENCE ID) of VAL) (REANALYZE (* ;  "Definitly don't want to CHECKFORCHANGED before the ANALYZE is done") (* ;; "From Lanning's Loops changes for Masterscope...") (* ;;  "(MAPC (MSLISTSET (CDR VAL) T 'KNOWN) (FUNCTION (LAMBDA (X) (UPDATEFN X T)))) (CL:VALUES)") (* ;; "JRB - The MSANALYZEFNS hashtable hook is hereby flushed.") (LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of (CDR VAL))) ((fetch (MSSETPHRASE DEFAULTTYPE) of (CDR VAL] (SET (MSLISTSET (CDR VAL) T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (if [AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] then (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!) else (for X in SET do (UPDATEFN X T)) (CL:VALUES)))) (ANALYZE (CHECKFORCHANGED (SETQ VAL (CDR VAL))) (* ;; "From Lanning's Loops changes for Masterscope...") (* ;; "(COND ((EQ (SETQ VAL (MSLISTSET VAL NIL 'KNOWN)) MSBLIP) (|printout| T %"Sorry, can't figure out which functions you mean.%" T) (ERROR!))) (MAPC VAL (FUNCTION UPDATEFN)) (CL:VALUES)") [LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of VAL)) ((fetch (MSSETPHRASE DEFAULTTYPE) of VAL] (SET (MSLISTSET VAL T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (COND ([AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!)) ((EQ SET MSBLIP) (PRINTOUT T "Sorry, can't figure out which items you mean. " T) (ERROR!)) (T (for X in SET do (UPDATEFN X T NIL SETTYPE)) (CL:VALUES]) ((EDIT SHOW) [PROG (DONE NEEDUPDATE UPDATEALL TYPE (EDIT (fetch (SENTENCE ID) of VAL)) REL SHOWSET (EDITCOMS (fetch OTHERSTUFF of VAL)) (SUBJECT (fetch (SENTENCE SUBJECT) of VAL)) (MSPRED (fetch (SENTENCE MSPRED) of VAL)) REP) (DECLARE (SPECVARS TYPE SHOWSET EDIT EDITCOMS DONE)) [COND ((NULL MSPRED) (* ;  "EDIT ANY CALLING FOO -- just call EDITFNS") (CHECKFORCHANGED SUBJECT) (RETURN (MAPC (MSLISTSET SUBJECT T) (FUNCTION (LAMBDA (FN) (PRIN2 FN T) (PRIN1 " : " T) (OR (NLSETQ (PRINT (APPLY 'MSEDITF (CONS FN EDITCOMS) ) T)) (PRINT "failed" T] [SETQ REL (fetch (THAT MSVERB) of (SETQ REP (fetch (MSSETPHRASE REP) of MSPRED] (SETQ SHOWSET (fetch (THAT OTHERSET) of REP)) [COND ((EQ (fetch TENSE of REL) 'ED) (replace TENSE of REL with 'S) (SETQ MSPRED (create MSSETPHRASE REP _ (create THAT MSVERB _ REL OTHERSET _ (SETQ SHOWSET (PROG1 SUBJECT (SETQ SUBJECT SHOWSET] (SETQ TYPE (VERBNOTICELIST (fetch VPART of REL))) (SETQ UPDATEALL (MSINTERPRETSET SUBJECT 'CHECK T)) [for FN in NEEDUPDATE do (COND ((GETHASH FN MSCHANGEDARRAY) (MSSHOWUSE FN TYPE SHOWSET EDIT NIL EDITCOMS) (SETQ DONE (CONS FN DONE))) (T (UPDATEFN FN] (COND (UPDATEALL [MAPHASH MSCHANGEDARRAY (FUNCTION (LAMBDA (VAL KEY) (AND (OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ((MSSHOWUSE KEY TYPE SHOWSET EDIT 'CHANGED EDITCOMS) (SETQ DONE (CONS KEY DONE] (MSCHECKEMPTY))) (MAPC (MSLISTSET (MSJOINSET 'AND MSPRED SUBJECT) T) (FUNCTION (LAMBDA (AT) (AND (NOT (FMEMB AT DONE)) (MSSHOWUSE AT TYPE SHOWSET EDIT NIL EDITCOMS ] (CL:VALUES)) (? [CHECKFORCHANGED (SETQ VAL (MSJOINSET 'AND (fetch MSPRED of VAL) (fetch SUBJECT of VAL] (OR SUBROUTINE (TAB 0 0)) (MSSOLVE VAL)) (PATHS (PROG ([INVERTED (for X on (CDR VAL) bind FROMFOUND do (SELECTQ (CAAR X) (FROM (SETQ FROMFOUND T)) (TO (RETURN (NOT FROMFOUND))) NIL) finally (RETURN (COND (FROMFOUND NIL) (T (FRPLACD VAL (CONS [CONS 'FROM (create MSSETPHRASE REP _ (create THAT MSVERB _ (create MSVERB ROOT _ 'IS MODIFIER _ 'KNOWN) OTHERSET _ (create MSSETPHRASE] (CDR VAL))) NIL] NEEDUPDATE UPDATEALL TEM) (SETQ UPDATEALL (CHECKPATHS (fetch MSPATHOPTIONS of VAL))) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY))) (COND ((SETQ TEM (fetch (PATHOPTIONS OUTPUT) of (CDR VAL))) (MSOUTPUT TEM))) (AND (SETQ TEM (fetch (PATHOPTIONS LINELENGTH) of (CDR VAL))) (RESETSAVE (LINELENGTH TEM))) (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") [SETQ MSTHOSE (MSPATHS [COND (INVERTED (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL] [COND (INVERTED (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL] INVERTED (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS SEPARATE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS MARKING) of (fetch MSPATHOPTIONS of VAL] (RETURN (CL:VALUES)))) (ERASE (* ;  "case of plain ERASE taken care of earlier") (MSERASE (MSLISTSET (CDR VAL) T 'KNOWN)) (PRIN1 "Erased." T) (CL:VALUES)) (DESCRIBE (CHECKFORCHANGED (CDR VAL) NIL T) (* ;  "Need to update the world since will print out CALLED BY:") (TAB 0 0) (MAPC (MSLISTSET (CDR VAL) T) (FUNCTION MSDESCRIBE))) (FOR (CHECKFORCHANGED (CADDDR VAL)) (FRPLACA (CDDDR VAL) (KWOTE (MSLISTSET (CADDDR VAL) T))) (EVAL VAL)) (CHECK (CHECKFORCHANGED (CDR VAL)) [MSCHECKBLOCKS (AND (CDR VAL) (MSLISTSET (CDR VAL) 'HARD 'FILES]) (SHOULDNT 18])]) (VERBNOTICELIST [LAMBDA (VPART) (* ; "Edited 12-Jun-87 16:37 by jrb:") (* ;;; " NOTE: The call to MSVBTABLES used to be a call to the macro MSVBNOTICED. The macro, however, existed only on the file MSANALYZE. Further, there was an EXPR definintion for the fn MSVBNOTICED, but BvM could find no reference to it in any file. What is going on? - smL") (COND [(type? CVERB VPART) (UNION (VERBNOTICELIST (fetch (CVERB VB1) of VPART)) (VERBNOTICELIST (fetch (CVERB VB2) of VPART] (T (OR (MSVBTABLES (fetch (VPART ROOT) of VPART) (fetch (VPART MODIFIER) of VPART)) (PROGN (printout T "can't SHOW or EDIT where things " (fetch (VPART ROOT) of VPART) %, (OR (fetch (VPART MODIFIER) of VPART) "") "!" T) (ERROR!]) (MSOUTPUT (LAMBDA (FILE) (* ; "Edited 12-Jun-90 20:43 by teruuchi") (* ;; "OUTPUT is already RESETSAVE'd") (COND ((OPENP FILE (QUOTE OUTPUT)) (OUTPUT FILE)) (T (OUTFILE FILE) (SETQ FILE (OUTPUT)) (RESETSAVE NIL (LIST (QUOTE CLOSEF) FILE)))) (* ;; "output to file, reset LINELENGTH") (LINELENGTH FILELINELENGTH)) ) (MSCHECKEMPTY [LAMBDA NIL (* lmm "20-JAN-79 14:08") (PROG (Q CF) (COND (MSDBEMPTY (printout T "No functions have been analyzed!" T) (UPDATEFILES) (SETQ CF (FILEPKGCHANGES 'FNS)) [COND ((AND [SETQ Q (APPEND (AND FILELST (LIST 'ON '%' FILELST)) (AND CF FILELST '(OR)) (AND CF (LIST 'IN '%' CF] (EQ [ASKUSER (AND (FIXP DWIMWAIT) (ITIMES 10 DWIMWAIT)) '(Y) (CONS "want to ." (SETQ Q (APPEND '(ANALYZE THE FNS) Q))) '((Y "es ") (N "o "] 'Y)) (MASTERSCOPE Q) (COND (MSDBEMPTY (printout T "Sorry, no functions were found to analyze!" T)) (T (RETURN] (ERROR!]) (CHECKFORCHANGED [LAMBDA (SET NOTTHISONE UPDATEALL) (* lmm "25-JUN-78 01:03") (PROG (NEEDUPDATE) (SETQ UPDATEALL (OR (MSINTERPRETSET SET 'CHECK (AND (NOT NOTTHISONE) (fetch KNOWN of SET))) UPDATEALL)) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY]) (MSSOLVE [LAMBDA (SET) (* ; "Edited 15-Aug-90 11:52 by jds") (SETQ MSTHOSE (MSLISTSET SET T)) (PROG (ND QT OSET REP) (SETQ REP (fetch REP of SET)) [OR (SELECTQ (fetch (SENTENCE ID) of REP) (AND (SETQ ND (fetch SET2 of REP)) (AND (EQ [fetch (SENTENCE ID) of (SETQ REP (fetch REP of (fetch SET1 of REP] 'INRELATION) (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH))) (INRELATION (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH)) NIL) (RETURN (COND ((EQ (fetch (MSSETPHRASE DET) of SET) 'WHICH) (* ; "Edited by TT (29-May-1990)") (if (EQ (OUTPUT) T) then MSTHOSE else (PRINT MSTHOSE) (CL:VALUES))) (T (if (EQ (OUTPUT) T) then (NOT (NULL MSTHOSE)) else (PRINT (NOT (NULL MSTHOSE))) (CL:VALUES] (replace REP of SET with REP) (replace (INRELATION INVERTED) of REP with (NOT (fetch (INRELATION INVERTED ) of REP))) [replace (INRELATION OSET) of REP with (create MSSETPHRASE REP _ (create QUOTE QUOTED _ (SETQ QT (LIST NIL] [MAPC MSTHOSE (FUNCTION (LAMBDA (FN) (PRIN2 FN) (PRIN1 " -- ") (FRPLACA QT FN) (PRINT (SUBSET (MSLISTSET SET T) (FUNCTION (LAMBDA (X) (MSMEMBSET X OSET] (RETURN (CL:VALUES]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD GETHASH (ID HTABLE . BADMARKS) ID _ 'GETHASH) (RECORD INRELATION (ID (INVERTED . HTABLES) . OSET) ID _ 'INRELATION) (ASSOCRECORD PATHOPTIONS (TO FROM AVOIDING SEPARATE NOTRACE TOPFLG OUTPUT LINELENGTH MARKING) (* CHECKPATHS assumes that this is  an ASSOCRECORD) ) (RECORD MSANALYZABLE (FILEPKGNAME SETNAME GETDEF-FN MARKCHANGED-FN)) ) ) (FILESLOAD MSCOMMON) (DECLARE%: DONTCOPY (RPAQQ MSCOMPILETIME [[P (MAPC '(GETRELQ TESTRELQ SCRATCHASH) (FUNCTION (LAMBDA (X) (PUTHASH X 'MACRO USERTEMPLATES] (BLOCKS (NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) (MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) (NOLINKFNS . T)) (MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (RETFNS MASTERSCOPE1) (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) (NOLINKFNS . T))) (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) (DECLARE%: EVAL@COMPILE (FILES (LOADCOMP) SEDIT-DECLS MSPARSE) (P (CLISPDEC 'FAST]) [MAPC '(GETRELQ TESTRELQ SCRATCHASH) (FUNCTION (LAMBDA (X) (PUTHASH X 'MACRO USERTEMPLATES] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) (BLOCK%: MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) (NOLINKFNS . T)) (BLOCK%: MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (RETFNS MASTERSCOPE1) (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) (NOLINKFNS . T)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) ) (DECLARE%: EVAL@COMPILE (FILESLOAD (LOADCOMP) SEDIT-DECLS MSPARSE) (CLISPDEC 'FAST) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA %.) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MSEDITE MSEDITF MSEDITF) ) (PUTPROPS MASTERSCOPE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1993 1994 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3574 20222 (UPDATEFN 3584 . 5078) (MSEDITF 5080 . 6080) (MSGETDEF 6082 . 7488) ( MSNOTICEFILE 7490 . 9883) (MSSHOWUSE 9885 . 15388) (MSUPDATEFN1 15390 . 16078) (MSUPDATE 16080 . 18506 ) (MSNLAMBDACHECK 18508 . 19390) (MSCOLLECTDATA 19392 . 20220)) (20223 21122 (UPDATECHANGED 20233 . 20596) (UPDATECHANGED1 20598 . 21120)) (21696 22119 (MSCLOSEFILES 21706 . 22117)) (22800 27232 ( MSDESCRIBE 22810 . 25598) (MSDESCRIBE1 25600 . 26663) (FMAPRINT 26665 . 27230)) (27325 27765 ( MSPRINTHELPFILE 27335 . 27763)) (27815 30915 (TEMPLATE 27825 . 29246) (GETTEMPLATE 29248 . 29383) ( SETTEMPLATE 29385 . 30913)) (31785 36709 (ADDTEMPLATEWORD 31795 . 32467) (MSADDANALYZE 32469 . 33967) (MSADDMODIFIER 33969 . 35050) (MSADDRELATION 35052 . 35799) (MSADDTYPE 35801 . 36707)) (38210 43431 ( MSMARKCHANGE1 38220 . 39014) (MSINIT 39016 . 40197) (GETVERBTABLES 40199 . 40752) (MSSTOREDATA 40754 . 42433) (STORETABLE 42435 . 43429)) (44832 49902 (PARSERELATION 44842 . 45442) (PARSERELATION1 45444 . 46899) (GETRELATION 46901 . 47930) (MAPRELATION 47932 . 49066) (TESTRELATION 49068 . 49900)) (49903 51543 (ADDHASH 49913 . 50391) (SUBHASH 50393 . 50621) (MAKEHASH 50623 . 50767) (MSREHASH 50769 . 51222) (EQMEMBHASH 51224 . 51541)) (51882 58097 (MSVBTABLES 51892 . 57671) (MSUSERVBTABLES 57673 . 58095)) (58180 60391 (BUILDGETRELQ 58190 . 59296) (BUILDTESTRELQ 59298 . 60389)) (60562 60950 (MSERASE 60572 . 60948)) (60951 64183 (DUMPDATABASE 60961 . 62298) (DUMPDATABASE1 62300 . 62645) (READATABASE 62647 . 64181)) (65265 94324 (MSCHECKBLOCKS 65275 . 69095) (MSCHECKBLOCK 69097 . 77717) ( MSCHECKFNINBLOCK 77719 . 80719) (MSCHECKBLOCKBASIC 80721 . 83141) (MSCHECKBOUNDFREE 83143 . 85042) ( GLOBALVARP 85044 . 85211) (PRINTERROR 85213 . 88429) (MSCHECKVARS1 88431 . 91384) (UNECCSPEC 91386 . 91664) (NECCSPEC 91666 . 92013) (SPECVARP 92015 . 92542) (SHORTLST 92544 . 93000) (DOERROR 93002 . 93712) (MSMSGPRINT 93714 . 94322)) (95468 110296 (MSPATHS 95478 . 98880) (MSPATHS1 98882 . 103117) ( MSPATHS2 103119 . 106529) (MSONPATH 106531 . 107759) (MSPATHS4 107761 . 108843) (DASHES 108845 . 109371) (DOTABS 109373 . 109614) (BELOWMARKER 109616 . 110079) (MSPATHSPRINTFN 110081 . 110294)) ( 110682 114106 (MSFIND 110692 . 110967) (MSEDITF 110969 . 111969) (MSEDITE 111971 . 113008) (EDITGETDEF 113010 . 114104)) (115112 123713 (MSMARKCHANGED 115122 . 116846) (CHANGEMACRO 116848 . 117553) ( CHANGEVAR 117555 . 117871) (CHANGEI.S. 117873 . 119206) (CHANGERECORD 119208 . 120079) (MSNEEDUNSAVE 120081 . 121073) (UNSAVEFNS 121075 . 123711)) (124154 127644 (%. 124164 . 124304) (MASTERSCOPE 124306 . 124832) (MASTERSCOPE1 124834 . 125702) (MASTERSCOPEXEC 125704 . 127642)) (127683 165342 ( MSINTERPRETSET 127693 . 155186) (MSINTERPA 155188 . 155722) (MSGETBLOCKDEC 155724 . 158237) (LISTHARD 158239 . 159457) (MSMEMBSET 159459 . 159604) (MSLISTSET 159606 . 159971) (MSHASHLIST 159973 . 160140) (MSHASHLIST1 160142 . 160468) (CHECKPATHS 160470 . 161110) (ONFILE 161112 . 165340)) (165343 188509 ( MSINTERPRET 165353 . 182206) (VERBNOTICELIST 182208 . 183318) (MSOUTPUT 183320 . 183637) (MSCHECKEMPTY 183639 . 184843) (CHECKFORCHANGED 184845 . 185365) (MSSOLVE 185367 . 188507))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 3-Mar-2021 09:08:58" {DSK}larry>ilisp>medley>library>MASTERSCOPE.;5 194485 previous date%: "25-Feb-2021 12:09:36" {DSK}larry>ilisp>save>MASTERSCOPE.;1) (* ; " Copyright (c) 1983-1988, 1990, 1993-1994, 2018, 2020-2021 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT MASTERSCOPECOMS) (RPAQQ MASTERSCOPECOMS [ (* ;; "Main file for MASTERSCOPE.") (FILES MSPARSE MSANALYZE) (PROP FILETYPE MASTERSCOPE) (COMS * MSDATABASECOMS) (COMS * MSAUXCOMS) (COMS * MSDBCOMS) (COMS * MSCHECKBLOCKSCOMS) (COMS * MSPATHSCOMS) [COMS (FNS MSFIND MSEDITF MSEDITE EDITGETDEF) (VARS MSBLIP) (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE.") [INITVARS (MSFNTYPES '((FNS FNS GETDEF] (COMS (* ; "SCRATCHASH") (INITVARS (MSCRATCHASH)) (DECLARE%: DONTCOPY (MACROS SCRATCHASH] (COMS (* ; "marking changed") (FNS MSMARKCHANGED CHANGEMACRO CHANGEVAR CHANGEI.S. CHANGERECORD MSNEEDUNSAVE UNSAVEFNS ) (ADDVARS (COMPILE.TIME.CONSTANTS)) (VARS (RECORDCHANGEFN 'CHANGERECORD)) (INITVARS (CHECKUNSAVEFLG T) (MSNEEDUNSAVE))) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS GETWORDTYPE)) (COMS (* ; "interactive routines") [VARS * (LIST (LIST 'MASTERSCOPEDATE (DATE (DATEFORMAT NO.TIME] (ADDVARS (HISTORYCOMS %.)) (FNS %. MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC) (* ; "Interpreting commands") (FNS MSINTERPRETSET MSINTERPA MSGETBLOCKDEC LISTHARD MSMEMBSET MSLISTSET MSHASHLIST MSHASHLIST1 CHECKPATHS ONFILE) (FNS MSINTERPRET VERBNOTICELIST MSOUTPUT MSCHECKEMPTY CHECKFORCHANGED MSSOLVE) (DECLARE%: DONTCOPY (RECORDS GETHASH INRELATION PATHOPTIONS MSANALYZABLE))) (FILES MSCOMMON) (DECLARE%: DONTCOPY (COMS * MSCOMPILETIME)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA %.) (NLAML) (LAMA MSEDITE MSEDITF MSEDITF]) (* ;; "Main file for MASTERSCOPE.") (FILESLOAD MSPARSE MSANALYZE) (PUTPROPS MASTERSCOPE FILETYPE :COMPILE-FILE) (RPAQQ MSDATABASECOMS ((FNS UPDATEFN MSEDITF MSGETDEF MSNOTICEFILE MSSHOWUSE MSUPDATEFN1 MSUPDATE MSNLAMBDACHECK MSCOLLECTDATA) (FNS UPDATECHANGED UPDATECHANGED1) (VARS TABLE.TO.NOTICED) (FNS MSCLOSEFILES) (VARS (MSFILELST) (MSOPENFILES)) (VARS (MSPRINTFLG '%.) (MSPRINTCNT 0)) (ADDVARS (MSHASHFILE) (ANALYZEUSERFNS)))) (DEFINEQ (UPDATEFN [LAMBDA (FN EVENIFVALID IFCANT TYPE) (* ; "Edited 25-Feb-2021 10:05 by larry") (* Update the analysis of a  particular function -  this is a "user" entry) (PROG NIL (OR (AND FN (LITATOM FN)) (RETURN)) (MSINIT) (COND ((AND (NOT EVENIFVALID) (NOT (GETHASH FN MSCHANGEDARRAY)) (TESTRELQ KNOWN FN)) (* Previous valid analysis --  return) (RETURN))) [SETQ DEF (MSGETDEF FN TYPE (SELECTQ IFCANT (0 'CURRENT) '?) '(NOERROR NOCOPY MASTERSCOPE] (COND ((NULL DEF) (* No definition can be found --  look at IFCANT) (SELECTQ IFCANT (ERROR (ERROR FN "can't be analyzed " T)) (PRINT (printout T "Sorry, the function " .P2 FN " can't be analyzed!" T)) NIL) (COND ((TESTRELQ KNOWN FN) (MSERASE (LIST FN))) (T (PUTHASH FN NIL MSCHANGEDARRAY))) (RETURN))) (MSUPDATEFN1 FN DEF]) (MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) (MSGETDEF [LAMBDA (NAME TYPE SOURCE OPTIONS) (* ;  "Edited 23-Jun-93 10:21 by sybalsky:mv:envos") (* ;;; "Take a whack at getting the definition of NAME. Masterscope assumes a bijection between names and analyzable things; it caches that relationship in the FPTYPE table") (LET (TABLEFPTYPE REALDEF) (COND ([SETQ TABLEFPTYPE (CAR (GETRELATION NAME (PARSERELATION 'FPTYPE] (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of (ASSOC TABLEFPTYPE MSFNTYPES)) NAME TABLEFPTYPE SOURCE OPTIONS)) (T (for FPTYPE in MSFNTYPES bind RESULT when (CL:MULTIPLE-VALUE-SETQ (RESULT REALDEF) (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of FPTYPE) NAME TYPE SOURCE OPTIONS)) do (PUTTABLE NAME (LIST (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (CADR (FASSOC 'FPTYPE MSDATABASELST))) (* ;; "Look up active editors, and use the edited defn, if there is one:") (SETQ REALDEF (OR (EDITGETDEF NAME TYPE) REALDEF)) (RETURN (CL:VALUES RESULT REALDEF)) finally NIL]) (MSNOTICEFILE [LAMBDA (FILE) (* ; "Edited 8-Apr-88 12:00 by jrb:") (DECLARE (GLOBALVARS MSHASHFILE LOADDBFLG)) (PROG (FULL COMS TEM) LP (COND ((SETQ TEM (FASSOC FILE MSFILELST)) (* already noticed) (RETURN TEM))) (OR COMS (SETQ COMS (FILECOMS FILE))) (SETQ FULL (FINDFILE FILE T)) [COND ((NOT (FMEMB FILE FILELST)) (* two possibilities%: either FILE is something like FOO or it has not  been loaded yet) [COND ((AND (NOT FULL) (EQ FILE (NAMEFIELD FILE T))) (COND ((LISTP (GETATOMVAL COMS)) (* dummy or new file since COMS set but not on filelst) (GO DUMMY] (* either the file has never been loaded, or an explicit was given) (OR FULL (ERROR FILE "not found")) [SETQ COMS (FILECOMS (SETQ FILE (NAMEFIELD FULL T] (OR (AND [EQ FULL (CDAR (GETPROP FILE 'FILEDATES] (LISTP (EVALV COMS))) (COND ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "should I LOADFROM" FULL))) (RESETVARS [(LOADDBFLG (COND (MSHASHFILE LOADDBFLG) (T 'NO] (* Should bring the hashfile up-to-date if we are noticing the file) (LOADFROM FULL))) (T (ERROR!] [COND ((EQ [CDAR (SETQ TEM (GETPROP FILE 'FILE] 'Compiled) (* If only the compiled version of the file has been loaded, still want to  know about GLOBALVARS or other things) (LOADVARS '((DECLARE%: -- DONTCOPY --)) (OR (AND (SETQ FULL (GETP FILE 'FILEDATES)) (INFILEP (CDAR FULL))) FILE)) (/RPLACD (CAR TEM) 'COMPILED] DUMMY (RETURN (OR (FASSOC FILE MSFILELST) (CAR (SETQ MSFILELST (CONS (CONS FILE COMS) MSFILELST]) (MSSHOWUSE [LAMBDA (SHOWFN SHOWTYPE SHOWSET SHOWEDIT IFCANT EDITCOMS) (* ;  "Edited 23-Jun-93 09:40 by sybalsky:mv:envos") (* ;; "Show/Edit where SHOWFN uses/etc. a pattern.") (PROG (DEF REALDEF ANYFOUND) (COND ([OR [CL:MULTIPLE-VALUE-SETQ (DEF REALDEF) (MSGETDEF SHOWFN (AND (fetch (MSSETPHRASE KNOWN) of SHOWSET) (fetch (MSSETPHRASE TYPE) of SHOWSET)) (COND ((EQ SHOWEDIT 'SHOW) '?) (T 'CURRENT NIL)) '(NOERROR NODWIM NOCOPY] (SETQ DEF (AND (EQ SHOWEDIT 'EDIT) (LET ((FILE (EDITLOADFNS? SHOWFN))) (COND (FILE (LOADFNS SHOWFN FILE 'PROP) (GETPROP SHOWFN 'EXPR] (* ;  "was (MSGETDEF SHOWFN IFCANT (EQ SHOWEDIT (QUOTE SHOW)))") (* ;  "The SHOW command does not need to save") (MSUPDATEFN1 SHOWFN DEF (LIST SHOWTYPE [FUNCTION (LAMBDA (ITEM SS SE PRNT INCLISP) (COND ((MSMEMBSET ITEM SS) (COND ((NOT ANYFOUND) (TAB 0 0 T) (PRIN2 SHOWFN) (PRIN1 " : "))) (SETQ ANYFOUND (CONS (CONS PRNT (AND INCLISP (NOT (MSFIND INCLISP PRNT)) INCLISP)) ANYFOUND)) (COND ([AND (EQ SE 'SHOW) (NOT (FASSOC PRNT (CDR ANYFOUND] (* ;; "The EDIT command works by collecting a list of the expressions, and then doing a (*ORF* (= . lst1) (= . lst2)) --- if within a CLISP translation (determined by the binding of the INCLISP variable) then want to point at the CLISP if the expression is not actually embedded in the expression") (SPACES 3) (LVLPRINT PRNT (OUTPUT) 2) (COND ((CDAR ANYFOUND) (* ; "This is under a clisp") (PRIN1 " {under ") (LVLPRIN2 INCLISP (OUTPUT) 2) (PRIN1 "} "] SHOWSET SHOWEDIT))) (T (printout T "Can't find a definition for " SHOWFN "!" T) (RETURN))) (COND ((NOT ANYFOUND) (RETURN)) ((EQ SHOWEDIT 'EDIT) [MAPC ANYFOUND (FUNCTION (LAMBDA (X) (FRPLNODE X '== (OR (CDR X) (CAR X] (SETQ ANYFOUND (CONS '*ANY* ANYFOUND)) (PRINT [APPLY* 'MSEDITE SHOWFN (OR REALDEF DEF) (ASSOC [CAR (GETRELATION SHOWFN (PARSERELATION 'FPTYPE] MSFNTYPES) (LIST 'BIND '(E (SETQ %#1) T) (LIST 'F ANYFOUND T) (LIST 'LPQ (LIST 'IF '(NEQ (%##) %#1) [LIST '(ORR (P) NIL) '(S %#1) (COND (EDITCOMS (CONS 'BIND EDITCOMS)) (T 'TTY%:] NIL) (LIST 'F ANYFOUND 'N] T T))) (RETURN T]) (MSUPDATEFN1 [LAMBDA (FN DEF EACHTIME DOSUBFNS) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Subfunction of UPDATEFN -- notices all of the "new" functions called by FN) (MSUPDATE FN DEF EACHTIME) (AND DOSUBFNS (for X in (GETRELQ (CALL NOTERROR) FN) when (NOT (TESTRELQ KNOWN X)) do (PROG (DEF) (AND [SETQ DEF (MSGETDEF X NIL 'CURRENT '(NOCOPY NODWIM NOERROR MASTERSCOPE] (MSUPDATEFN1 X DEF EACHTIME T]) (MSUPDATE [LAMBDA (FNNAME FNDEF EACHTIME) (* lmm "22-Jul-86 18:24") (* This is the main internal entry to the analysis routines.) (PROG (VARS ERS TEM PRFLG DATA) (* VARS is used to mark the CURRENT variables bound.  INCLISP and EACHTIME need to be bound by ADDTO which checks to see if we are  in a SHOW or EDIT) (MSNLAMBDACHECK FNNAME) [COND ((EQ (CAR FNDEF) 'CL:LAMBDA)) ([OR (EQ DWIMIFYCOMPFLG T) (EQ CLISPIFYPRETTYFLG T) (EQ (CAR (SETQ TEM (CADDR FNDEF))) 'CLISP%:) (AND (EQ (CAR TEM) COMMENTFLG) (EQ (CADR TEM) 'DECLARATIONS%:)) (NOT (FMEMB (CAR FNDEF) '(LAMBDA NLAMBDA] (* Check if the whole definition  needs to be DWIMIFIED) (LET (VARS) (DECLARE (CL:SPECIAL VARS)) (MSPRGDWIM FNDEF FNNAME FNDEF] [COND ((NOT EACHTIME) (COND ((OR (EQ MSPRINTFLG T) (AND (FIXP MSPRINTFLG) (NOT (IGREATERP (SETQ MSPRINTCNT (SUB1 MSPRINTCNT)) 0)) (SETQ MSPRINTCNT MSPRINTFLG))) (SETQ PRFLG (PRIN2 FNNAME T))) ((EQ MSPRINTFLG '%.) (PRIN1 '%. T] (SETQ DATA (ALLCALLS FNDEF 'ARG NIL FNNAME T EACHTIME)) (for F in ANALYZEUSERFNS do (SETQ DATA (APPLY* F FNNAME FNDEF DATA))) [SETQ ERS (FMEMB MSERRORFN (CDR (FASSOC 'ERRORS DATA] [SELECTQ MSPRINTFLG (NIL) (%. (AND ERS (PRIN1 '? T))) (PROGN [OR PRFLG (COND ((OR ERS (AND EACHTIME (NOT ANYFOUND))) (SETQ PRFLG (PRIN2 FNNAME T] (* always print if errors) (COND (ERS (PRIN1 " (CALLS ppe)" T))) (AND PRFLG (PRIN1 '", " T] (MSSTOREDATA FNNAME DATA]) (MSNLAMBDACHECK [LAMBDA (FN) (* lmm "22-DEC-78 13:11") (COND ((AND (NOT (TEMPLATE FN T)) [SETQ FN (COND [(NLAMBDAFNP FN) (SUBSET (GETRELQ (CALL DIRECTLY) FN T) (FUNCTION (LAMBDA (FN2) (* the set of functions which call this one, but don't call it as an nlambda) (NOT (FMEMB FN (GETRELQ (CALL NLAMBDA) FN2] (T (* someone calls it as an NLAMBDA) (GETRELQ (CALL NLAMBDA) FN T] (MSMARKCHANGE1 FN]) (MSCOLLECTDATA [LAMBDA (TNAME FLG) (* lmm "30-OCT-80 10:00") (COND ((LISTP TNAME) (SELECTQ (CAR TNAME) (- (LDIFFERENCE (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (+ (UNION (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (SHOULDNT 2))) (T (PROG NIL (RETURN (MSCOLLECTDATA (CADR (OR (AND (NULL FLG) (FASSOC TNAME TABLE.TO.NOTICED)) (RETURN (CDR (FASSOC TNAME FNDATA]) ) (DEFINEQ (UPDATECHANGED [LAMBDA NIL (* lmm "16-JUL-78 05:07") (* Update all functions marked as  changed) (MSINIT) (MAPHASH MSCHANGEDARRAY (FUNCTION UPDATECHANGED1)) NIL]) (UPDATECHANGED1 [LAMBDA (VAL KEY) (* ; "Edited 27-Jan-88 16:49 by jrb:") (COND [(OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ([SETQ VAL (MSGETDEF KEY NIL '? '(NOERROR NOCOPY MASTERSCOPE] (MSUPDATEFN1 KEY VAL NIL T)) (T (printout T KEY " disappeared!" T) (MSERASE (LIST KEY] (T (PUTHASH KEY NIL MSCHANGEDARRAY]) ) (RPAQQ TABLE.TO.NOTICED ((BIND (- (- (- (- (+ BIND ARG) REF) SMASH) SET) TEST)) (REFFREE (- (- (- REFFREE SETFREE) SMASHFREE) TESTFREE)) (REF (- (- (- REF SET) SMASH) TEST)) (PREDICATE (- PREDICATE CALL)) (EFFECT (- (- EFFECT CALL) PREDICATE)) (CALL (- CALL NLAMBDA)) (0 TYPE) (APPLY (+ APPLY STACK)) (ARGS ARG))) (DEFINEQ (MSCLOSEFILES [LAMBDA NIL (* lmm "24-JUN-78 17:18") (* this is RESETSAVE'd from MSGETDEF to close any files that MSGETDEF leaves  open) (for X in MSOPENFILES when (AND (NOT (CADR X)) (OPENP (CADDR X))) do (CLOSEF (CADDR X))) (SETQ MSOPENFILES]) ) (RPAQQ MSFILELST NIL) (RPAQQ MSOPENFILES NIL) (RPAQQ MSPRINTFLG %.) (RPAQQ MSPRINTCNT 0) (ADDTOVAR MSHASHFILE ) (ADDTOVAR ANALYZEUSERFNS ) (RPAQQ MSAUXCOMS ((COMS (FNS MSDESCRIBE MSDESCRIBE1 FMAPRINT) (ADDVARS (DESCRIBELST)) (GLOBALVARS DESCRIBELST)) (COMS (FNS MSPRINTHELPFILE) (VARS MSHELPFILE)) (COMS (FNS TEMPLATE GETTEMPLATE SETTEMPLATE) (FILEPKGCOMS TEMPLATES)) (COMS (FNS ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (INITVARS (MSCHECKFNS NIL)) (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES)))) (DEFINEQ (MSDESCRIBE [LAMBDA (FN SN) (* lmm "22-Jul-85 18:16") (* Prints function name, arguments,  local and free variables.  etc) (DECLARE (SPECVARS FN)) (* Make FN available to user  DESCRIBELST forms) (PROG (GLOBALS FREES ARGS LINE) [SETQ ARGS (COND ((SETQ ARGS (GETRELQ ARGS FN)) (* The args in the argtable have precedence, even if the function is  resident, cause they correspond to what was actually analyzed.) (* T is for an arglist of NIL) (AND (NEQ ARGS T) ARGS)) ((GETD FN) (SMARTARGLIST FN] (printout NIL "(" .FONT BOLDFONT |.P2| FN .FONT DEFAULTFONT) (FMAPRINT ARGS NIL " " ")") (OR (TESTRELQ KNOWN FN) (PRIN1 " (not analyzed)" T)) (COND ([AND [OR (HARRAYP SN) (HARRAYP (CAR (LISTP SN] (SMALLP (SETQ LINE (GETHASH FN SN] (TAB 45 T) (PRIN1 " {line ") (PRIN1 (ABS LINE)) (PRIN1 "}"))) (TERPRI) (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN) '"calls: ") (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN T) '"called by:") (MSDESCRIBE1 (for VAR in (GETRELQ BIND FN) when (NOT (EQMEMB VAR ARGS)) collect VAR) '"binds: ") [for VAR in (GETRELQ (USE FREELY) FN) do (COND ((OR (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR)) (SETQ GLOBALS (CONS VAR GLOBALS))) (T (SETQ FREES (CONS VAR FREES] (MSDESCRIBE1 FREES '"uses free:") (MSDESCRIBE1 GLOBALS '"globals: ") (MSDESCRIBE1 (GETRELQ (USE FIELDS) FN) '"fields: ") (for D L in DESCRIBELST when (SETQ L (EVAL (CADR D))) do (MSDESCRIBE1 L (CAR D))) (TERPRI]) (MSDESCRIBE1 [LAMBDA (LST STR) (* lmm " 9-AUG-77 04:45") (* lmm%: 15 NOV 75 2248) (COND (LST (SPACES 2) (PRIN1 STR) (SPACES 1) (PROG (LL P) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) (SETQ LL (LINELENGTH)) (SETQ P (POSITION)) LP (COND ((IGREATERP (IPLUS (POSITION) 5 (NCHARS (CAR LST))) LL) (TAB P))) (PRIN2 (CAR LST)) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 '%,) (GO LP) EXIT (TERPRI]) (FMAPRINT [LAMBDA (LST FILE LEFT RIGHT SEP) (* lmm%: 28 OCT 75 757) (PROG NIL (AND LEFT (PRIN1 LEFT FILE)) (OR SEP (SETQ SEP '% )) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) LP (PRIN2 (CAR LST) FILE) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 SEP FILE) (GO LP) EXIT (AND RIGHT (PRIN1 RIGHT FILE]) ) (ADDTOVAR DESCRIBELST ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DESCRIBELST) ) (DEFINEQ (MSPRINTHELPFILE [LAMBDA NIL (* lmm "20-JAN-79 13:48") (PROG (FL) [SETQ FL (OR (INFILEP MSHELPFILE) (RETURN (PROGN (printout T "Sorry, HELP file not available!" T) NIL] (SETQ FL (INPUT (INFILE FL))) (RESETSAVE NIL (LIST 'CLOSEF FL)) (COPYBYTES FL T 0 (GETEOFPTR FL]) ) (RPAQQ MSHELPFILE MASTERSCOPE.SYNTAX) (DEFINEQ (TEMPLATE [LAMBDA (FN TEMPLATE FLG) (* lmm "23-DEC-78 14:06") (* MSTEMPLATES is the hash table for pre-defined templates.  USERTEMPLATES contains user defined templates.  The split is so that DUMPDATABASE can dump the templates as well -  check for MSDATABASE is so CALLS doesn't need to init database) (PROG [(OLD (OR (GETHASH FN USERTEMPLATES) (GETHASH FN MSTEMPLATES] (COND ((EQ OLD T) (SETQ OLD))) (COND ((AND (NOT (EQUAL TEMPLATE OLD)) (NEQ TEMPLATE T)) [COND ((NOT FLG) [AND FILEPKGFLG (MARKASCHANGED FN 'TEMPLATES (NOT (NULL OLD] (AND MSDATABASELST (MSMARKCHANGED (GETRELATION FN '(CALL DIRECTLY) T) 'FNS] (PUTHASH FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (MACRO TEMPLATE) (NIL (AND (GETHASH FN MSTEMPLATES) T)) (ERROR TEMPLATE "Invalid template"))) (T TEMPLATE)) USERTEMPLATES))) (RETURN OLD]) (GETTEMPLATE [LAMBDA (FN) (* lmm " 9-AUG-77 06:20") (SETTEMPLATE FN T]) (SETTEMPLATE [LAMBDA (FN TEMPLATE NOSAVEFLG) (* ; "Edited 25-Feb-2021 09:51 by larry") (PROG ([OLD (COPY (TEMPLATE FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (EVAL '(CALL |..| EVAL)) ((NIL T MACRO) TEMPLATE) (ERROR TEMPLATE "Invalid template"))) (T (SELECTQ (CAR TEMPLATE) (MACRO TEMPLATE) (! (CDR TEMPLATE)) (CONS 'CALL (AND (OR (CAR TEMPLATE) (CDR TEMPLATE)) TEMPLATE] VAL) [SETQ VAL (COND ((NLISTP OLD) OLD) (T (SELECTQ (CAR OLD) (MACRO OLD) (CALL (OR (CDR OLD) (CONS))) (CONS '! OLD] [OR (EQ TEMPLATE T) NOSAVEFLG (AND LISPXHIST (UNDOSAVE (LIST 'SETTEMPLATE FN OLD] (RETURN VAL]) ) (PUTDEF (QUOTE TEMPLATES) (QUOTE FILEPKGCOMS) '((COM MACRO [X (P * (MAPCAR 'X (FUNCTION (LAMBDA (FN) (LIST 'SETTEMPLATE (KWOTE FN) (KWOTE (GETTEMPLATE FN] CONTENTS NILL) (TYPE DESCRIPTION "masterscope templates"))) (DEFINEQ (ADDTEMPLATEWORD [LAMBDA (WORD) (* smL "27-Nov-85 17:49") (* * Add a new word that can be used in TEMPLATES.  This really means add a new MasterScope table.) (MSINIT) (if (NOT (ASSOC WORD MSFNDATA)) then (PUTASSOC WORD NIL MSFNDATA)) (if (NOT (ASSOC WORD MSDATABASELST)) then (PUTASSOC WORD (CONS (MAKETABLE 2) (MAKETABLE 2)) MSDATABASELST)) (if (NOT (ASSOC WORD MSDATABASEINIT)) then (PUTASSOC WORD (CONS 2 2) MSDATABASEINIT]) (MSADDANALYZE [LAMBDA (PLURAL SINGLE FILETYPE GETDEF-FN MARKCHANGED-FN) (* ; "Edited 16-Jun-88 10:35 by jrb:") (* * Defines a new MasterScope datatype) [for word in (LIST PLURAL SINGLE) do (LET ((oldDef (GETHASH word MSWORDS))) (if oldDef then (PUTASSOC 'TYPE PLURAL oldDef) else (PUTHASH word (LIST (CONS 'TYPE PLURAL)) MSWORDS] (* ;;  "MSANALYZEFNS is bogus and is hereby removed. (PUTHASH PLURAL ANALYZEFN MSANALYZEFNS)") (* ;; "JRB - ") (if FILETYPE then (LET ((oldEntry (ASSOC FILETYPE MSFNTYPES))) (if oldEntry then (replace (MSANALYZABLE SETNAME) oldEntry PLURAL) (replace (MSANALYZABLE GETDEF-FN) oldEntry GETDEF-FN) (replace (MSANALYZABLE MARKCHANGED-FN) oldEntry MARKCHANGED-FN) else (push MSFNTYPES (create MSANALYZABLE FILEPKGNAME _ FILETYPE SETNAME _ PLURAL GETDEF-FN _ GETDEF-FN MARKCHANGED-FN _ MARKCHANGED-FN]) (MSADDMODIFIER [LAMBDA (RELATION MODIFIERS TABLES) (* smL "16-Dec-85 15:39") (* * Define a new modifier to a MasterScope relation, telling what tables  should be combined to determine the modified relation) (SETQ TABLES (MKLIST TABLES)) (SETQ MODIFIERS (MKLIST MODIFIERS)) (MSINIT) (for adverb in MODIFIERS bind oldWordDef do (SETQ oldWordDef (ASSOC 'V (GETHASH adverb MSWORDS))) (if oldWordDef then (PUTASSOC 'V [CONS adverb (CONS RELATION (MKLIST (CDDR oldWordDef] (GETHASH adverb MSWORDS)) else (PUTHASH adverb (CONS (CONS 'V (LIST adverb RELATION)) (GETHASH adverb MSWORDS)) MSWORDS))) (PUTHASH RELATION (CONS (CONS MODIFIERS TABLES) (GETHASH RELATION MSUSERVBTABLES)) MSUSERVBTABLES) (for table in TABLES do (ADDTEMPLATEWORD table]) (MSADDRELATION [LAMBDA (RELATION TABLES) (* smL "16-Dec-85 14:55") (* * Let the user define a new MasterScope relation.  -  RELATION is a list of ROOT PRESENT PARTICIPLE and PAST conjugations of the  new relation. They can then be used in MasterScope commands to specify  relations. -  TABLES is a list of new MasterScope database tables.  These tables can then be used in MasterScope templates.  TABLES defaults to the ROOT of the relation.) (LET ((ROOT (CAR RELATION))) (MSSETUP (LIST RELATION)) [MSADDMODIFIER ROOT '(NIL) (MKLIST (MKLIST (OR TABLES ROOT] ROOT]) (MSADDTYPE [LAMBDA (TYPE TABLES HOWUSED SYNONYMS) (* smL "16-Dec-85 15:35") (* * Defines the TYPE as the union of the TABLES so you can use phrases like  "USE foo AS A " or "USE THE foo") [SETQ HOWUSED (MKLIST (OR HOWUSED 'USE] (SETQ SYNONYMS (MKLIST SYNONYMS)) (SETQ TABLES (MKLIST TABLES)) (MSINIT) (for typeWord in (CONS TYPE SYNONYMS) bind oldWordDef do (SETQ oldWordDef (GETHASH typeWord MSWORDS)) (if oldWordDef then (PUTASSOC 'TYPE TYPE oldWordDef) else (SETQ oldWordDef (LIST (CONS 'TYPE TYPE))) (PUTHASH typeWord oldWordDef MSWORDS)) (PUTASSOC 'AS [CONS TYPE (APPEND HOWUSED (CDDR (ASSOC 'AS oldWordDef] oldWordDef)) (MSADDMODIFIER 'USE TYPE TABLES]) ) (RPAQ? MSCHECKFNS NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES) ) (RPAQQ MSDBCOMS [(FNS MSMARKCHANGE1 MSINIT GETVERBTABLES MSSTOREDATA STORETABLE) (ADDVARS (MSCHANGEDARRAY) (MSDATABASELST)) (INITVARS (MSDBEMPTY T)) (VARS MSDATABASEINIT NODUMPRELATIONS) (FNS PARSERELATION PARSERELATION1 GETRELATION MAPRELATION TESTRELATION) (COMS (FNS ADDHASH SUBHASH MAKEHASH MSREHASH EQMEMBHASH) [P (MAPC '((GETHASH GETTABLE) (GETHASH TESTTABLE) (PUTHASH PUTTABLE) (ADDHASH ADDTABLE) (SUBHASH SUBTABLE) (MAPHASH MAPTABLE) (MAKEHASH MAKETABLE) (EQMEMBHASH EQMEMBTABLE)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X] (FNS MSVBTABLES MSUSERVBTABLES) (INITVARS (MSUSERVBTABLES (MAKETABLE 2)) (MSANALYZEFNS (MAKETABLE 2))) (FNS BUILDGETRELQ BUILDTESTRELQ) (DECLARE%: DONTCOPY (MACROS GETRELQ TESTRELQ))) (COMS (FNS MSERASE)) (COMS (FNS DUMPDATABASE DUMPDATABASE1 READATABASE) (VARS DATABASECOMS)) (ADDVARS (GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE]) (DEFINEQ (MSMARKCHANGE1 [LAMBDA (FNS FLG) (* rmk%: "19-FEB-81 14:53") (* mark the selected functions as "changed" -  FLG=T in MSCHANGEDARRAY means to complain if the definition can't be found, 0  means give up quietly.) (OR FLG (SETQ FLG T)) (for FN inside FNS do (PUTHASH FN FLG MSCHANGEDARRAY)) (* This isn't undone by simply restoring the pevious entry in the hash array  because the user might have asked a question that caused the functions to be  reanalyzed. Against this possibility, we "undo" by re-marking the functions  for reanalysis.) (UNDOSAVE (LIST (FUNCTION MSMARKCHANGE1) FNS FLG]) (MSINIT (LAMBDA (DATABASE) (* ; "Edited 12-Jun-90 20:45 by teruuchi") (* ;; "lmm %"29-Jul-85 21:06%"") (* ;; "This function should be called at the beginning of any function which accesses the data base") (COND ((OR (NULL MSDATABASELST) (LISTP DATABASE)) (SETQ MSDATABASELST) (pushnew MARKASCHANGEDFNS (QUOTE MSMARKCHANGED)) (SETQ MSCHANGEDARRAY (HASHARRAY 128)) (* ;; "MSDATABASEINIT is a pattern for how the data base list should look. The data base is stored in multiple hash tables. These hash tables are pointed to both by a list, MSDATABASELST which is an a-list of (TableName ForwardTable . BackTable) while the array, MSDATABASE, is an array of the same length as the list, with ELT's the forward htables, and ELTD's the back tables.") (OR DATABASE (SETQ MSDBEMPTY)) (SETQ MSDATABASELST (for X in MSDATABASEINIT collect (CONS (CAR X) (CONS (OR (CADR (ASSOC (CAR X) DATABASE)) (SELECTQ (CAR X) (USERTEMPLATES USERTEMPLATES) (MAKETABLE (CADR X) (CAR X)))) (COND ((FIXP (CDDR X)) (OR (CDDR (ASSOC (CAR X) DATABASE)) (MAKETABLE (CDDR X) (CAR X) T))) (T (CDDR X))))) finally (SETQ MSFILETABLE (ASSOC (QUOTE FILE) $$VAL)) (SETQ MSARGTABLE (ASSOC (QUOTE ARGS) $$VAL)))) T))) ) (GETVERBTABLES [LAMBDA (ROOT MODIFIER) (* lmm "28-FEB-79 16:08") (for Y in (OR (MSVBTABLES ROOT MODIFIER) (SHOULDNT 3)) collect (COND [(LISTP Y) (LIST (CDDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) (MSSTOREDATA [LAMBDA (FNNAME FNDATA) (* lmm " 1-JUN-81 23:19") (PROG [NEWREL (KWN (PARSERELATION 'KNOWN] (SETQ MSDBEMPTY NIL) (* Database for FNNAME about to become inconsistant -  mark it as changed) (PUTHASH FNNAME T MSCHANGEDARRAY) (* * Now update the database) (for TAB in MSDATABASELST when (AND (NOT (FMEMB (CAR TAB) NODUMPRELATIONS)) (NEQ (CDDR TAB) T)) do (SETQ NEWREL (MSCOLLECTDATA (CAR TAB))) (STORETABLE FNNAME TAB NEWREL)) [OR (TESTRELATION FNNAME KWN) (PUTTABLE FNNAME T (CADR (FASSOC 'NOBIND MSDATABASELST] (* Table NOBIND is for those functions which don't do very much.  The idea is that the test that a function has been analyzed is whether it  binds variables are calls functions, etc.  However, for those functions which have no such entries,  (e.g. their definition is (LAMBDA NIL NIL)) need to still be able to know  that they were.) (PUTHASH FNNAME NIL MSCHANGEDARRAY]) (STORETABLE [LAMBDA (KEY TABLST VALUE) (* lmm "10-APR-81 08:46") (PROG [(OLDREL (GETTABLE KEY (CADR TABLST] (PUTTABLE KEY VALUE (CADR TABLST)) (COND ((CDDR TABLST) (for Z in VALUE do (* Used to test here (NOT (EQMEMB Z OLDREL)) but occasionally found the data  base was out of synch & A calls B but B doesn't show being called by A;  thus we always add KEY to Z's back pointers  (nothing will be done if it is already there)) (ADDTABLE Z KEY (CDDR TABLST))) (for Z in OLDREL do (* However, we must rely on the previous value to tell who values must be  DELETED from) (AND (NOT (FMEMB Z VALUE)) (SUBTABLE Z KEY (CDDR TABLST]) ) (ADDTOVAR MSCHANGEDARRAY ) (ADDTOVAR MSDATABASELST ) (RPAQ? MSDBEMPTY T) (RPAQQ MSDATABASEINIT ((CALL 25 . 50) (BIND 10 . 10) [NLAMBDA 10 . 10] (NOBIND 10) (RECORD 20 . 10) (CREATE 2 . 2) (FETCH 10 . 10) (REPLACE 10 . 10) (REFFREE 10 . 1) (REF 10 . 25) (SETFREE 1 . 1) (SET 20 . 30) (SMASHFREE 1 . 1) (SMASH 1 . 1) (PROP 1 . 1) (TEST 1 . 1) (TESTFREE 1 . 1) (PREDICATE 10 . 10) (EFFECT 10 . 10) (CLISP 10 . 10) (SPECVARS 10 . 10) (LOCALVARS 10 . 10) (APPLY 10 . 10) (ERROR 10 . 10) (LOCALFREEVARS 10 . 10) (CONTAINS 10 . 10) (FILE 10) (ARGS 10) (USERTEMPLATES NIL . T) (0 10 . 10) (FPTYPE 10 . 10) (KEYACCEPT 2 . 2) (KEYSPECIFY 2 . 2) (KEYCALL 2 . 2) (FLET 2 . 2) (LABEL 2 . 2) (MACROLET 2 . 2) (COMPILER-LET 2 . 2) (SENDNOTSELF 2 . 2) (SENDSELF 2 . 2) (IMPLEMENT 2 . 2) (GETNOTSELF 2 . 2) (GETSELF 2 . 2) (GETCVSELF 2 . 2) (GETCVNOTSELF 2 . 2) (PUTNOTSELF 2 . 2) (PUTSELF 2 . 2) (PUTCVSELF 2 . 2) (PUTCVNOTSELF 2 . 2) (OBJECT 2 . 2))) (RPAQQ NODUMPRELATIONS (CONTAINS FILE)) (DEFINEQ (PARSERELATION [LAMBDA (RELATION) (* lmm "11-Jul-86 15:50") (MSINIT) (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (CONS 'TABLES (for Y in (PARSERELATION1 RELATION) collect (COND [(LISTP Y) (CDR (CDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) (PARSERELATION1 [LAMBDA (ROOT MOD TAIL) (* lmm "30-DEC-78 17:06") (COND [TAIL (APPLY* (SELECTQ (CAR TAIL) (ANDNOT (FUNCTION LDIFFERENCE)) (AND (COND ((EQ (CADR TAIL) 'NOT) (SETQ TAIL (CDR TAIL)) (FUNCTION LDIFFERENCE)) (T (FUNCTION INTERSECTION)))) (OR (FUNCTION UNION)) (ERROR TAIL '?)) (PARSERELATION1 ROOT MOD) (PARSERELATION1 (CADR TAIL) (CDDR TAIL] ((LISTP ROOT) (PARSERELATION1 (CAR ROOT) (CDR ROOT))) [(LISTP MOD) (SELECTQ (CAR MOD) ((A AS AN FOR) (PARSERELATION1 ROOT (CDR MOD))) ((AND OR ANDNOT) (PARSERELATION1 ROOT NIL MOD)) (PARSERELATION1 ROOT (CAR MOD) (CDR MOD] (T (OR (MSVBTABLES ROOT MOD) [MSVBTABLES (GETWORDTYPE ROOT 'S) (CAR (OR (GETWORDTYPE MOD 'V) (GETWORDTYPE MOD 'AS) (GETWORDTYPE MOD 'FOR) (ERROR MOD '?] (ERROR ROOT '?]) (GETRELATION [LAMBDA (ITEM RELATION INVERTED) (* lmm "11-Jul-86 15:51") (PROG (VAL) (for TABLE in [CDR (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (PARSERELATION RELATION] do (SETQ VAL (UNION [GETTABLE ITEM (COND (INVERTED (COND ((LITATOM (CDR TABLE)) (ERROR RELATION "CAN'T BE INVERTED"))) (CDR TABLE)) (T (CAR TABLE] VAL))) (RETURN VAL]) (MAPRELATION [LAMBDA (RELATION MAPFN) (* lmm "21-SEP-78 04:20") (DECLARE (SPECVARS MAPZ MAPW MAPFN2 MAPFN)) (PROG ((MAPZ (NARGS MAPFN)) (MAPW (PARSERELATION RELATION))) (MAP (CDR MAPW) (FUNCTION (LAMBDA (MAPFN2) (MAPTABLE (CAAR MAPFN2) (FUNCTION (LAMBDA (DUMMY MAPX) (OR [SOME (CDR MAPFN2) (FUNCTION (LAMBDA (HT2) (TESTTABLE MAPX (CAR HT2] (COND ((EQ MAPZ 1) (APPLY* MAPFN MAPX)) (T (MAPC (GETRELATION MAPX MAPW) (FUNCTION (LAMBDA (Z) (APPLY* MAPFN MAPX Z]) (TESTRELATION [LAMBDA (ITEM RELATION ITEM2 INVERTED) (* lmm "25-JUN-78 01:16") (AND [SOME [CDR (COND ((EQ (CAR RELATION) 'TABLES) RELATION) (T (PARSERELATION RELATION] (FUNCTION (LAMBDA (TABLE) (COND [ITEM2 (FMEMB ITEM2 (GETTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] (T (TESTTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] T]) ) (DEFINEQ (ADDHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (* Add VAL to the hash-key of ITEM  in ARRAY) (PROG ((OV (GETHASH ITEM ARRAY))) (COND (OV (OR (FMEMB VAL OV) (NCONC1 OV VAL))) (T (PUTHASH ITEM (LIST VAL) ARRAY]) (SUBHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (PROG ((OV (GETHASH ITEM ARRAY))) (AND OV (OR (DREMOVE VAL OV) (PUTHASH ITEM NIL ARRAY]) (MAKEHASH [LAMBDA (N) (* rmk%: " 3-Jan-84 21:31") (HASHARRAY N (FUNCTION MSREHASH]) (MSREHASH [LAMBDA (HA) (* rmk%: "30-Dec-83 11:45") (* The hash tables in the database rehash using this algorithm;  they increase size by 25% + 50 This insures that even though some tables  start out small (e.g. 1 or 2 elements) they will rehash to larger ones.) (IPLUS (IQUOTIENT (ITIMES 5 (HARRAYSIZE HA)) 4) 50]) (EQMEMBHASH [LAMBDA (X V H) (* rmk%: "10-JUN-79 21:00") (* Provided in case MSHASH is loaded  without MSSWAP) (MEMB V (GETHASH X H]) ) [MAPC '((GETHASH GETTABLE) (GETHASH TESTTABLE) (PUTHASH PUTTABLE) (ADDHASH ADDTABLE) (SUBHASH SUBTABLE) (MAPHASH MAPTABLE) (MAKEHASH MAKETABLE) (EQMEMBHASH EQMEMBTABLE)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X] (DEFINEQ (MSVBTABLES [LAMBDA (VERB MOD) (* ; "Edited 30-Jun-87 10:32 by jrb:") (* ;; "The call to MSUSERVBTABLES checks a user hash table to allow extensions.") [COND ((LISTP VERB) (SETQ MOD (CADR VERB)) (SETQ VERB (CAR VERB] (MKLIST (OR (SELECTQ VERB (BIND (SELECTQ MOD (NIL '(BIND REF SET SMASH TEST)) (NOTUSE 'BIND) NIL)) (CALL (SELECTQ MOD (DIRECTLY '(CALL EFFECT PREDICATE NLAMBDA)) (EFFECT 'EFFECT) (INDIRECTLY 'APPLY) (NIL '(APPLY CALL EFFECT ERROR PREDICATE NLAMBDA)) (NOTERROR '(APPLY CALL EFFECT PREDICATE NLAMBDA)) (PREDICATE 'PREDICATE) (TESTING 'PREDICATE) (VALUE '(CALL NLAMBDA)) (NLAMBDA 'NLAMBDA) NIL)) (CREATE (SELECTQ MOD (NIL 'CREATE) NIL)) (DECLARE (SELECTQ MOD (CL:LOCALLY 'LOCALVARS) (LOCALVARS 'LOCALVARS) (NIL '(LOCALVARS SPECVARS)) (SPECVARS 'SPECVARS) NIL)) (FETCH (SELECTQ MOD (NIL 'FETCH) NIL)) (IS (SELECTQ MOD (FIELDS '((FETCH) (REPLACE))) (FNS '(CALL NOBIND REF (CALL) (APPLY))) (KNOWN '(CALL NOBIND REF)) (NIL '(CALL NOBIND REF (CALL) (BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (RECORDS) (FETCH) (REPLACE) (PROP) (APPLY) (TEST) (TESTFREE))) (PROPS '((PROP))) (RECORDS '((RECORD) (CREATE))) (VARS '((BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (TEST) (TESTFREE))) (TYPE '((0))) NIL)) (KNOWN (SELECTQ MOD (NIL '(CALL NOBIND REF)) NIL)) (PROG (SELECTQ MOD (NIL 'PROG) NIL)) (REFERENCE (SELECTQ MOD (FIELDS 'FETCH) (FREELY '(REFFREE TESTFREE SMASHFREE)) (CL:LOCALLY '(REF TEST SMASH)) (NIL '(REF REFFREE TEST TESTFREE SMASH SMASHFREE)) NIL)) (REPLACE (SELECTQ MOD (NIL 'REPLACE) NIL)) (SET (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SETFREE) (CL:LOCALLY 'SET) (NIL '(SET SETFREE)) NIL)) (SMASH (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SMASHFREE) (CL:LOCALLY 'SMASH) (NIL '(SMASH SMASHFREE)) NIL)) (TEST (SELECTQ MOD (FREELY 'TESTFREE) (CL:LOCALLY 'TEST) (NIL '(TEST TESTFREE)) NIL)) (USE (SELECTQ MOD (FIELDS '(FETCH REPLACE)) (FREELY '(REFFREE SETFREE SMASHFREE TESTFREE)) (I.S.OPRS 'CLISP) (INDIRECTLY 'LOCALFREEVARS) (CL:LOCALLY '(REF SET SMASH TEST)) (NIL '(REF REFFREE SET SETFREE SMASH SMASHFREE TEST TESTFREE)) (PREDICATE '(TEST TESTFREE)) (PROPNAMES 'PROP) (RECORDS '(CREATE RECORD)) (TESTING '(TEST TESTFREE)) (VALUE '(REF REFFREE SMASH SMASHFREE)) (TYPE '0) NIL)) NIL) (MSUSERVBTABLES VERB MOD]) (MSUSERVBTABLES [LAMBDA (VERB MOD) (* smL "20-Dec-85 17:03") (* * Find the relation tables for a user-defined relation) (OR [AND (BOUNDP 'MSUSERVBTABLES) (HASHARRAYP MSUSERVBTABLES) (CDR (for modifier in (GETHASH VERB MSUSERVBTABLES) thereis (EQMEMB MOD (CAR modifier] VERB]) ) (RPAQ? MSUSERVBTABLES (MAKETABLE 2)) (RPAQ? MSANALYZEFNS (MAKETABLE 2)) (DEFINEQ (BUILDGETRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:36 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM F1) [for REL in (MSVBTABLES (CAR X)) do [SETQ F1 (LIST 'GETTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE REL) 'MSDATABASELST] (SETQ FORM (COND (FORM (LIST 'UNION F1 FORM)) (T F1] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) (BUILDTESTRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:41 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM) [SETQ FORM (CONS 'OR (for R in (MSVBTABLES (CAR X)) collect (LIST 'TESTTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE R) 'MSDATABASELST] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS GETRELQ MACRO (X (BUILDGETRELQ X))) (PUTPROPS TESTRELQ MACRO (X (BUILDTESTRELQ X))) ) ) (DEFINEQ (MSERASE [LAMBDA (ATOMS) (* lmm " 1-JUN-81 22:56") (DECLARE (SPECVARS ERASESET)) (COND ((EQ ATOMS T) (SETQ MSCHANGEDARRAY) (SETQ MSDATABASELST) (SETQ MSFILETABLE) (SETQ MSARGTABLE) (SETQ MSDBEMPTY T)) (T (for AT in ATOMS do (MSSTOREDATA AT]) ) (DEFINEQ (DUMPDATABASE [LAMBDA (FNLST) (* lmm "12-APR-81 15:57") (PROG (DUMPEDFLG) (DECLARE (SPECVARS DUMPEDFLG DUMPTABLE)) (COND (FNLST (MAPC FNLST (FUNCTION UPDATEFN))) (T (UPDATECHANGED))) (PRINT '(READATABASE)) (PRIN1 '%() (TERPRI) [for DUMPTABLE in MSDATABASELST when (NOT (MEMB (CAR DUMPTABLE) NODUMPRELATIONS)) do (SETQ DUMPEDFLG NIL) [COND ((OR (NOT FNLST) (EQ (CDDR DUMPTABLE) T)) (* either dumping everything, or this is a permanent table which should be  dumped in entirity (e.g. templates)) (MAPTABLE (CADR DUMPTABLE) (FUNCTION DUMPDATABASE1))) (T (MAPC FNLST (FUNCTION (LAMBDA (FN) (DUMPDATABASE1 (GETTABLE FN (CADR DUMPTABLE)) FN] (COND (DUMPEDFLG (PRINT] (TERPRI) (PRIN1 '%)) (TERPRI]) (DUMPDATABASE1 [LAMBDA (VALUE FN) (* rmk%: "24-OCT-79 10:02") (COND (FN (COND ((NOT DUMPEDFLG) (SETQ DUMPEDFLG (PRIN2 (CAR DUMPTABLE))) (SPACES 1))) (PRIN2 FN) (SPACES 1) (PRIN2 VALUE) (SPACES 1]) (READATABASE [LAMBDA NIL (* ; "Edited 3-Jun-88 12:34 by jrb:") [SELECTQ (RATOM) ((%[ %()) (HELP '(BAD DATABASE] (MSINIT) (SETQ MSDBEMPTY) (PROG (TAB FN NEWREL NAME) (while (SETQ NAME (READ)) do (SELECTQ NAME (USERTEMPLATES (while (SETQ FN (READ)) do (TEMPLATE FN (READ) T))) (COND ((SETQ TAB (FASSOC NAME MSDATABASELST)) (while (SETQ FN (READ)) do (PUTHASH FN T MSCHANGEDARRAY) (SETQ NEWREL (MKLIST (READ))) (STORETABLE FN TAB NEWREL) (PUTHASH FN NIL MSCHANGEDARRAY))) (T (LISPXPRINT "*** incompatible MASTERSCOPE data base" T T) (while (READ]) ) (RPAQQ DATABASECOMS ((E (DUMPDATABASE)))) (ADDTOVAR GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE))) (RPAQQ MSCHECKBLOCKSCOMS ((FNS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE GLOBALVARP PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT) (BLOCKS (MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) (NOLINKFNS . T) (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS DONTCOMPILEFNS ENTRIES) (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) GLOBALVARP)))) (DEFINEQ (MSCHECKBLOCKS [LAMBDA (FILES) (* ; "Edited 2-Jun-88 13:45 by jrb:") (PROG ((LOCALVARS SYSLOCALVARS) (SPECVARS T) FNS BLOCKS NOBLOCKFNS TEM) [COND ((NULL FILES) (SETQ FILES FILELST)) ((NLISTP FILES) (SETQ FILES (OR (GETP FILES 'FILEGROUP) (LIST FILES] [for FL in FILES do (MSNOTICEFILE FL) (SETQ BLOCKS (NCONC (FILECOMSLST FL 'BLOCKS) BLOCKS)) (* ;;  "JRB - Check now gathers everything analyzable, not just FNS") (MAPC [SETQ TEM (for FT in MSFNTYPES join (FILECOMSLST FL (ffetch (MSANALYZABLE FILEPKGNAME) of FT] (FUNCTION UPDATEFN)) (SETQ FNS (NCONC TEM FNS)) (COND ((SETQ TEM (FILECOMSLST FL 'LOCALVARS)) (APPLY (FUNCTION LOCALVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'SPECVARS)) (APPLY (FUNCTION SPECVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'GLOBALVARS)) (* ;; "Ordinarily a noop, since noticing the file sets up GLOBALVARS (unlike SPECVARS and LOCALVARS, which are EVAL@COMPILE); however, user might have edited coms since then") (APPLY (FUNCTION ADDTOVAR) (CONS 'GLOBALVARS TEM] (UPDATECHANGED) (TAB 0 0) (COND ((SETQ NOBLOCKFNS (for FN in FNS unless [OR (MEMB FN DONTCOMPILEFNS) (for BLOCK in BLOCKS thereis (MEMB FN (CDR BLOCK] collect FN)) (MSCHECKBLOCK (CONS (COND [BLOCKS (APPEND '("no block - ") (COND [(CDDDDR NOBLOCKFNS) (APPEND (LDIFF NOBLOCKFNS (CDDDDR NOBLOCKFNS )) '("--"] (T NOBLOCKFNS] (T (CONS "File" FILES))) NOBLOCKFNS) FNS BLOCKS))) (for BLOCK in BLOCKS do (MSCHECKBLOCK BLOCK FNS BLOCKS]) (MSCHECKBLOCK [LAMBDA (BLOCK FNS BLOCKS) (* ; "Edited 3-Jun-88 10:50 by jrb:") (LET ((SPECVARS SPECVARS) (LOCALVARS LOCALVARS) (BLKNAME (CAR BLOCK)) BLKAPPLYFNS ENTRIES LOCALFREEVARS BLKFNS FREEVARS TEM TEM2 BOUNDFREE BLKAPPLYCALLERS ERRORS SHOULDBESPECVARS (GLOBALVARS GLOBALVARS) (RETFNS RETFNS) (BLKLIBRARY BLKLIBRARY) (NOLINKFNS NOLINKFNS) (LINKFNS LINKFNS) (DONTCOMPILEFNS DONTCOMPILEFNS)) (DECLARE (SPECVARS GLOBALVARS RETFNS BLKLIBRARY NOLINKFNS LINKFNS DONTCOMPILEFNS)) (COND ((LISTP BLKNAME) (SETQ BLKNAME NIL))) [COND (BLKNAME (SETQ LOCALVARS T) (SETQ SPECVARS (COND ((NEQ SPECVARS T) (UNION SYSSPECVARS SPECVARS)) (T SYSSPECVARS] [for X in (CDR BLOCK) do (* ; "set up declarations and BLKFNS") (COND ((LISTP X) [SETQ TEM (COND ((EQ (CADR X) '*) (EVAL (CADDR X))) (T (CDR X] (SET (CAR X) (COND ((NLISTP (CDR X)) (CDR X)) ([LISTP (SETQ TEM2 (EVALV (CAR X] (APPEND TEM TEM2)) (T TEM))) (* ;; "ASSERT: ((REMOTE EVAL) SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)") (SELECTQ (CAR X) (SPECVARS (COND ((EQ TEM T) (SETQ LOCALVARS SYSLOCALVARS)))) (LOCALVARS (COND ((EQ TEM T) (SETQ SPECVARS SYSSPECVARS)))) ((LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)) (DOERROR (CAR X) "unrecognized item in block declaration"))) ((MEMB X BLKFNS) (DOERROR X "on block twice")) (T (SETQ BLKFNS (CONS X BLKFNS] (COND (BLKNAME (MSCHECKBLOCKBASIC BLOCK BLKNAME)) (T (COND (BLKAPPLYFNS (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but not a real block" NIL T))) (SETQ BLKLIBRARY NIL))) (for FN in BLKFNS do (OR (FMEMB FN FNS) (FMEMB FN BLKLIBRARY) (DOERROR FN "not on the file")) (COND (BLKNAME (* ; "a real block") (MSCHECKFNINBLOCK FN BLOCK BLOCKS))) [for VAR in (UNION (SETQ TEM (GETRELQ (BIND NOTUSE) FN)) (GETRELQ (USE CL:LOCALLY) FN)) do [OR (FMEMB VAR BOUNDFREE) (FMEMB VAR SYSSPECVARS) (GLOBALVARP VAR) (COND ((TESTRELQ (USE FREELY) VAR T) (* ;  "i.e. it is bound in this block, and used freely by someone else") (SETQ BOUNDFREE (CONS VAR BOUNDFREE))) ((SPECVARP VAR FN) (AND (NEQ SPECVARS T) (UNECCSPEC FN VAR))) ((FMEMB VAR TEM) (DOERROR FN "binds and never uses" VAR T] (COND ((AND (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (NOT (SPECVARP VAR FN))) (DOERROR VAR "should be SPECVAR (used in functional arg) in" FN T] (SETQ FREEVARS (UNION (GETRELQ (USE FREELY) FN) FREEVARS))) (MSCHECKBOUNDFREE BOUNDFREE BLKNAME) [for VAR in FREEVARS unless (OR (FMEMB VAR SHOULDBESPECVARS) (FMEMB VAR SYSSPECVARS) (FMEMB VAR (LISTP SPECVARS)) (FMEMB VAR LOCALFREEVARS) (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR) (CL:CONSTANTP VAR) (GET VAR 'GLOBALLY-SPECIAL)) do (COND ((NULL (SETQ TEM (for FN in (GETRELQ (USE FREELY) VAR T) when (FMEMB FN BLKFNS) collect FN))) (* ; "Nobody uses it??") ) ((TESTRELQ BIND VAR T) (DOERROR VAR "not declared, used freely by " TEM 0)) ((NOT (BOUNDP VAR)) (DOERROR VAR "not declared, never bound, no top-level value, used freely by" TEM T)) (T (DOERROR VAR "not bound, not a GLOBALVAR, used freely by" TEM T] (for DEC in BLOCK when (LISTP DEC) do (SELECTQ (CAR DEC) ((SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS) (for VAR in (CDR DEC) unless (OR (FMEMB VAR BOUNDFREE) (FMEMB VAR FREEVARS) (for FN in (GETRELQ BIND VAR T) thereis (FMEMB FN BLKFNS))) do (DOERROR VAR "not mentioned in block, but on" (CAR DEC) T))) NIL)) (COND (ERRORS (OR (ZEROP (POSITION)) (TERPRI)) (TERPRI) (PRIN1 "<<<<< In "))) [MSMSGPRINT (OR (CAR BLOCK) (CONS NIL (NCONC (for X in (CDR BLOCK) collect X repeatuntil (NLISTP X)) '(--] (COND (ERRORS (PRIN1 ": >>>>>") (MAPC (SETQ ERRORS (DREVERSE ERRORS)) (FUNCTION PRINTERROR)) (PRIN1 "---------------- ")) (T (PRIN1 ", "]) (MSCHECKFNINBLOCK [LAMBDA (FN BLOCK BLOCKS) (* bvm%: "26-Mar-84 12:02") (* * Checks things related to FN in a real block) (PROG (INDIRECTCALLERS MACRODEF ISCALLEDP) (COND ([AND (SETQ MACRODEF (GETPROP FN 'MACRO)) (OR (NULL (CAR MACRODEF)) (LISTP (CAR MACRODEF))) (NOT (FMEMB FN ENTRIES)) (NOT (MSFIND MACRODEF 'IGNOREMACRO] (* no point in having it in the block, since all of the other block fns would  get the -  however, computed macros might return IGNOREMACRO) (DOERROR FN "internal block function with MACRO property" NIL T))) (COND ((AND (NOT (FMEMB FN ENTRIES)) (NOT (FMEMB FN BLKLIBRARY))) (* Check that internal FN is not called from outside the block) (SETQ ISCALLEDP NIL) [for FN2 in (UNION (SETQ INDIRECTCALLERS (GETRELQ (CALL INDIRECTLY) FN T)) (GETRELQ (CALL DIRECTLY) FN T)) do (* FN2 calls FN) (COND ((AND (NEQ FN2 FN) (FMEMB FN2 BLKFNS)) (* is called by somebody in the  block) (SETQ ISCALLEDP T))) (COND [(NOT (FMEMB FN2 BLKFNS)) (COND ([NOT (for OTHERBLOCK in BLOCKS thereis (AND (NEQ OTHERBLOCK BLOCK) (MEMB FN (CDR OTHERBLOCK)) (OR (NULL (CAR OTHERBLOCK)) (MEMB FN2 (CDR OTHERBLOCK] (* called by FN2 outside the block, and FN is not also a member of a block  containing FN2) (DOERROR FN "not an entry, called from outside the block by" FN2] ((FMEMB FN2 INDIRECTCALLERS) (* called indirectly) (OR (FMEMB FN RETFNS) (FMEMB FN BLKAPPLYFNS) (DOERROR FN "not an entry or on RETFNS or BLKAPPLYFNS, called indirectly by" FN2] (COND ((AND (NOT ISCALLEDP) (NOT (FMEMB FN BLKAPPLYFNS))) (DOERROR FN "not an entry, not called from inside the block"]) (MSCHECKBLOCKBASIC [LAMBDA (BLOCK BLKNAME) (* bvm%: "26-Mar-84 11:45") (* check for things having to do  with real blocks) [COND ((AND (NULL ENTRIES) (MEMB BLKNAME BLKFNS)) (COND ((NEQ BLKNAME (CADR BLOCK)) (DOERROR BLKNAME "must also be the FIRST function in the block"] [COND ((AND (EQ BLKNAME (CAR ENTRIES)) (NULL (CDR ENTRIES)) (NULL BLKAPPLYFNS)) (* MKENTRIES treats the case of ENTRIES=NIL specially by not setting up a  separate BLOCK.) (SETQ ENTRIES NIL)) ((AND (NULL ENTRIES) BLKAPPLYFNS) (* Above caper only works if no  BLKAPPLYFNS) (SETQ ENTRIES (LIST BLKNAME] (COND ((MEMB BLKNAME ENTRIES) (DOERROR BLKNAME "can't be both entry and block name"))) (for X in [APPEND BLKAPPLYFNS (OR ENTRIES (SETQ ENTRIES (LIST BLKNAME] do (OR (MEMB X BLKFNS) (DOERROR X "on ENTRIES or BLKAPPLYFNS but not in block"))) (for FN in BLKLIBRARY when (AND [NOT (FMEMB FN '(EQUAL GETPROP GETP NTH TAILP MEMBER] (for Y in (GETRELQ (CALL NOTERROR) FN T) thereis (FMEMB Y BLKFNS))) do (COND ((NULL (GETPROP FN 'BLKLIBRARYDEF)) (DOERROR FN "on BLKLIBRARY but no BLKLIBRARYDEF property" NIL T))) (SETQ BLKFNS (NCONC1 BLKFNS FN))) (COND ([AND BLKAPPLYFNS (NOT (SETQ BLKAPPLYCALLERS (for X in '(BLKAPPLY BLKAPPLY*) join (for Y in (GETRELQ (CALL NOTERROR) X T) when (FMEMB Y BLKFNS) collect Y] (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but no calls to BLKAPPLY in block" NIL T]) (MSCHECKBOUNDFREE [LAMBDA (BOUNDFREE BLKNAME) (* bvm%: "26-Mar-84 12:08") (for V in BOUNDFREE do (SCRATCHASH SEEN (PROG ((USERS (GETRELQ (USE FREELY) V T)) (LF (FMEMB V LOCALFREEVARS)) (BINDERS (GETRELQ BIND V T)) LF1 SFLG) (CLRHASH SEEN) (for X in USERS do (PUTHASH X -1 SEEN)) (for X in BINDERS do (PUTHASH X 1 SEEN)) (for U in USERS do (COND ((FMEMB U BLKFNS) (COND ((FMEMB U BINDERS) (NECCSPEC V U U))) (SETQ LF1 LF))) (MSCHECKVARS1 U)) (COND ((AND (NULL SFLG) (OR BLKNAME (EQ LOCALVARS T)) (NEQ SPECVARS T)) (for X in BINDERS when (FMEMB X BLKFNS) do (SELECTQ (GETHASH X SEEN) (2) (-1) (AND (SPECVARP V X) (UNECCSPEC X V]) (GLOBALVARP [LAMBDA (X) (* lmm "31-DEC-78 15:23") (OR (FMEMB X GLOBALVARS) (GETPROP X 'GLOBALVAR]) (PRINTERROR [LAMBDA (ERR) (* lmm "24-FEB-79 21:15") (PROG ((MSG (CAR ERR)) (VALS (CDDR ERR)) NEWPRS PR POS POS2 (LL (IDIFFERENCE (LINELENGTH) 30)) POS3) (SELECTQ (CAR MSG) (0 (SETQ MSG (CDR MSG)) (PRIN1 " (note) ")) (T (SETQ MSG (CDR MSG)) (PRIN1 " (possible error) ")) (PRIN1 " (probable error) ")) (COND (VALS (for X inside VALS do (PRIN2 X) (SPACES 1)) (PRIN1 '-) (for X inside MSG do (SPACES 1) (PRIN1 X)) (PRIN1 '%.) (TERPRI))) [for PRL on (DREVERSE (CADR ERR)) do [COND ([NULL (CDDR (SETQ PR (CAR PRL] (for ERR in (CDR PRL) do (COND ((EQUAL (CDR ERR) (CDR PR)) (FRPLACA ERR (CONS (CAR PR) (CAR ERR))) (FRPLACA PR NIL) (RETURN] (AND (CAR PR) (SETQ NEWPRS (CONS PR NEWPRS] (COND (NEWPRS (TAB 0 0) (SHORTLST (CAAR NEWPRS) 4) (SETQ POS (POSITION)) (PRIN1 " - ") (for X inside MSG do (PRIN1 X) (SPACES 1)) (SETQ POS2 (POSITION)) [COND ((OR (ILESSP POS2 (IDIFFERENCE POS 3)) (IGREATERP POS2 LL)) (SETQ POS2 (IPLUS POS 10] (SETQ POS3 (IDIFFERENCE (IQUOTIENT (IPLUS POS POS2) 2) 4)) (PRIN1 " -") (SHORTLST (CDAR NEWPRS) 4) (PRIN1 '". ") (MAPC (CDR NEWPRS) (FUNCTION (LAMBDA (PR) (SHORTLST (CAR PR) 4) (TAB POS T) (PRIN1 " -") (TAB POS3 T) (PRIN1 " %"%" ") (TAB POS2 T) (PRIN1 "-") (SHORTLST (CDR PR) 4) (PRIN1 ". "]) (MSCHECKVARS1 [LAMBDA (FN) (* lmm "16-Jul-84 14:54") [COND ((AND LF1 (FMEMB FN ENTRIES)) (DOERROR V [CONS "on LOCALFREEVARS" (COND ((EQ U FN) "but used freely by the entry") (T (LIST "but the entry" FN "can reach functions using it freely"] U T) (SETQ LF (SETQ LF1 NIL] (PROG ((CALLERS (GETRELQ (CALL NOTERROR) FN T)) (VAL 3)) [COND ((FMEMB FN BLKAPPLYFNS) (SETQ CALLERS (UNION BLKAPPLYCALLERS CALLERS] (* interpretation of SEEN codes -  0 recursive call -  -1 uses var -  1 binds var -  2 binds var, path from it to user -  T always bound above -  3 no callers -  4 not always bound above) (for X in CALLERS do (SELECTQ (GETHASH X SEEN) ((0 -1 4)) (3 (SETQ VAL 4)) (1 (* we have found a path from a user up to a binder -  if the path is entirely in the block, then LOCALFREEVAR is ok, -  if the path is outside the block, then it doesn't matter, otherwise SPECVAR) (COND ((FMEMB X BLKFNS) (* if the binder isn't in this  block, ignore) (* should just be SPECVAR if not entirely within the block) (NECCSPEC V X U))) (PUTHASH X 2 SEEN) (COND ((EQ VAL 3) (SETQQ VAL T)))) ((T 2) (COND ((EQ VAL 3) (SETQQ VAL T)))) (NIL (* now check recursively) (PUTHASH X 0 SEEN) (PUTHASH X (MSCHECKVARS1 X) SEEN)) (SHOULDNT 4))) (RETURN VAL]) (UNECCSPEC [LAMBDA (FN VAR) (* lmm "30-AUG-78 03:36") (OR (GLOBALVARP VAR) (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (DOERROR VAR "might not need to be a specvar in" FN T]) (NECCSPEC [LAMBDA (VAR BINDER) (* lmm "21-SEP-78 04:21") (COND ((NOT (OR SFLG (SPECVARP VAR BINDER))) (SETQ SFLG T) (SETQ SHOULDBESPECVARS (CONS VAR SHOULDBESPECVARS)) (DOERROR VAR (LIST "(used freely in)" U "is not a SPECVAR in") BINDER T]) (SPECVARP [LAMBDA (X FN) (* lmm "25-JUN-78 01:15") (COND ((FMEMB X (GETRELQ (DECLARE LOCALVARS) FN)) NIL) ((FMEMB X (GETRELQ (DECLARE SPECVARS) FN)) T) ((NEQ LOCALVARS T) (NOT (FMEMB X LOCALVARS))) (T (OR (EQ SPECVARS T) (FMEMB X SPECVARS) (FMEMB X LOCALFREEVARS) (FMEMB X GLOBALVARS) (GETP X 'GLOBALVAR]) (SHORTLST [LAMBDA (X N) (* lmm " 9-AUG-77 03:18") (COND ((NULL X) N) ((LISTP X) (SHORTLST (CDR X) (SHORTLST (CAR X) N))) (T (COND ((IGREATERP (SETQ N (SUB1 N)) 0) (SPACES 1) (PRIN2 X)) ((ZEROP N) (PRIN1 " etc"))) N]) (DOERROR [LAMBDA (AT MSG ARG QUESTIONABLE) (* lmm "21-Mar-85 08:29") [COND (QUESTIONABLE (SETQ MSG (CONS QUESTIONABLE MSG] (PROG ([L (CDR (OR (SASSOC MSG ERRORS) (CAR (SETQ ERRORS (CONS (CONS MSG (CONS)) ERRORS] (AT AT)) (COND (ARG [SETQ AT (OR (FASSOC AT (CAR L)) (CAAR (FRPLACA L (CONS (CONS AT) (CAR L] (OR (MEMBER ARG (CDR AT)) (NCONC1 AT ARG))) ((NOT (FMEMB AT (CDR L))) (FRPLACD L (CONS AT (CDR L]) (MSMSGPRINT [LAMBDA (MSG) (* ; "Edited 3-Jun-88 12:39 by jrb:") (* ;; "Prints messages Masterscope builds as lists - only atoms get prin2'ed.") (COND ((STRINGP MSG) (PRIN1 MSG)) ((CL:CONSP MSG) (PRIN1 "(") (MSMSGPRINT (pop MSG)) (while (CL:CONSP MSG) do (PRIN1 " ") (MSMSGPRINT (pop MSG))) (if MSG then (PRIN1 " . ") (MSMSGPRINT MSG)) (PRIN1 ")")) (T (PRIN2 MSG]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) (NOLINKFNS . T) (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS DONTCOMPILEFNS ENTRIES) (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) GLOBALVARP) ) (RPAQQ MSPATHSCOMS [(FNS MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN) (BLOCKS (MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING SEPARATE) (GLOBALVARS MSBLIP MSCRATCHASH) (NOLINKFNS . T]) (DEFINEQ (MSPATHS [LAMBDA (FROM TO INVERTED AVOIDING SEPARATE NOTRACE MARKING) (* ; "Edited 3-Jun-88 12:37 by jrb:") (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, or if DEPTH is exceeded -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") (SCRATCHASH SEEN (PROG (TABS (LL (LINELENGTH)) (BELOWCNT 0) (LINENUM 0) (FIRST T) X NAMED TEM (UNDONE (MSLISTSET FROM T))) (COND (INVERTED (PRINTOUT T "inverted tree" T))) [MAPC UNDONE (FUNCTION (LAMBDA (X) (PUTHASH X (COND ((AND NOTRACE (MSMEMBSET X NOTRACE)) -1) (T 0)) SEEN] (TAB 0 0) [RESETVARS ((MSPRINTFLG)) (do (COND (NAMED (OR FIRST (DASHES (GETHASH (CAR NAMED) SEEN))) (SETQ FIRST) (PUTHASH (CAR NAMED) 0 SEEN) (MSPATHS1 (CAR NAMED) NIL T) (SETQ NAMED (CDR NAMED))) (UNDONE [COND ([OR (NULL (SETQ TEM (GETHASH (CAR UNDONE) SEEN))) (EQ TEM 0) (AND (LISTP TEM) (NULL (CAR TEM] (PUTHASH (CAR UNDONE) (LIST NIL) SEEN) (SETQ NAMED (LIST (CAR UNDONE] (SETQ UNDONE (CDR UNDONE))) (T (TERPRI) (RETURN] (RETURN]) (MSPATHS1 [LAMBDA (FROM FIRST LAST) (* lmm " 4-AUG-83 23:45") (PROG (TEM THISLINE POS (XT TABS)) [COND ((NOT FIRST) (TERPRI) (SETQ LINENUM (ADD1 LINENUM)) (* if NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS) then) (PRIN1 LINENUM) (PRIN1 ".") (DOTABS (CDR TABS] (SETQ THISLINE LINENUM) (AND TABS (TAB (CAR TABS) 0)) (AND LAST (SETQ TABS (CDR TABS))) (SETQ POS (MSPATHSPRINTFN FROM)) (MSPATHS2 FROM) (COND [(NEQ (SETQ TEM (GETHASH FROM SEEN)) 0) (* Already expanded on a previous line -  or is a NOTRACE) (COND ((EQ TEM MSBLIP) (SHOULDNT 5)) ((OR (NOT (NUMBERP TEM)) (NOT (MINUSP TEM))) (PRIN1 " {") (PRIN1 (COND ((NLISTP TEM) (* Either line number or overflow  line letter) TEM) [(LISTP TEM) (* A list means that this must be a  sub-tree) (COND ((CAR TEM)) (T (FRPLACA TEM (BELOWMARKER)) (SETQ NAMED (NCONC1 NAMED FROM)) (CAR TEM] (T TEM))) (PRIN1 "}"] (T (PROG ((TABS TABS) (FIRST T) NEXTLEVEL TEM) (PUTHASH FROM (IDIFFERENCE -1 THISLINE) SEEN) (OR (SETQ NEXTLEVEL (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FROM)) (T (GETRELQ CALL FROM T))) when (MSPATHS2 Y) collect Y)) (RETURN)) (* AND (SETQ TEM (FASSOC  (QUOTE SORT) PRINTOPTIONS))  (SORT NEXTLEVEL (CDR TEM))) (COND ([AND XT (OR (SETQ TEM (AND SEPARATE (MSMEMBSET FROM SEPARATE))) (SOME NEXTLEVEL (FUNCTION (LAMBDA (FN) (IGREATERP (IPLUS (NCHARS FN) POS 6) LL] (* NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (SETQ NAMED (NCONC1 NAMED FROM)) (PRIN1 " {") [PRIN1 (COND (TEM (CAR (PUTHASH FROM (LIST (BELOWMARKER)) SEEN))) (T (PUTHASH FROM (BELOWMARKER) SEEN] (PRIN1 "}") (RETURN))) (SETQ TABS (CONS POS TABS)) (PUTHASH FROM THISLINE SEEN) (for X on NEXTLEVEL do (MSPATHS1 (CAR X) FIRST (NULL (CDR X))) (SETQ FIRST]) (MSPATHS2 [LAMBDA (FN FLG) (* lmm "20-Jul-84 14:36") (* Returns T if FN should be PRINTED -  The SEEN table contains one of the following entries for a function -  MSBLIP %: don't print the function at all -  n a number %: don't trace it, it was expanded previously -  -n %: don't trace it, it was printed earlier, though it had no sub-functions  -  0 %: yes, print and trace it -  -1 %: yes, print it, but don't trace it -  (NIL)%: it should be given a separate tree, as yet unnamed -  (letter)%: give it a separate tree with this letter name -  letter %: the function is expanded in an OVERFLOW table below) (* When below MSPATHS4 for ON PATH sets  (and CALL SOMEHOW) the SEEN table contains either 0 %: not traced yet, MSBLIP  %: don't print, -1 print, don't trace, T %: top set  (e.g. for CALLED SOMEHOW BY X, X is originally marked T) 1 already seen and  traced) (NEQ [OR (GETHASH FN SEEN) (PROGN (OR INVERTED (UPDATEFN FN NIL 0)) (COND ((AND AVOIDING (MSMEMBSET FN AVOIDING)) (* If it is avoiding, then no) (PUTHASH FN MSBLIP SEEN)) ((AND (NULL FLG) NOTRACE (MSMEMBSET FN NOTRACE)) (* Will not be traced%: entry should be either MSBLIP or -1 depending on  whether the function should be printed) (COND ((MSPATHS2 FN T) (PUTHASH FN -1 SEEN)) (T MSBLIP))) ((NULL TO) (PUTHASH FN (COND ((AND (NULL INVERTED) (GETD FN) (NOT (TESTRELQ KNOWN FN))) MSBLIP) (T 0)) SEEN)) ((MSMEMBSET FN TO) (* If it is in the TO set, then definitly YES) (PUTHASH FN 0 SEEN)) (T (* Will a path through this function eventually print out an element of TO?) (PUTHASH FN MSBLIP SEEN) (* assume not) (COND ((OR (NULL FLG) (NULL NOTRACE) (NOT (MSMEMBSET FN NOTRACE))) (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FN)) (T (GETRELQ CALL FN T))) when (MSPATHS2 Y) do (RETURN (PUTHASH FN 0 SEEN)) finally (RETURN MSBLIP))) (T MSBLIP] MSBLIP]) (MSONPATH [LAMBDA (SETREP) (* ; "Edited 15-Aug-90 11:53 by jds") (PROG ((FROM (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of SETREP))) (TO (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of SETREP))) (AVOIDING (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of SETREP) )) (NOTRACE (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of SETREP))) INVERTED (TOPFLG (fetch (PATHOPTIONS TOPFLG) of (fetch MSPATHOPTIONS of SETREP))) (SEEN (HASHARRAY 20)) TEM) (COND ((NULL FROM) (SETQ INVERTED T) (SETQ FROM TO) (SETQ TO NIL))) (SETQ TEM (MSLISTSET FROM T)) [MAPC TEM (FUNCTION (LAMBDA (X) (PUTHASH X 0 SEEN] (* 0 means yes expand, not expanded  yet) [MAPC TEM (FUNCTION (LAMBDA (X) (MSPATHS4 X TOPFLG] (RETURN SEEN]) (MSPATHS4 [LAMBDA (FROM TOP) (* lmm "25-JUN-78 01:10") (* traces paths from FROM. When done, the SEEN array will contain MSBLIP or  NIL for entries not expanded, 0 for entries which should be expanded but  weren't for some reason (probably a bug)%, 1 for entries which were below the "top"  and T for entries which were above the top only) (PROG (TEM) (COND ((MSPATHS2 FROM) (COND ((EQ (SETQ TEM (GETHASH FROM SEEN)) 0) (PUTHASH FROM (COND (TOP T) (T 1)) SEEN) (for Y in (COND (INVERTED (GETRELQ CALL FROM T)) (T (GETRELQ CALL FROM))) do (MSPATHS4 Y))) ((AND (EQ TEM T) (NOT TOP)) (PUTHASH FROM 1 SEEN]) (DASHES [LAMBDA (MARKER) (* lmm "21-JAN-79 14:28") (TERPRI) (FRPTQ (IDIFFERENCE LL 20) (PRIN1 '-)) (PRIN1 (COND ((LISTP MARKER) (* OR (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (PRIN1 "------------ ") (OR (CAR MARKER) '"")) (T (PRIN1 "--- overflow - ") MARKER]) (DOTABS [LAMBDA (LST) (* lmm%: 19 MAY 75 146) (COND ((NULL LST) NIL) (T (DOTABS (CDR LST)) (TAB (CAR LST) 0) (PRIN1 "|"]) (BELOWMARKER [LAMBDA NIL (* lmm "22-JUN-78 00:15") (* lmm%: 26 MAY 75 1751) (PROG1 [COND ((ILESSP BELOWCNT 26) (FCHARACTER (IPLUS 97 BELOWCNT))) (T (PACK* (FCHARACTER (IPLUS 97 (IREMAINDER BELOWCNT 26))) (IQUOTIENT BELOWCNT 26] (SETQ BELOWCNT (ADD1 BELOWCNT]) (MSPATHSPRINTFN [LAMBDA (FN) (* lmm "16-MAY-78 02:27") (AND MARKING (MSMEMBSET FN MARKING) (PRIN1 ">")) (PRIN2 FN) (ADD1 (POSITION]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING SEPARATE) (GLOBALVARS MSBLIP MSCRATCHASH) (NOLINKFNS . T)) ) (DEFINEQ (MSFIND [LAMBDA (IN X) (* lmm "24-JAN-79 15:16") (OR (EQ IN X) (AND (LISTP IN) (OR (MSFIND (CAR IN) X) (MSFIND (CDR IN) X]) (MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) (MSEDITE [LAMBDA ARGCOUNT (* ; "Edited 24-Oct-2018 16:25 by rmk:") (* ;  "Edited 22-Jun-93 12:14 by sybalsky:mv:envos") (* ;; "Edit something, NAME is arg 1, DEF-TO-EDIT is arg 2, FPTYPE is arg 3, TTYCOMS is args 4-n. Used when we have to fetch the definition above MSEDITF, e.g. for finding SHOW WHERE places, and it's a definer that copies when you getdef it.") (LET [(FNAME (ARG ARGCOUNT 1)) (FNDEF (ARG ARGCOUNT 2)) (FPTYPE (OR (ARG ARGCOUNT 3) 'FNS)) FPNAME (FEDITCOMS (for X from 4 to ARGCOUNT collect (ARG ARGCOUNT X] (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (COND ((EQ FPTYPE 'FNS) (APPLY 'EDITF (CONS FNAME FEDITCOMS))) (T (EDITE FNDEF FEDITCOMS FNAME FPNAME))) FPNAME]) (EDITGETDEF [LAMBDA (NAME TYPE) (* ;  "Edited 23-Jun-93 10:24 by sybalsky:mv:envos") (* ;; "This is meant to encapsulate the notion of asking the active editor, %"Are you editing the definition for this object? If so, give me the true definition you're editing%". Called from MSGETDEF to get the REALDEF for an object to be EDIT WHERE'd, so the editor == command works right.") (AND (EQ (EDITMODE) 'SEDIT:SEDIT) (bind SEDIT::WINDOW for SEDIT::CONTEXT in SEDIT::CONTEXTS when (AND NAME (CL:EQUAL NAME (fetch SEDIT::ICON-TITLE of SEDIT::CONTEXT)) (EQ TYPE (fetch SEDIT::EDIT-TYPE of SEDIT::CONTEXT))) do (* ;; "we found a context that matches, return it.") (RETURN (fetch CL:STRUCTURE of (SEDIT::SUBNODE 1 (fetch SEDIT::ROOT of SEDIT::CONTEXT]) ) (RPAQQ MSBLIP "sysout and inform Masinter@PARC") (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE." ) (RPAQ? MSFNTYPES '((FNS FNS GETDEF))) (* ; "SCRATCHASH") (RPAQ? MSCRATCHASH ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS SCRATCHASH MACRO [(ARRAYNAME . FORMS) ([LAMBDA (ARRAYNAME) (SETQ MSCRATCHASH) (PROG1 (PROGN . FORMS) (SETQ MSCRATCHASH ARRAYNAME] (COND (MSCRATCHASH (CLRHASH MSCRATCHASH) MSCRATCHASH) (T (HASHARRAY 20 (FUNCTION MSREHASH]) ) ) (* ; "marking changed") (DEFINEQ (MSMARKCHANGED [LAMBDA (NAME TYPE REASON) (* ; "Edited 8-Apr-88 10:17 by jrb:") (* ;; "Called from inside MARKASCHANGED") (* ;; "JRB - Some things need to be MARKASCHANGED strangely (FUNCTIONS that are actually DEFMACROS need to have CHANGEMACRO called, but not MSMARKCHANGE1, for instance). If there is a function in the MARKCHANGED-FN slot of the appropriate MSANALYZABLE record, and it returns non-NIL, MSMARKCHANGE1 gets called.") (AND MSDATABASELST (LET (ATYPEREC MSMCFN) (if (OR (NULL TYPE) (SETQ ATYPEREC (ASSOC TYPE MSFNTYPES))) then (COND ((EQ REASON 'DELETED) (MSERASE (LIST NAME))) ((OR (NOT (SETQ MSMCFN (fetch (MSANALYZABLE MARKCHANGED-FN) ATYPEREC))) (APPLY* MSMCFN NAME TYPE REASON)) (MSMARKCHANGE1 NAME 0))) (SELECTQ TYPE ((VARS VARIABLES T) (CHANGEVAR NAME TYPE REASON)) (MACROS (CHANGEMACRO NAME TYPE REASON)) (I.S.OPRS (CHANGEI.S. NAME TYPE REASON)) NIL]) (CHANGEMACRO [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:17 by jrb:") (* ;; "We don't do anything if the item is being defined. This is a heuristic that compensates for the fact that a database can be loaded from a file before the definitions that it knows about come in. We don't want a subsequent LOADFROM of a file to generate all sorts of probably spurious messages.") (AND MSDATABASELST (NEQ REASON 'DEFINED) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) (FILEPKGTYPE TYPE 'DESCRIPTION) (EQ (GETTEMPLATE NAME T) 'MACRO]) (CHANGEVAR [LAMBDA (NAME TYPE REASON) (* rmk%: "19-FEB-81 15:22") (DECLARE (GLOBALVARS COMPILE.TIME.CONSTANTS)) (AND MSDATABASELST (FMEMB NAME COMPILE.TIME.CONSTANTS) (MSNEEDUNSAVE (GETRELATION NAME '(USE FREELY) T) "constants"]) (CHANGEI.S. [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:18 by jrb:") (AND MSDATABASELST (SELECTQ REASON (DEFINED (* ;; "If it has a function definition, then defining it as an i.s.opr has no effect (at least for interpreted code)") (AND (NOT (GETD NAME)) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) '(i.s.oprs as functions) T))) ((CHANGED DELETED) (MSNEEDUNSAVE (UNION (GETRELATION NAME '(USE I.S.OPRS) T) (AND (U-CASEP NAME) (GETRELATION (L-CASE NAME) '(USE I.S.OPRS) T))) "i.s. oprs" T)) NIL]) (CHANGERECORD [LAMBDA (RNAME RFIELDS OLDFLG) (* ; "Edited 3-Jun-88 12:12 by jrb:") (AND MSDATABASELST OLDFLG (MSNEEDUNSAVE (PROG ((FNLIST (GETRELATION RNAME '(USE RECORDS) T))) (for F in RFIELDS do (SETQ FNLIST (UNION (GETRELATION F '(USE FIELDS) T) FNLIST))) (RETURN FNLIST)) "records" MSRECORDTRANFLG]) (MSNEEDUNSAVE [LAMBDA (FNS MSG MARKCHANGEFLG) (* rmk%: "22-MAY-81 13:23") (AND MARKCHANGEFLG (MSMARKCHANGE1 FNS)) (COND ((AND CHECKUNSAVEFLG (SETQ FNS (for FN inside FNS when (NOT (OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (FMEMB FN MSNEEDUNSAVE))) collect FN))) (COND ((EQ CHECKUNSAVEFLG '!) (UNSAVEFNS FNS)) (T (printout T "The functions " .PARA2 0 0 FNS " use " MSG " which have changed." T "Call UNSAVEFNS() to load and/or UNSAVEDEF them." T) (/SETATOMVAL 'MSNEEDUNSAVE (NCONC FNS MSNEEDUNSAVE]) (UNSAVEFNS [LAMBDA (FNS) (* ; "Edited 3-Jun-88 12:24 by jrb:") (OR FNS (SETQ FNS (APPEND MSNEEDUNSAVE))) (for FN in FNS when FN bind FNTYPE do [SETQ FNTYPE (for FNREC in MSFNTYPES when (HASDEF FN (fetch (MSANALYZABLE FILEPKGNAME) FNREC) '? '(NOERROR)) do (RETURN (fetch (MSANALYZABLE FILEPKGNAME) FNREC] [OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (PROG NIL (COND ((FGETD FN) (VIRGINFN FN T) (SAVEDEF FN))) (SELECTQ RECOMPILEDEFAULT (CHANGES (* don't mark as changed) (RESETVARS (MSDATABASELST) (* ASSERT%: ((REMOTE CALL)  MSMARKCHANGED)) (MARKASCHANGED FN FNTYPE))) (EXPRS (for FL in (WHEREIS FN FNTYPE FILELST) unless [OR (FMEMB FL NOTCOMPILEDFILES) (CDR (GETP FL 'FILE] do (/SETATOMVAL 'NOTCOMPILEDFILES (CONS FL NOTCOMPILEDFILES) ))) NIL) (COND ((HASDEF FN FNTYPE 'SAVED) (PRINTOUT T "unsaving " FN T) (UNSAVEDEF FN FNTYPE)) (T (PRINTOUT T "loading " FN T) (LOADDEF FN FNTYPE '?] (/SETATOMVAL 'MSNEEDUNSAVE (REMOVE FN MSNEEDUNSAVE))) (AND FNS (EQ RECOMPILEDEFAULT 'CHANGES) (printout T "WARNING: you must set RECOMPILEDEFAULT to EXPRS in order to have these functions recompiled automatically" T]) ) (ADDTOVAR COMPILE.TIME.CONSTANTS ) (RPAQQ RECORDCHANGEFN CHANGERECORD) (RPAQ? CHECKUNSAVEFLG T) (RPAQ? MSNEEDUNSAVE ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS GETWORDTYPE MACRO [(WORD TYPE) (CDR (FASSOC TYPE (GETHASH WORD MSWORDS]) ) ) (* ; "interactive routines") (RPAQ MASTERSCOPEDATE " 3-Mar-2021") (ADDTOVAR HISTORYCOMS %.) (DEFINEQ (%. [NLAMBDA MASTERSCOPECOMMAND (* lmm "16-MAY-78 01:07") (MASTERSCOPE MASTERSCOPECOMMAND]) (MASTERSCOPE [LAMBDA (MASTERSCOPECOMMAND TOPFLG) (* ; "Edited 5-Dec-86 06:08 by lmm") (* ;; "Top level entry. If given a sentence, parse it and return; otherwise, enter into USEREXEC-like loop") (COND (MASTERSCOPECOMMAND (MSINTERPRET (MKLIST MASTERSCOPECOMMAND) (NOT TOPFLG))) (T (PRINTOUT T "Type Masterscope commands to the exec using the . command, e.g." T ". WHO CALLS 'MASTERSCOPE" T]) (MASTERSCOPE1 [LAMBDA NIL (* ; "Edited 28-Jan-88 11:28 by jrb:") (* ;  "merged from smL Loops Masterscope by JRB") (printout T "Masterscope " MASTERSCOPEDATE T) (PROG (X (*PACKAGE* (CL:FIND-PACKAGE "IL"))) ERLP [ERSETQ (PROGN (PROMPTCHAR "_. " T LISPXHISTORY) (SELECTQ (SETQ X (LISPXREAD T T)) ((E _) (LISPX (LISPXREAD T T) '_)) ((OK STOP) (RETFROM (FUNCTION MASTERSCOPE1))) (LISPX X '_ NIL (FUNCTION MASTERSCOPEXEC] (GO ERLP]) (MASTERSCOPEXEC [LAMBDA (X LINE) (* ; "Edited 17-Jun-87 16:57 by jrb:") (* Called via the LISPX in  MASTERSCOPE) (* ;  "Merged from smL Loops Masterscope by JRB") (PROG (MASTERSCOPECOMMAND) (AND [OR [COND ((NULL LINE) (* Single entry on line) (OR (NOT (LITATOM X)) (OR (NEQ (EVALV X) 'NOBIND) (STRPOSL CLISPCHARRAY X] (AND (LITATOM X) (FGETD X) (LISTP LINE) (OR [COND ((NULL (CDR LINE)) (* "EDITF ] " OR SETQ  (A B) TYPE ENTRY) (OR (NULL (CAR LINE)) (LISTP (CAR LINE] (EQ (ARGTYPE X) 3] (RETURN)) (* If MASTERSCOPEXEC returns NIL, then LISPX will handle the event as a  normal typin) (SETQ MASTERSCOPECOMMAND (CONS X LINE)) (SELECTQ (CAR MASTERSCOPECOMMAND) ((OK STOP BYE ok stop) (RETFROM 'MASTERSCOPE1 NIL T)) NIL) LISPXVALUE [AND (LISTP LISPXHIST) (FRPLACA LISPXHIST (CONS '%. (CAR LISPXHIST] (* Make sure the event shows up with a %.  in it) (SETQ LISPXVALUE (MSINTERPRET MASTERSCOPECOMMAND)) (RETURN T]) ) (* ; "Interpreting commands") (DEFINEQ (MSINTERPRETSET [LAMBDA (SET OP ARG) (* ; "Edited 15-Aug-90 11:50 by jds") (* ;; "DECLARATIONS%%: (RECORDS SENTENCE MSSETPHRASE)")  (* ; "Edited 3-Jun-88 12:42 by jrb:") (PROG (TEM TYPE (REP (fetch (MSSETPHRASE REP) of SET))) START [COND [(NLISTP REP) (OR (NULL REP) (SHOULDNT (LIST REP TEM TYPE ARG))) [COND ((fetch (MSSETPHRASE TYPE) of SET) [replace (MSSETPHRASE REP) of SET with (create INRELATION HTABLES _ (for TYPE inside (fetch (MSSETPHRASE TYPE) of SET) join (GETVERBTABLES 'IS TYPE)) OSET _ (create MSSETPHRASE DET _ 'ANY] (RETURN (MSINTERPRETSET SET OP ARG] (RETURN (SELECTQ OP (CHECK ARG) (LIST MSBLIP) (HARD (LISTHARD SET)) (MEMB T) (SHOULDNT 8] (T (RETURN (SELECTQ (fetch (SENTENCE ID) of REP) (APPLY (SELECTQ OP (CHECK ARG) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (APPLY* (fetch (APPLY PRED) of REP) ARG)) (SHOULDNT 9))) (NOT (SELECTQ OP (CHECK (MSINTERPRETSET (fetch NEGATED of REP) 'CHECK ARG)) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (NOT (MSINTERPRETSET (fetch NEGATED of REP) 'MEMB ARG))) (SHOULDNT 10))) (INRELATION (SELECTQ OP (CHECK ARG) ((LIST HARD) (* ;; "got a list of dotted pairs of hash tables and another set; want to know the set of all things which have the given relation to any in the other set") (PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) V SET2VAL) (SETQ SET2VAL (MSINTERPRETSET OTHERSET 'LIST)) [COND [(EQ SET2VAL MSBLIP) (for R in HTABS do (MAPTABLE (COND (INVERTED (CDR R)) (T (CAR R))) (FUNCTION MSINTERPA] (T (for R in HTABS do (for X in SET2VAL do (SETQ V (UNION [GETTABLE X (COND (INVERTED (CAR R)) (T (CDR R] V] (RETURN V))) (MEMB [PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP))) (RETURN (find R in HTABS suchthat (find Z in [GETTABLE ARG (COND (INVERTED (CDR R)) (T (CAR R] suchthat (MSINTERPRETSET OTHERSET 'MEMB Z]) (SHOULDNT 11))) (GETHASH (SELECTQ OP (CHECK ARG) ((LIST HARD) (PROG (V) [for X in (fetch (GETHASH HTABLE) of REP) do (SETQ V (MSHASHLIST X V NIL (fetch (GETHASH BADMARKS) of REP] (RETURN V))) (MEMB [SOME (fetch (GETHASH HTABLE) of REP) (FUNCTION (LAMBDA (H) (AND (SETQ H (GETTABLE ARG H)) (NEQ H MSBLIP) (NOT (EQMEMB H (fetch (GETHASH BADMARKS) of REP]) (SHOULDNT 12))) (QUOTE (SELECTQ OP (CHECK (COND (ARG (SETQ NEEDUPDATE (UNION NEEDUPDATE (fetch QUOTED of REP))) NIL))) ((HARD LIST) (SETQ TYPE (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET))) (COND ([AND ARG (NEQ ARG 'FILES) (NEQ TYPE 'FILES) (FMEMB (SETQ TEM (fetch QUOTED of REP)) FILELST) (COND ((EQ ARG 'KNOWN) (NOT (OR (TESTRELQ KNOWN TEM) (GETD TEM] (replace (MSSETPHRASE TYPE) of SET with (COND ((EQ ARG 'KNOWN) 'FNS) (T ARG))) (SETQ TEM (for FILE in (fetch QUOTED of REP) join (ONFILE FILE ARG))) (printout T (fetch QUOTED of REP) " => ON " (fetch QUOTED of REP) T) (replace QUOTED of (fetch (MSSETPHRASE REP) of SET) with TEM)) (T (COND ([AND (EQ TYPE 'FNS) (GETP (fetch QUOTED of REP) 'CLISPWORD) (NOT (GETD (fetch QUOTED of REP] (printout T "Warning: " (fetch QUOTED of REP) "is a CLISP word and is not treated like a function!" T))) (fetch QUOTED of REP)))) (MEMB (FMEMB ARG (fetch QUOTED of REP))) (SHOULDNT 13))) (OR (* ;; "I.e. WHO ON MYFILE OR @ EXPRP CALL X --- if either of the sets need to be KNOWN and are 'vague' then the entire world needs to be updated") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((LIST HARD) [PROG (S1 S2) (RETURN (COND ((EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) OP))) MSBLIP) ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) (OR [EQ 'QUOTE (fetch (SENTENCE ID) of (fetch (MSSETPHRASE REP) of (fetch (CSET SET1) of REP] (replace (MSSETPHRASE REP) of (fetch (CSET SET1) of REP) with (create QUOTE QUOTED _ S1))) MSBLIP) (T (UNION S1 S2]) (MEMB (OR (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 14))) (AND (* ; "I.e. WHO ON MYFILE AND @ EXPRP CALL Z -- only if both sets are vague does the world need updating") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((HARD LIST) [PROG (S1 S2) (RETURN (COND [[EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) 'LIST] (COND ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) MSBLIP) (T (SUBSET S2 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB X] (T (SUBSET S1 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB X]) (MEMB (AND (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 15))) (ANDNOT (replace (SENTENCE ID) of REP with 'AND) [replace (MSSETPHRASE REP) of (fetch SET2 of REP) with (create NOT NEGATED _ (create MSSETPHRASE using (fetch SET2 of REP) REP _ (fetch (MSSETPHRASE REP) of (fetch SET2 of REP] (GO RETRY)) (IN [SETQ REP (create QUOTE QUOTED _ (MKLIST (CL:EVAL (fetch (IN EXPRESSION) of REP] (GO RETRY)) (BLOCKS (* ; "Block set") (SELECTQ OP (CHECK [[LAMBDA (X Y) (OR X Y] (AND (fetch FNS of REP) (MSINTERPRETSET (fetch FNS of REP) 'CHECK)) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'CHECK]) (PROGN [SETQ REP (create QUOTE QUOTED _ (MSGETBLOCKDEC (fetch TYPES of REP) (fetch FNS of REP) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'HARD] (GO RETRY)))) (FIELDS (SELECTQ OP (CHECK (MSINTERPRETSET (fetch RECS of REP) OP)) (PROGN [SETQ REP (create QUOTE QUOTED _ (PROG (VAL) (for X in (MSLISTSET (fetch RECS of REP) T) do (SETQ VAL (UNION (RECORDFIELDNAMES X) VAL))) (RETURN VAL] (GO RETRY)))) (THAT (PROG (TABLES (MSVERB (fetch (THAT MSVERB) of REP)) VALUE (OS (fetch (THAT OTHERSET) of REP))) (SELECTQ (fetch (MSVERB ROOT) of MSVERB) ((AND OR ANDNOT) [SETQ REP (create CSET ID _ (fetch (CVERB C) of (fetch VPART of MSVERB)) SET1 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB1) of (fetch VPART of MSVERB))) OTHERSET _ OS)) SET2 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB2) of (fetch VPART of MSVERB))) OTHERSET _ OS] (GO RETRY)) (CALL (COND ((EQ (fetch (MSVERB MODIFIER) of MSVERB) 'SOMEHOW) [SETQ REP (create PATHS MSPATHOPTIONS _ (COND ((EQ (fetch TENSE of MSVERB) 'ED) (create PATHOPTIONS FROM _ OS TO _ (create MSSETPHRASE) TOPFLG _ T)) (T (create PATHOPTIONS TO _ OS TOPFLG _ T] (GO RETRY)))) (CONTAIN (COND ((EQ (fetch DET of OS) 'WHICH) (SHOULDNT 16))) (* ;; "JRB - Default types on files are now ignored - removed (|fetch| (MSSETPHRASE DEFAULTTYPE) |of| SET) from ORs below.") [SETQ REP (create QUOTE QUOTED _ (SELECTQ (fetch TENSE of MSVERB) (ED (ONFILE (MSINTERPRETSET OS 'HARD) (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of SET) 'ALL))) (ONFILE NIL (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of OS) 'ALL) (OR (MSINTERPRETSET OS 'HARD) T] (GO RETRY)) NIL) (SELECTQ OP (CHECK (SETQ VALUE (MSINTERPRETSET OS 'CHECK (fetch KNOWN of OS)))) NIL) (SETQ TABLES (GETVERBTABLES (fetch (MSVERB ROOT) of MSVERB ) (fetch (MSVERB MODIFIER) of MSVERB))) (replace REP of SET with (SETQ REP (create INRELATION INVERTED _ (EQ (fetch TENSE of MSVERB) 'ED) HTABLES _ TABLES OSET _ OS))) OUT (RETURN (OR (MSINTERPRETSET SET OP ARG) VALUE)))) (PATHS (COND ((EQ OP 'CHECK) (CHECKPATHS (fetch MSPATHOPTIONS of REP))) (T (SETQ REP (create GETHASH HTABLE _ (LIST (MSONPATH REP)) BADMARKS _ T)) (GO RETRY)))) (SHOULDNT 17] RETRY (replace REP of SET with REP) (GO START]) (MSINTERPA [LAMBDA (VAL KEY) (* DECLARATIONS%: (RECORDS SETPHRASE)) (* ; "Edited 12-Jan-87 01:20 by jds") (AND (NOT (FMEMB KEY V)) [COND ((AND (NULL (fetch (MSSETPHRASE TYPE) of OTHERSET)) (NULL (fetch REP of OTHERSET))) VAL) (T (find Z in VAL suchthat (MSINTERPRETSET OTHERSET 'MEMB Z] (SETQ V (CONS KEY V]) (MSGETBLOCKDEC [LAMBDA (TYPE FNSET FILES) (* lmm "24-FEB-79 20:50") (PROG (VAL) [for FILE inside (OR FILES FILELST) do ([for BLOCK in (FILECOMSLST FILE 'BLOCKS) when [OR (NULL FNSET) (SOME BLOCK (FUNCTION (LAMBDA (FILE) (AND (LITATOM FILE) (MSMEMBSET FILE FNSET] do ([SELECTQ TYPE ((BLKFNS BLOCK NIL) (for FILE in (CDR BLOCK) when (AND (LITATOM FILE) (NOT (FMEMB FILE VAL))) do (SETQ VAL (CONS FILE VAL)))) (for Y in BLOCK when (AND (LISTP Y) (EQMEMB (CAR Y) TYPE)) do (SETQ VAL (UNION (COND ((EQ (CADR Y) '*) (EVAL (CADDR Y))) (T (CDR Y))) VAL] (COND ((AND (EQ TYPE 'ENTRIES) (CAR BLOCK) (FMEMB (CAR BLOCK) (CDR BLOCK)) (NOT (FMEMB (CAR BLOCK) VAL))) (SETQ VAL (CONS (CAR BLOCK) VAL] (OR FNSET (SETQ VAL (UNION (FILECOMSLST FILE (SELECTQ TYPE (BLKFNS 'FNS) TYPE)) VAL] (RETURN VAL]) (LISTHARD [LAMBDA (SET) (* DECLARATIONS%: (RECORDS  MSSETPHRASE)) (* ; "Edited 12-Jan-87 00:59 by jds") (PROG (VAL) [for TYPE inside (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET)) do (for TABLE in (GETVERBTABLES 'IS (COND ((AND (EQ TYPE 'FNS) (fetch (MSSETPHRASE KNOWN) of SET)) 'KNOWN) (T TYPE))) do (SETQ VAL (MSHASHLIST (CAR TABLE) VAL SET] (RETURN VAL]) (MSMEMBSET [LAMBDA (ITEM SET) (* lmm%: 25-JAN-76 2 20) (MSINTERPRETSET SET 'MEMB ITEM]) (MSLISTSET [LAMBDA (SET TRYHARD TYPE) (* lmm " 8-JUL-78 02:11") (* Interpret set as List -  return list of elements in set S, or MSBLIP if can't) (MSINTERPRETSET SET (COND (TRYHARD 'HARD) (T 'LIST)) TYPE]) (MSHASHLIST [LAMBDA (HTABLE PREVVALUE OTHERSET BADMARKS) (* lmm " 8-AUG-77 15:17") (MAPTABLE HTABLE (FUNCTION MSHASHLIST1)) PREVVALUE]) (MSHASHLIST1 [LAMBDA (VAL KEY) (* lmm " 8-AUG-77 15:16") (AND (NEQ VAL MSBLIP) (NOT (EQMEMB VAL BADMARKS)) (NOT (FMEMB KEY PREVVALUE)) (OR (NULL OTHERSET) (MSMEMBSET KEY OTHERSET)) (SETQ PREVVALUE (CONS KEY PREVVALUE]) (CHECKPATHS [LAMBDA (OPTIONS VAL) (* lmm "20-DEC-78 20:03") (PROG (VAL) (for PR in OPTIONS when (FMEMB (CAR PR) '(FROM TO AVOIDING NOTRACE MARKING SEPARATE)) do (AND (MSINTERPRETSET (CDR PR) 'CHECK (EQ (CAR PR) 'FROM)) (SETQ VAL T))) (RETURN (OR VAL (NULL (FASSOC 'FROM OPTIONS]) (ONFILE [LAMBDA (FILES TYPES FINDITEMS) (* ; "Edited 2-Jun-88 11:19 by jrb:") (* ;  "MSHASHFILE uses cause GETRELATION barfs if CONTAINS table doesn't exist.") (PROG (VAL) (* ;; "JRB - TYPES of 'ALL means gather all types Masterscope knows about") [AND (EQ TYPES 'ALL) (SETQ TYPES (for FT in MSFNTYPES collect (fetch (MSANALYZABLE FILEPKGNAME) of FT] [for FILE (FNSONLY _ (AND MSHASHFILE (SELECTQ (COND ((AND (LISTP TYPES) (NULL (CDR TYPES)) (CAR TYPES))) (T TYPES)) ((FNS KNOWN NIL) T) NIL))) inside (OR FILES FILELST) do (* ;  "Don't notice the file if we only care about FNS and the file is known to the database.") (COND [(AND FNSONLY (NOT (MEMB FILE FILELST)) (GETRELATION FILE 'CONTAINS] (T (MSNOTICEFILE FILE))) (for TYPE inside TYPES do (SETQ TYPE (SELECTQ TYPE ((FNS KNOWN NIL) 'FNS) TYPE)) (COND [FINDITEMS (OR (FMEMB FILE VAL) (AND (find X inside FINDITEMS suchthat (INFILECOMS? X TYPE (FILECOMS FILE))) (SETQ VAL (CONS FILE VAL] (T (SETQ VAL (UNION (FILECOMSLST FILE TYPE) VAL] [COND ((AND MSHASHFILE (NULL VAL) (find TYPE inside TYPES suchthat (SELECTQ TYPE ((FNS KNOWN NIL) T) NIL))) (* ;  "Didn't find it in core; perhaps the CONTAINS table knows") (COND [FILES (for FILE inside FILES do (COND (FINDITEMS (for X inside FINDITEMS when (TESTRELATION X 'CONTAINS FILE T) do (pushnew VAL FILE))) (T (SETQ VAL (UNION (GETRELATION FILE 'CONTAINS) VAL] (FINDITEMS (* ;; "No files: should use all known files, but that information isn't explicitly kept by MSHASH. Soooo, we'll only do the case where FINDITEMS is given") (for X inside FINDITEMS do (SETQ VAL (UNION (GETRELATION X 'CONTAINS T) VAL] (RETURN VAL]) ) (DEFINEQ (MSINTERPRET [LAMBDA (COMMAND SUBROUTINE) (* ; "Edited 15-Aug-90 11:54 by jds") (RESETLST [PROG (VAL EDITQUIETFLG) (SELECTQ (CAR COMMAND) ((; * -) (RETURN)) NIL) (SETQ VAL (MSPARSE COMMAND)) (COND ((EQ MSPRINTFLG T) (PRINT VAL T))) (COND ((EQ (CAR VAL) 'OUTPUT) (MSOUTPUT (CADR VAL)) (SETQ VAL (CDDR VAL)) (MAPRINT COMMAND NIL ". " " "))) (* ;; "Now to interpret") [COND ((AND (EQ (CAR VAL) 'ERASE) (NULL (CDR VAL))) (MSERASE T) (RETURN 'ok] (MSINIT) (RETURN (SELECTQ (fetch (SENTENCE ID) of VAL) (REANALYZE (* ;  "Definitly don't want to CHECKFORCHANGED before the ANALYZE is done") (* ;; "From Lanning's Loops changes for Masterscope...") (* ;;  "(MAPC (MSLISTSET (CDR VAL) T 'KNOWN) (FUNCTION (LAMBDA (X) (UPDATEFN X T)))) (CL:VALUES)") (* ;; "JRB - The MSANALYZEFNS hashtable hook is hereby flushed.") (LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of (CDR VAL))) ((fetch (MSSETPHRASE DEFAULTTYPE) of (CDR VAL] (SET (MSLISTSET (CDR VAL) T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (if [AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] then (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!) else (for X in SET do (UPDATEFN X T)) (CL:VALUES)))) (ANALYZE (CHECKFORCHANGED (SETQ VAL (CDR VAL))) (* ;; "From Lanning's Loops changes for Masterscope...") (* ;; "(COND ((EQ (SETQ VAL (MSLISTSET VAL NIL 'KNOWN)) MSBLIP) (|printout| T %"Sorry, can't figure out which functions you mean.%" T) (ERROR!))) (MAPC VAL (FUNCTION UPDATEFN)) (CL:VALUES)") [LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of VAL)) ((fetch (MSSETPHRASE DEFAULTTYPE) of VAL] (SET (MSLISTSET VAL T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (COND ([AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!)) ((EQ SET MSBLIP) (PRINTOUT T "Sorry, can't figure out which items you mean. " T) (ERROR!)) (T (for X in SET do (UPDATEFN X T NIL SETTYPE)) (CL:VALUES]) ((EDIT SHOW) [PROG (DONE NEEDUPDATE UPDATEALL TYPE (EDIT (fetch (SENTENCE ID) of VAL)) REL SHOWSET (EDITCOMS (fetch OTHERSTUFF of VAL)) (SUBJECT (fetch (SENTENCE SUBJECT) of VAL)) (MSPRED (fetch (SENTENCE MSPRED) of VAL)) REP) (DECLARE (SPECVARS TYPE SHOWSET EDIT EDITCOMS DONE)) [COND ((NULL MSPRED) (* ;  "EDIT ANY CALLING FOO -- just call EDITFNS") (CHECKFORCHANGED SUBJECT) (RETURN (MAPC (MSLISTSET SUBJECT T) (FUNCTION (LAMBDA (FN) (PRIN2 FN T) (PRIN1 " : " T) (OR (NLSETQ (PRINT (APPLY 'MSEDITF (CONS FN EDITCOMS) ) T)) (PRINT "failed" T] [SETQ REL (fetch (THAT MSVERB) of (SETQ REP (fetch (MSSETPHRASE REP) of MSPRED] (SETQ SHOWSET (fetch (THAT OTHERSET) of REP)) [COND ((EQ (fetch TENSE of REL) 'ED) (replace TENSE of REL with 'S) (SETQ MSPRED (create MSSETPHRASE REP _ (create THAT MSVERB _ REL OTHERSET _ (SETQ SHOWSET (PROG1 SUBJECT (SETQ SUBJECT SHOWSET] (SETQ TYPE (VERBNOTICELIST (fetch VPART of REL))) (SETQ UPDATEALL (MSINTERPRETSET SUBJECT 'CHECK T)) [for FN in NEEDUPDATE do (COND ((GETHASH FN MSCHANGEDARRAY) (MSSHOWUSE FN TYPE SHOWSET EDIT NIL EDITCOMS) (SETQ DONE (CONS FN DONE))) (T (UPDATEFN FN] (COND (UPDATEALL [MAPHASH MSCHANGEDARRAY (FUNCTION (LAMBDA (VAL KEY) (AND (OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ((MSSHOWUSE KEY TYPE SHOWSET EDIT 'CHANGED EDITCOMS) (SETQ DONE (CONS KEY DONE] (MSCHECKEMPTY))) (MAPC (MSLISTSET (MSJOINSET 'AND MSPRED SUBJECT) T) (FUNCTION (LAMBDA (AT) (AND (NOT (FMEMB AT DONE)) (MSSHOWUSE AT TYPE SHOWSET EDIT NIL EDITCOMS ] (CL:VALUES)) (? [CHECKFORCHANGED (SETQ VAL (MSJOINSET 'AND (fetch MSPRED of VAL) (fetch SUBJECT of VAL] (OR SUBROUTINE (TAB 0 0)) (MSSOLVE VAL)) (PATHS (PROG ([INVERTED (for X on (CDR VAL) bind FROMFOUND do (SELECTQ (CAAR X) (FROM (SETQ FROMFOUND T)) (TO (RETURN (NOT FROMFOUND))) NIL) finally (RETURN (COND (FROMFOUND NIL) (T (FRPLACD VAL (CONS [CONS 'FROM (create MSSETPHRASE REP _ (create THAT MSVERB _ (create MSVERB ROOT _ 'IS MODIFIER _ 'KNOWN) OTHERSET _ (create MSSETPHRASE] (CDR VAL))) NIL] NEEDUPDATE UPDATEALL TEM) (SETQ UPDATEALL (CHECKPATHS (fetch MSPATHOPTIONS of VAL))) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY))) (COND ((SETQ TEM (fetch (PATHOPTIONS OUTPUT) of (CDR VAL))) (MSOUTPUT TEM))) (AND (SETQ TEM (fetch (PATHOPTIONS LINELENGTH) of (CDR VAL))) (RESETSAVE (LINELENGTH TEM))) (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") [SETQ MSTHOSE (MSPATHS [COND (INVERTED (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL] [COND (INVERTED (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL] INVERTED (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS SEPARATE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS MARKING) of (fetch MSPATHOPTIONS of VAL] (RETURN (CL:VALUES)))) (ERASE (* ;  "case of plain ERASE taken care of earlier") (MSERASE (MSLISTSET (CDR VAL) T 'KNOWN)) (PRIN1 "Erased." T) (CL:VALUES)) (DESCRIBE (CHECKFORCHANGED (CDR VAL) NIL T) (* ;  "Need to update the world since will print out CALLED BY:") (TAB 0 0) (MAPC (MSLISTSET (CDR VAL) T) (FUNCTION MSDESCRIBE))) (FOR (CHECKFORCHANGED (CADDDR VAL)) (FRPLACA (CDDDR VAL) (KWOTE (MSLISTSET (CADDDR VAL) T))) (EVAL VAL)) (CHECK (CHECKFORCHANGED (CDR VAL)) [MSCHECKBLOCKS (AND (CDR VAL) (MSLISTSET (CDR VAL) 'HARD 'FILES]) (SHOULDNT 18])]) (VERBNOTICELIST [LAMBDA (VPART) (* ; "Edited 12-Jun-87 16:37 by jrb:") (* ;;; " NOTE: The call to MSVBTABLES used to be a call to the macro MSVBNOTICED. The macro, however, existed only on the file MSANALYZE. Further, there was an EXPR definintion for the fn MSVBNOTICED, but BvM could find no reference to it in any file. What is going on? - smL") (COND [(type? CVERB VPART) (UNION (VERBNOTICELIST (fetch (CVERB VB1) of VPART)) (VERBNOTICELIST (fetch (CVERB VB2) of VPART] (T (OR (MSVBTABLES (fetch (VPART ROOT) of VPART) (fetch (VPART MODIFIER) of VPART)) (PROGN (printout T "can't SHOW or EDIT where things " (fetch (VPART ROOT) of VPART) %, (OR (fetch (VPART MODIFIER) of VPART) "") "!" T) (ERROR!]) (MSOUTPUT (LAMBDA (FILE) (* ; "Edited 12-Jun-90 20:43 by teruuchi") (* ;; "OUTPUT is already RESETSAVE'd") (COND ((OPENP FILE (QUOTE OUTPUT)) (OUTPUT FILE)) (T (OUTFILE FILE) (SETQ FILE (OUTPUT)) (RESETSAVE NIL (LIST (QUOTE CLOSEF) FILE)))) (* ;; "output to file, reset LINELENGTH") (LINELENGTH FILELINELENGTH)) ) (MSCHECKEMPTY [LAMBDA NIL (* lmm "20-JAN-79 14:08") (PROG (Q CF) (COND (MSDBEMPTY (printout T "No functions have been analyzed!" T) (UPDATEFILES) (SETQ CF (FILEPKGCHANGES 'FNS)) [COND ((AND [SETQ Q (APPEND (AND FILELST (LIST 'ON '%' FILELST)) (AND CF FILELST '(OR)) (AND CF (LIST 'IN '%' CF] (EQ [ASKUSER (AND (FIXP DWIMWAIT) (ITIMES 10 DWIMWAIT)) '(Y) (CONS "want to ." (SETQ Q (APPEND '(ANALYZE THE FNS) Q))) '((Y "es ") (N "o "] 'Y)) (MASTERSCOPE Q) (COND (MSDBEMPTY (printout T "Sorry, no functions were found to analyze!" T)) (T (RETURN] (ERROR!]) (CHECKFORCHANGED [LAMBDA (SET NOTTHISONE UPDATEALL) (* lmm "25-JUN-78 01:03") (PROG (NEEDUPDATE) (SETQ UPDATEALL (OR (MSINTERPRETSET SET 'CHECK (AND (NOT NOTTHISONE) (fetch KNOWN of SET))) UPDATEALL)) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY]) (MSSOLVE [LAMBDA (SET) (* ; "Edited 15-Aug-90 11:52 by jds") (SETQ MSTHOSE (MSLISTSET SET T)) (PROG (ND QT OSET REP) (SETQ REP (fetch REP of SET)) [OR (SELECTQ (fetch (SENTENCE ID) of REP) (AND (SETQ ND (fetch SET2 of REP)) (AND (EQ [fetch (SENTENCE ID) of (SETQ REP (fetch REP of (fetch SET1 of REP] 'INRELATION) (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH))) (INRELATION (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH)) NIL) (RETURN (COND ((EQ (fetch (MSSETPHRASE DET) of SET) 'WHICH) (* ; "Edited by TT (29-May-1990)") (if (EQ (OUTPUT) T) then MSTHOSE else (PRINT MSTHOSE) (CL:VALUES))) (T (if (EQ (OUTPUT) T) then (NOT (NULL MSTHOSE)) else (PRINT (NOT (NULL MSTHOSE))) (CL:VALUES] (replace REP of SET with REP) (replace (INRELATION INVERTED) of REP with (NOT (fetch (INRELATION INVERTED ) of REP))) [replace (INRELATION OSET) of REP with (create MSSETPHRASE REP _ (create QUOTE QUOTED _ (SETQ QT (LIST NIL] [MAPC MSTHOSE (FUNCTION (LAMBDA (FN) (PRIN2 FN) (PRIN1 " -- ") (FRPLACA QT FN) (PRINT (SUBSET (MSLISTSET SET T) (FUNCTION (LAMBDA (X) (MSMEMBSET X OSET] (RETURN (CL:VALUES]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD GETHASH (ID HTABLE . BADMARKS) ID _ 'GETHASH) (RECORD INRELATION (ID (INVERTED . HTABLES) . OSET) ID _ 'INRELATION) (ASSOCRECORD PATHOPTIONS (TO FROM AVOIDING SEPARATE NOTRACE TOPFLG OUTPUT LINELENGTH MARKING) (* CHECKPATHS assumes that this is  an ASSOCRECORD) ) (RECORD MSANALYZABLE (FILEPKGNAME SETNAME GETDEF-FN MARKCHANGED-FN)) ) ) (FILESLOAD MSCOMMON) (DECLARE%: DONTCOPY (RPAQQ MSCOMPILETIME [[P (MAPC '(GETRELQ TESTRELQ SCRATCHASH) (FUNCTION (LAMBDA (X) (PUTHASH X 'MACRO USERTEMPLATES] (BLOCKS (NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) (MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) (NOLINKFNS . T)) (MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (RETFNS MASTERSCOPE1) (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) (NOLINKFNS . T))) (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) (DECLARE%: EVAL@COMPILE (FILES (LOADCOMP) SEDIT-DECLS MSPARSE) (P (CLISPDEC 'FAST]) [MAPC '(GETRELQ TESTRELQ SCRATCHASH) (FUNCTION (LAMBDA (X) (PUTHASH X 'MACRO USERTEMPLATES] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) (BLOCK%: MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) (NOLINKFNS . T)) (BLOCK%: MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (RETFNS MASTERSCOPE1) (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) (NOLINKFNS . T)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) ) (DECLARE%: EVAL@COMPILE (FILESLOAD (LOADCOMP) SEDIT-DECLS MSPARSE) (CLISPDEC 'FAST) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA %.) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MSEDITE MSEDITF MSEDITF) ) (PUTPROPS MASTERSCOPE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1993 1994 2018 2020 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3433 20204 (UPDATEFN 3443 . 5060) (MSEDITF 5062 . 6062) (MSGETDEF 6064 . 7470) ( MSNOTICEFILE 7472 . 9865) (MSSHOWUSE 9867 . 15370) (MSUPDATEFN1 15372 . 16060) (MSUPDATE 16062 . 18488 ) (MSNLAMBDACHECK 18490 . 19372) (MSCOLLECTDATA 19374 . 20202)) (20205 21104 (UPDATECHANGED 20215 . 20578) (UPDATECHANGED1 20580 . 21102)) (21678 22101 (MSCLOSEFILES 21688 . 22099)) (22782 27214 ( MSDESCRIBE 22792 . 25580) (MSDESCRIBE1 25582 . 26645) (FMAPRINT 26647 . 27212)) (27307 27747 ( MSPRINTHELPFILE 27317 . 27745)) (27797 30935 (TEMPLATE 27807 . 29228) (GETTEMPLATE 29230 . 29365) ( SETTEMPLATE 29367 . 30933)) (31805 36729 (ADDTEMPLATEWORD 31815 . 32487) (MSADDANALYZE 32489 . 33987) (MSADDMODIFIER 33989 . 35070) (MSADDRELATION 35072 . 35819) (MSADDTYPE 35821 . 36727)) (38230 43451 ( MSMARKCHANGE1 38240 . 39034) (MSINIT 39036 . 40217) (GETVERBTABLES 40219 . 40772) (MSSTOREDATA 40774 . 42453) (STORETABLE 42455 . 43449)) (44852 49922 (PARSERELATION 44862 . 45462) (PARSERELATION1 45464 . 46919) (GETRELATION 46921 . 47950) (MAPRELATION 47952 . 49086) (TESTRELATION 49088 . 49920)) (49923 51563 (ADDHASH 49933 . 50411) (SUBHASH 50413 . 50641) (MAKEHASH 50643 . 50787) (MSREHASH 50789 . 51242) (EQMEMBHASH 51244 . 51561)) (51902 58117 (MSVBTABLES 51912 . 57691) (MSUSERVBTABLES 57693 . 58115)) (58200 60411 (BUILDGETRELQ 58210 . 59316) (BUILDTESTRELQ 59318 . 60409)) (60582 60970 (MSERASE 60592 . 60968)) (60971 64203 (DUMPDATABASE 60981 . 62318) (DUMPDATABASE1 62320 . 62665) (READATABASE 62667 . 64201)) (65285 94344 (MSCHECKBLOCKS 65295 . 69115) (MSCHECKBLOCK 69117 . 77737) ( MSCHECKFNINBLOCK 77739 . 80739) (MSCHECKBLOCKBASIC 80741 . 83161) (MSCHECKBOUNDFREE 83163 . 85062) ( GLOBALVARP 85064 . 85231) (PRINTERROR 85233 . 88449) (MSCHECKVARS1 88451 . 91404) (UNECCSPEC 91406 . 91684) (NECCSPEC 91686 . 92033) (SPECVARP 92035 . 92562) (SHORTLST 92564 . 93020) (DOERROR 93022 . 93732) (MSMSGPRINT 93734 . 94342)) (95488 110316 (MSPATHS 95498 . 98900) (MSPATHS1 98902 . 103137) ( MSPATHS2 103139 . 106549) (MSONPATH 106551 . 107779) (MSPATHS4 107781 . 108863) (DASHES 108865 . 109391) (DOTABS 109393 . 109634) (BELOWMARKER 109636 . 110099) (MSPATHSPRINTFN 110101 . 110314)) ( 110702 114126 (MSFIND 110712 . 110987) (MSEDITF 110989 . 111989) (MSEDITE 111991 . 113028) (EDITGETDEF 113030 . 114124)) (115132 123733 (MSMARKCHANGED 115142 . 116866) (CHANGEMACRO 116868 . 117573) ( CHANGEVAR 117575 . 117891) (CHANGEI.S. 117893 . 119226) (CHANGERECORD 119228 . 120099) (MSNEEDUNSAVE 120101 . 121093) (UNSAVEFNS 121095 . 123731)) (124174 127664 (%. 124184 . 124324) (MASTERSCOPE 124326 . 124852) (MASTERSCOPE1 124854 . 125722) (MASTERSCOPEXEC 125724 . 127662)) (127703 165362 ( MSINTERPRETSET 127713 . 155206) (MSINTERPA 155208 . 155742) (MSGETBLOCKDEC 155744 . 158257) (LISTHARD 158259 . 159477) (MSMEMBSET 159479 . 159624) (MSLISTSET 159626 . 159991) (MSHASHLIST 159993 . 160160) (MSHASHLIST1 160162 . 160488) (CHECKPATHS 160490 . 161130) (ONFILE 161132 . 165360)) (165363 188529 ( MSINTERPRET 165373 . 182226) (VERBNOTICELIST 182228 . 183338) (MSOUTPUT 183340 . 183657) (MSCHECKEMPTY 183659 . 184863) (CHECKFORCHANGED 184865 . 185385) (MSSOLVE 185387 . 188527))))) STOP \ No newline at end of file diff --git a/library/MASTERSCOPE.DFASL b/library/MASTERSCOPE.DFASL index 9e2378f8078fde74121fd43c4fb7e1d426f2c676..d1d5645b246970a6fc517434b481c0c26b3e2075 100644 GIT binary patch delta 12504 zcma)id0ds%_V=^*^E~H(2r`2Ra=-}{j6o1*4)bu}Am9KFh>C(B7;2f?J>s=)Dps%@ z&auo)O*2d2SWX#PH`C0zL;3SfZ#iUPT57|s+r9VayVu$WPuIr%s^`^LKLS^J1GG`Fd`YH9U6lPM{#u&OC8F+MTD6hC@QeCn9wRPStaspYq9Q>*7SR4EK z$s`KQtubMdSW`m$m_$)*bjQU%dXD^mRkpchwfBNQ~tUT-JXWzosC<+@7 zn%Bmtz3B@S@!feYtr6o|FATfd6J6xaq0kjP1O~O@Z}5mT>0v3GgsU_tXKEX~L@7v*GSnoCN|D8_8+K`ZiKf5*-&In&nwEr{*e{c^P-U9pmU>7CRgJ}rZ_+L-KeQNCjsUMz0aBK95sKgTBCuCS!|K-pV0CnuHYu0QfbG$#>?E{~2!I>W zqu8GzYCurm)7S&HMg+=1`%^8N#avp3iB_-xA*Ipzc*-yX zdmB2&?d5&bVe0q7=f->XwYPW{Sxe1Rva&5X)YzqFU6fId!J+ZV>>zwSemq;` zjF}M3*h-i<@t26!A)+Imh30}R(l910#M^u*YK19jQ9~h4_Bu#Lico~e!|hvmO`5qT zEbK_`&i15SArU*$;@CMjmu62+Al}dW6KAV0rH=9;7_(j>GU};Fm0DHlf^Fu`pmGwT zu6%y1{kEd&RKaGLou0`K!JhPytQ9^@PxaU}iZXUVSjKL40J<{L*)(98i`iyq%FMI9 zNVzHwoPHl~MYvIn)MJLZxHzjQGx1?$Q9hqToULV)Iy#1;FAbQrLvX8;Nee4$1?J|` zM~V5+LX23i=`xaCbSlbr`xYf~wkWBa+s3S5ZK0hsJ(hXoAW}Bjj@H!X?eBGqwROHFr3NH^ni(!=z^evOjZCD1txf; zV5rBR6(p-6u)kn*uWp`*DW!Wbd{c1O<5US1IR;-^5^Qfr%Pjg4%2%Y>co(WAy`acC zwW#OM9J6onSdeDsjMlgxQ_|8!LfSbq=bicKevIYqHhL=Uee+m_A5#kiH^l;1m!e6mj_#5q)YkU>1i}qOs*X(UAfrADPEHoF#W#^TYmc^A$ zPPgQh(l25`T%|!qb4Kw1xLlYp_LxD8+o7Ur1&zjbo^nax)WL)Y5&crLR*rywoJ7%I zz*4k6;%!of90n4tE1X!rrs?5b&hLxL7>je}7Vl(iDttXDMvFt07F05X{RPICO!pW^ z{N0K0d`Uz%hAncnhswcF;)GtatT?`3d(s?tYO1p!<2sPUD!LNj=!rx zO-4AxPt{{+sLG{gbtv-j^Bz=*KUzJ#$Xt?Bs<3GL7OengP92j_ajevwFQo&8a$B0 zRer$=_y;g#dW3Nob^IMDm>wC~pWI2IRBL>NQY~kBuJzZI%a63*RNw&?0z0M~jR92t zGk9hC*a9-8{4YJa;|yhe>`Jmjlsw;)`=5Gnhvt0b(UcwK|E6K_zvy>xGF>z*sRy8`#i3E~A_AWv>$Dazwe?m5P z4&fat@i$mlWeTCZwi;i=>v z1`;Dd5_T0WJCnkMQ2Ch{2;L?5DJ0Ad>z#~we<4CLOr2{A8H9xGNMMg4+(LO5;K{l1 z>>_l{J!niON|JNgym;PAIF7QBWH>l~g)x`%vYqh@1~bo(T|)c`RMtcodw$vPYo7OL zlghmfhSw%}-nMTc)3z5D)DAQ*5N@?l$k1BbFQRaJVeOsPnkNdAd|PYQ)UK{^kgOL9 z>%O`W&eRTOTi{M@e_zzmVq;)&Y2g9Te_;&2ZGf(dAegz(x4hdEM*=jc?POwE^E^x` z-Q|v?bWz$Mc5bECjPXe1S4N@VmywxS5=%wacw_wo2PX8ap*z9?Vd21_$tB>e)v(*Pi)kU*SP*GPYaSxX`NR&krmVwlM#|NLJrP4!QB zy}|64q0*|*(q&nN!^wdG(62Fz{R^rZFNko=;+&LY*vMnZqD`_JUYX6cPGVG$7&82b9Rec?ERFYMVoKdaPS4wPf zcAh1R#v>eo5NteLbiW@gek>S#9`>|Rd96)kuPJXbUqgm2M?Z|nBD38H*T~W&BI;|CWGd6qKN1m(@S>3LU4)?oZy=kh^*f>dpYT>@vb!{;x zW1}tM(gAJbQXM`d4X^e)PV=EX%6k$2a_&j-Do%z}TfwEraF}wB^#}*B({nGL+)l1})9WA+cCOK~?5KwMpm$7n-9Y z{v{^cBeNuHN>&N&`;0%_XEt7k;5AXXpCf_f#JJj>w~QcaN+W3%gQ_Msb|al=0n#J+3o zZuo4H8$aQOvxGN4j6iE>TUS&_e17=M%;8xbHNSW-B8`#P-Qo; zZS}SLji@`_aHAX2zoV&8%b|R2WJr-aZxlkAXM(5Jno_06?-Nvh5A$d)IQ={csbvXY zbu(;&uhvG*TR;`#2&BJCv&W?=A}YA) zr`I8rR2n4>UndEb)B<9_Vd%+jUg`wHF>7z!r)q~0veQW2C*VX`v9^oIXOO(f&HNNm zaciVW%_DlOXe)_|n<=dkR{tT?M(uOlz-VNLG!p%j_v=xqeQH#F#ZATb6^3o94mXvW zXV|7nz7q{mrRHe^CtVgvHDfW=h7&EfctqykQN^^|yL7)|PNt43=I*X>*){A0f6>jm zlWM?O;`C2wL|o1@&H>LRUYv41iuAo~Ig!et=y0+UlG>lBC&6?y&_+L+(Kehi*^iWo zzllvosNq^~M-=fG(sL^B5pHkskNc0$+gtD$Z`)gp zV@wn9!{n!Sh+tR+L!ZGY4w*g2;b+QgK;bbCgIntciEXI=`b=?zF?D?c>x6ad2eJk5 z>iUrp57=7*=hQaLTO#gt=9wC*AF6ILEn8Ae-q|I%w?3G?1i>4IgotW=8XH`G$kK;v z=aRQF2g)|Yd%kSnqGS7QuyI4Bnpks;ZU=bFd~Lhftw3GN7B&y~#sNcYs&p3?tFGBq zd&~J$y(wNn;mcszI5LS$pHy0PL`Kuc$fc6{Ya~)7l%@B8b7M8z1AU)-j6DWBo=j%d z@QDbG;PuqQo(E(nc{6NyYH6ei&ts;B(*CL9 z{U5nM8ZOVBcf-iU1-5z`4*IQ(G&8S5IO{$$Bh^I4lS$Dhk?xBOWL{XH8&cDfN;596 zW_}_D5>4rv5d1Sy(+R)n=2(YN+p`KI^%V7vca}?Hp(KXOl&4GuLBHfCTY<1a-eOy1 z$xAOWmy~DH&7(X|qm}8paYJ8Uxs3%S^=pDRG3{0^ic~IZkt%I4Y6(R;A&((^-CaWm zLS}s2C?ehj+cu44tKp+fCUMStXHz2E4Ffi(u(eRJd414c`xZQSFndc>$l0SS`el&=tNpsg#n9KqQ1{#XFMBFTp?p8q%NjT}JiIg5 z8fXdMmJc(x_7^uEtG1@v3TOr@gX{U7%1~#7HF(jzJC$M1zrBXVZF7w7mQ|7r8M?INuem2rk zALyv}cGSC0y0rbUcH1DfANFrc_S`A1F+|IJF?4Uc8!05UrqW-CGY0+vyFH_6EYD?R|RBrXF3x z>Lv9v{WIp1jF_$W6UO*tJ)xV#K1OsZ zksUzDGMX?XCzv|Hmb#g1-OMz*vJJU$z+Ng+q+fvA=bAI83lCug`T;!4-a;myCyIMz zam8$kj>ZtP`U@r#x&!QP4?DYfpVkN?c4T>q6HQO#sDf2H-qRfUY&v8=-&R(W=j%G} z*BVt1?3uPyB^9qNljd8jOliJ*OkdM~n7$=0(?^o6T{e2cz3A{GA>WOyA?2a% zmj@e4w>Op)XKuN>;@A~?GnQ!}rW$H(~vr z2V!;)Lw@Cp0T{6+>Y{d2VcFsw$W*;_uIv174_w)^OpJ8ui)o3kk@)huG-~O50!F+p zNJd^lw;4+5FkV#qEV1l@GcP{Qc0uvpkrBJdi%_l=$sF2yD%Xa)_;&8?W(}}@U%vnw zQgrH^P6|LlLiJaDj##9r= zltb4`G3mzi&LH`)N?M3oX}ogJXh-vQwhziQLiHB3E1}XkwK&6HLTW%EG%B-azHEr4;1l$QO!wCf#nD0v)ADB1H(duQt_^B z5WYXY(p%b8UCpts4lunE#)_O{U&&S{rbu(Fr??h(qqN5QC~1xLRF!t(dYVcd*T<=W z*tkBL!XkL9y|_1ex00RLL3l?xD}u_7l+@{h%;zE>t#)2PMTkoFMQZH~q|$*Mr`Z-& zoa->LSm(DL1}35(I~^=I*5&2brt0MFT?6{Ul-slLLL zY)PByOMKhX7M79c)WN=jfY(MCEK|hmr&ibNr_16+%cybA%_TuqwNR~yODv|W@2*JRv-Y>>3Ak<@>FB~2q#s{a444hWw zn2EKN$%vEz*>Nr<4{bh=p&DpEJ%HfXNG0PXc}aOIWU+pvirBZ#^rQWlXPlfowFF%@Oh1El3E3kcaBDQYkhI?}${o z^S$E_FyF!AjYWma-xil^w?RJ<*{4yiFkPyGdPq7k+@I{YG+0*ZLp>}$@ptj-7QA_b zSz%JwOi#HQteipA@c?+gtB%ctl(&ZSnF@I>55E;@o2jrMVcA!?H0yNnULk%`eb~S6 zZmX}Fbb_~=pyy{$fUXpb9q;;FyM^ZA4B1E#>Dj~KB-xaX?)@lEoMV6 zHfIzJ>nl*NZ1Hxq#GD}>oq9R&7()NOU?V%C&w!UsCKyS)^cl`8CpYWt5 zJpGQ*i8ZQ!a}GU|&O&73Qcln71Xmi?ygz1i(QHwr(wUv!Y5w&i+aqQ)0TDRE(n64| z<;vmURpvGL;r+s}Ovmp=U`wo-q?`GXu3>(BB1}KqZ_pTVBGObnx3Ov7lIY(y{#nm8 z8+SUNIXi<1efRSR+r+y$ICoQJole`IPcu!;Nl9{A{u;x)e)XoIQ^liPaX+Zw?VJDdKL97lym; zW_Z!lBGd2*7F1ghen1dQ8x9i0D>%arH{9fgO_U&bHfcGjZoX`R;%To6rWbLivg#8*9=QBZb@_jrKf0I&vOD znI=_HCs_tk)BvyF-4_s|k_fA&SVx$&uUFy0@1}?@p8oDTcHVjX`&5?NKqd4BnsGx0 z^S6W4^9@*&OS_Zzr2op^>uJv6KmL`As_y+1Bzhe5^Vkumd_@7dxlqv!ml~0vye*Xw zuwK;!zxz3oUaBbPXpD;dQ*qG#b0{-8&-{GPC}cD>Y4bUj#wxe^F!muEcKC0MUE*xr z)?*s$*BiZleH&G$ZoQ(hu%fX@Sxgf~YS4M>$^B$!Oa z#&6Bj*>Gw_BLP*fZe6XjpbX^E9+5l<LuO|_UR<4J4yeArgD;qWdWmY}kht)KX@Ma+9^hCeICy|nQ;D CZ{#5W delta 12839 zcmbVSd0f;-mjBi7=mrGk1`(tIZ$S=0MHFeErJ*nE1{FL}QP2hq;uw$EpgD{(QLHH4 z8aIl>E13wkyGk6d%s5dK^NBH;=)}aB#E2$3lF4S0>?CfzR}DRx-9PrTd_Git>(#5O zS5>dxdsV-7x66lLk+&rcEnQJrzao2C#d3Q^ZMLy)VTC=rrgD+Ja`o6T8QJ#g70Vaa z)mPFEzi>x-fURz2{lZGk;%a-PW?_A0MMLExjjf_#W&NUx)rp$aOpUE_c|&E*g35YL zT1r|bqUt6M^YEA|2bmxv{b#ZBlUTf1sc^KX2A6F8?sJJOL8xupDtF`Hjwi3oc z0vT1Z>ZSts&p1Xmz#kY{WwzuNn)9J}$6NCmtC91xMkCNW=*I!Gqu+5hhiDd7)DCaZ zEU45})K=J6uc=%V2Mj0Ow*L8|l$xI6-WB*;S&<9U(#F$KVV6lG{m-ydiErjDVO+wa zwoaj|=#*h!N3?;=7U#5>nvCSM5$hsN1J4@7QypKrKM4;a@hef3Z&>G~79a_PM1?R2 zAfbVg%N?_rn8Xa_Qa~_2G8IHGDJh!>g={Ez=0`@bf>?-52@Fcc;%UGWiM^Tt_D5)8 zQ1}Nx;d@9Pxym8yW^I&FT65VbDE)<%=;O$7iQ}DAWSH1kA|~L@r#Y#_N|MEDby5PA z#f_{DNum`4V@QbGG4QNR*3l`09|eb)$lM&Q!JqXgoHB{0J08&7*vr}m)~KJ!W-GB+ zb+DJv+Kv)^0dTGt79;!;sOf!F;RkBcRHlqU!UL#FaHT^w*aaFxf_dh{Mp5akR*TgJ zREd7B`D4Gu&So)D1Lc{tGcGOSMozUKNJpzWg)2F}0NFmiLW7z!Y2e=Ypp#WyRc} zl{|u6rC%n$GHd!}a3#u+12Uam0;1L|O3E(RT zK~QPC7q0j6)_bANotnB=%;6$GgeH5SQhHd)~KQX(1epx%6hBKGq6^@0|+ zyTCz6wR>z~HSuZTiq}Hhi}HQ8Pr<&=&__l2q=;r1G<3RQgwOi|kfm_?tRd6yu9ylX zp?fI3Wa#m^V8td~^i5-G()oB^6@l4Z+&u9NSTDt3w#+d1?pv30r%xr-m! zwyS-Gj>tk1M8u*Tttj?`)i@hcD0X$+(FYO9fDFve2NBtr8-2w1PfTFvZ&w8hqRfUN z<)TElnPLavf=O{A0ZF8Idd8G0b}6*S6rO;pBn`!iAt>n0CV2(`@md;YSLrD8=9u%z zSlEs{;+be+g8g3Z5;7j0B>#NsZGz&E6_W z_jf}@KOl&0R9%`Cu?bp(Nf5Q*!-Qt6bJMcY!DKUivUJ#lE!-g;Rbw~Ldt@R(O#e(( zC$$pcezisWj24fQ*j305XCa{N%_eCi0P#Z~-VEHGV%AyukzAmIW?ETVJ9Adw!i#UwYcuDH zZ;7A*0iD=K2c}2q^s>0%rP#gD#RTM*cfiYZU3omsD~}MR)AU5S zhP+L$m&XOR@eYKau!FY+CVvHVx^Y(2fP8=VII) ziUfqH*ir$oakT*`{D2Gydl23LYBvj2)cLwRqt=QZ;}%vybS1pcA0o7K; zsC)OPvTCnS3%A!TG@yE{??dNKbY}->VfB#g#b|m_vGqBkNOmB68dFS+dyLhOTB*XYdwNKE(4QuvJBW5?4H`{-yM9)V3@;SslM13YFmkiKLeF(wgOk{2W% zdYwUUA#|g+5bpM_+K;S1ShYXWZ|#PlIi#G-XC(m*PD_WLnrk$pV{_nIHjrJ*iae&s z$PE(s>bv?KKG5PU81|Rxu9_U_M@69LeiJ&|%r2N919K7qko_JD5NZqmfe@}M!mC~? z4~F4lCu{?%_!B^kgvka}5%I%PsE{sDQ>`Ynlc@k1`2=UhwG_|OrrHSK|MFO~pXk0? z?SNbfPmiqSjI^h=octFx)?H`m(B%c=x?q%Npi(Y&KqlO(LW-S^<6PP0QXwr zX#xGsip1bmY%*$Nq1iCijA1BaKfc1+Z=t`(Zc73UYM3xwByelw5hSVb7zXi2K4Ez- z^SDf8aTs0RFiGk$6WZC3CTGKy=U&4Eb`OYOxsC+VmsftC6=4Y_^Mdt-+$~!|#d)D; zJGvqAQeaM!PUOD1Knip%kb-cYPhmQjp83r%C7j7Sh+f$kv3-?~gR6cEtkz$FN9+XH z?S-E*ZpD~iI2CW$&q0NB0eEJ4A=*5$0;q|up^#~yQuqa+KkK01)Iy^!&tkIimkZ%> zZ?!`Zz6C5(;J?#L7KH0w>e~RN|G>yvufVi`f)cb?P}(n-gxNtB1P zGM&HXi0o%cB<{eq5+UEy;&q|_^q)p(9z%c~@e@8xyUaIEJV*g~Ic%80-k0gQ;xAgJWfhX!p3pe*AvbyiC;R24#% zm;o?}uGuiyf!a>sO+fVp)N%N!7vgA~ihdejH&o}4VFNUK%?q7g_;epsZUU6sS)#n- zg{KiZh6CB{CGQ7_Plw7TFRbxGs~3*%gYp%CD5ZSS3;*DSXApwG@)0lGIo69ec;QUu zwSDs}W?PBYTmtJR;{hNLo=NxUrH#WKct&wR>3wX7&njLqB(E3}7X!wYj`j`0uOhgb z5?U4xaqn=kBzS&{m~FD<>2-OAT%#q=U`w_Y>++^+t;JvpB)zw@RDir$6y5x^W&+pn zgN!QTA;%>ZabGz^p*TDQjX8V)^w3dYwB%}yFb=d|h{M4A#JOHr=7s1laV zFP|LZDc~>!o55O;U%c=hn`&&|RB6LAQG-5#TAUGi-3xayMh)0+dhVG3$9iuC`crP4 zEBmOzR)FLWED=y4#ZEjiByJH@h!L4s-!zRCRH&QysHJ)f$?#~ZIth?dQA-7|p{jPI zI^YFN#SJoyp+f)9nYUmU=YhJ;+r=uRf(ubiKnTWJH430)0Ei|5!*&(gEHuc5chhScOx@MEH(m^@c*b9? zDr_%zVVu{2Zi;|9k?;GM3C;s|lGuPMHv$7LvAi1KIHaxuh$mBC2QU(;>jC;AT*Dy0 z^P}v-*GOFpR5a;}2d`JT} z=d*Vg>*iGUEd2E5A*6yH-keTG(oZ)JioEV@9#C7?psB0XG*t0Vd8{cpNQ1Tvk6`c6 z{aFQ%S{hbWFT~hpKDBH~@jc?)sQ_mS-Lz$%lv?!$eh2t@%VOyz1EEWrcalo_OLM}= z^%A$cbrO#>)<}4YSzr)=6J3qz5nqKSXGPG8-wqm!XNH@(rC14mk{AGTYlaKOA@8f5 z9{p`4X{TW?JVTzQyI;s)0sB>!s;GMFD&JSRq@sg9x3xivWzT_+w?>iMG-}(|;g9f% zri*=Dc%$lc;eLIm@KGW8Jxy*gvi}e|<@HdywPg-ls|PLd!`FL6uk(n$M(U69t(68~ zUXSUkblmn72bwjUgvi|jOhOca1Kk4o*$aR0!oPXpLxkuSKK4THLy`LLUMfHINL>b0 zsSM&{vKX+q6yO|yd{MbW0>@2aunW*m&j&JuAzms@kPD0_fNY=>T`7)DytlQGNf+#p ziJdr4x!uHx(VPWaNf*Lkh_8Tz=ak$=_zO_4d8zLr{2Hj|yi_zS*134xAf*7MtRL+b=b5xynN3%84p=0&<=Ea5eeAI*z$ zhZb6bvBqf$F67S*9)aEnDdIB>31P1voj?DBEdwl^yne=dTXVUlh|s1H0m~4%lTR2y<@W4^W#kJ^mZ)`VgxoUm%1)kX!;NbOCIlhn)#z zCB5Q|b#R}AFO4IS17R>c3g#KDz2EwMpo$+3sSgS~hC_@0qnG*}LO7uU>OO{k0xCR* zT+5N+5V~ki#`p=x5Vm-Gd)5n^c*nIoo5eFd&qhNgg>pA`I})V*hszE!;A(JXy^Fl~ zIs67dMrGG<0dF=K+6jO1kQwznGGp}U_EKL*>Un7Fb@#$ANLKt#ahB2F2sBp2-+3As(P$nJ+#}`Cj?pUg_Qs~?>vCKGk!0Drx{P| zvJc?r*z9wFH(m7Ee_Nhk$^wru0gNC{aW-RkAtthq((L=RCO#fgsETAv8VEhegI;#> zQ6Fs?o%piO_m*>~FL2DKn_hlPauyM4+q>ObT^J}xY80zh!eb<_kkD1g4Ln|8hr1uv z_d4At{>ACmdz@|^a^0fi_a)?6aUOV94V(-^=Xt4kJtnUM6{8OUdC@D&pE0WNF5R=Q zmPHc&ZGRw#=zDEhEcM?%dT=`rH#czB!+ZyYZtR3T@RjaQBA?NX`zH-t?s=nJ$)9rN z6)4ANEEsPb7DgZJkMwEh^FBxe+S8ST?4553o!cHxXSdIcE%1Ck(|JCh8TcCU@KruY zueF;Zb+}wYH(DI2p!Y=FrxRY8OYYOwSCU8UAB8jiG66DDk3!1#;YTygvZk_Oq389f zoj!bJC7bJ_1359ri-1>LibqiXFqN0Wct+132xZTme?IUmOXnO+k7>h8ukZz)Te)ot zunAwFwUOKC>j%3tYMit`J3Ia+Td}r8Z^Ns)lghv-;}umwyQ(AtMZuQJNP6K=3VUSj zT~zsSHmRj~hl_$&HF1%ZkdUd@1#I1Wvb z6dD30`L++VdY?OkBk}l4A>kEQTC&R?hwPUJy6pX3cD2hc0q1$T_tlfW&9t^g>6mKZLiOo!R}k&Rk-mi#o?e zz)!gN;|!i`5ly*LPCGlplAwu*i;EF4ze|egj7lCu|H2V~=WwXe?!R@ah-$Qv%_5pk zI~C>*bvsD-XwOYzSxyOR)l91I6ieyhYJ zIZI10e(EG&(a3)vBO0c=Z=D*vg zTHV5+NO(03B$q;!VQgOzs?0{N+bQFHZm(lFgql2q(4RJ%z zk}AvS+SA{&{ir{4kC^G~vvbs3=gsuo*+w#(YR`>kY0bHG$83RwF~_{lV;9RkKe*a7 z%^vl0&#_E<#kA`)?T>p}^(aS2mENA&vm2FDZ}+?LUdIf*J>};fC#SsEp=ZS#9l5NT zJ?iGKS`Pi!mZ8wn(bMW_x)EBkRv+UsoSe4o`avnaMo^8)dQuBNzKLcV{7*zZpF3>!mvrrAQ+b|i zeG&{rn()MsAeb{UqEC81 z9g4@?@oQCGf}NT*wM^&&xQoaui5{Slx%d-tc8N1Al7kp z*QmrG3icPdkXSFQsJ23hiY8q*Wu zQ#SiPCXfj=*g~nn^;PAOU?){U zA4(0T+!*qZVlqwU%)SN1iVvXy>Nw7_zpssLJJO^h(R(*EaP37T~QgXEO+S- zKdPBlk4?$kVI?_a?hZ=cB_mHPAmpY7TL5V#n@^1BPf{harL{bW)DZvHi$TN|0>4mzHo`e!7t2(49zXtX DPnT}` diff --git a/library/MSANALYZE b/library/MSANALYZE index 0a5d211d..33e0bb07 100644 --- a/library/MSANALYZE +++ b/library/MSANALYZE @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Aug-90 13:13:24" |{PELE:MV:ENVOS}LIBRARY>MSANALYZE.;5| 62596 changes to%: (VARS MSANALYZECOMS) previous date%: "12-Jun-90 17:27:56" |{PELE:MV:ENVOS}LIBRARY>MSANALYZE.;4|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1982 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 MSANALYZECOMS) (RPAQQ MSANALYZECOMS [(PROP FILETYPE MSANALYZE) (COMS (FNS VARS FREEVARS CALLS COLLECTFNDATA CALLS3) (VARS MSMACROPROPS (NOPACKCALLSFLG)) (BLOCKS (CALLS CALLS COLLECTFNDATA CALLS3 (LOCALFREEVARS CALLSDATA) (NOLINKFNS . T) (GLOBALVARS INVISIBLEVARS COMPILEUSERFN NOPACKCALLSFLG LAMBDASPLST MSRECORDTRANFLG)) (NIL VARS FREEVARS (LOCALVARS . T))) (DECLARE%: EVAL@COMPILE (VARS MS.VERB.TO.NOTICED) DONTCOPY (MACROS MSVBNOTICED))) [COMS (FNS ALLCALLS MSINITFNDATA MSPRGE MSPRGMACRO MSPRGCALL MSBINDVAR MSPRGRECORD MSPRGERR MSPRGTEMPLATE1 MSPRGTEMPLATE MSPRGLAMBDA MSPRGLST ADDTO NLAMBDAFNP MSPRGDWIM MSDWIMTRAN) (E (MAPC MSFNDATA (FUNCTION RPLACD))) (VARS MSFNDATA MSERRORFN (MSRECORDTRANFLG)) (ADDVARS (INVISIBLEVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17)) (DECLARE%: DONTCOPY (MACROS INCLISP LTEMPLATE)) (BLOCKS (ALLCALLS ALLCALLS ADDTO MSBINDVAR MSDWIMTRAN MSPRGCALL MSPRGDWIM MSPRGE MSPRGMACRO MSPRGERR MSPRGLAMBDA MSPRGLST MSPRGRECORD MSPRGTEMPLATE MSPRGTEMPLATE1 NLAMBDAFNP (NOLINKFNS . T) (LOCALFREEVARS FNNAME ERRORS FNDEF INCLISP ONLYRELS PARENTCONTEXT TOPVARS PARENT EACHTIME VARS) (GLOBALVARS CLISPARRAY MSERRORFN MSRECORDTRANFLG MSFNDATA INVISIBLEVARS CLISPARRAY MSTEMPLATES USERTEMPLATES MSRECORDTRANFLG NLAMA NLAML DWIMFLG CLISPTRANFLG DWIMESSGAG) (NOLINKFNS . T)) (NIL MSINITFNDATA NLAMBDAFNP MSPRGDWIM (LOCALVARS . T) (GLOBALVARS NLAMA NLAML MSFNDATA DWIMFLG DWIMESSGAG))) (P (PUTDQ? MSWORDNAME (LAMBDA (X) X] (COMS (VARS (MSTEMPLATES (HASHARRAY 160)) (USERTEMPLATES (HASHARRAY 10))) (FILEVARS INITIALTEMPLATES) (* ;;; "INITIALTEMPLATES is not needed after loading up") [P (MAPC INITIALTEMPLATES (FUNCTION (LAMBDA (X) (MAPC (CDR X) (FUNCTION (LAMBDA (Y) (PUTHASH Y (CAR X) MSTEMPLATES] (DECLARE%: EVAL@COMPILE DONTCOPY (PROP MACRO LTEMPLATE))) (COMS (FNS MSFINDP) (BLOCKS (MSFINDP MSFINDP]) (PUTPROPS MSANALYZE FILETYPE :COMPILE-FILE) (DEFINEQ (VARS (LAMBDA (FN USEDATABASE) (* lmm%: 29-DEC-75 23 22) (CDR (CALLS FN USEDATABASE T)))) (FREEVARS (LAMBDA (FN USEDATABASE) (* lmm%: 5-DEC-75 11 8) (CADDR (CALLS FN USEDATABASE 'FREEVARS)))) (CALLS [LAMBDA (EXPR USEDATABASE VARSFLG) (* ; "Edited 12-Jun-90 17:25 by teruuchi") (* ;  "This FNS is for the User Interface Function in MSANALYZE(MasterScope)") (* ;  "Edited by Tomoru Teruuchi(12-June-90 : for AR#10020)") (PROG (FREES (GLOBALS NIL) FNDEF FLG) [COND ((AND USEDATABASE (LITATOM EXPR) (GETD 'UPDATEFN)) (UPDATEFN EXPR NIL 'ERROR) [SETQ FREES (GETRELATION EXPR '(USE FREELY] [SETQ FREES (SUBSET FREES (FUNCTION (LAMBDA (VAR) (* ;  "This Function is The Predicate whether the variable is global or not.") (if (OR (FMEMB VAR GLOBALVARS) (EQ (GETPROP VAR 'GLOBALVAR) T)) then (pushnew GLOBALS VAR) NIL else T] (* ;  "Edited by TT (Date : 8-May-1990)") (RETURN (LIST [AND (NOT VARSFLG) (GETRELATION EXPR '(CALL NOTERROR] (AND (NEQ VARSFLG 'FREEVARS) (GETRELATION EXPR 'BIND)) FREES GLOBALS] GETDLP (SETQ FNDEF (COND [(LITATOM EXPR) (OR (GETD (OR (GETP EXPR 'BROKEN) EXPR)) (GETP EXPR 'EXPR) (AND (NEQ EXPR (SETQ EXPR (FNCHECK EXPR NIL NIL T))) (GO GETDLP] (T EXPR))) (RETURN (COND ((NULL FNDEF) NIL) ((SUBRP FNDEF) NIL) ((CCODEP FNDEF) (SETQ FNDEF (CALLSCCODE FNDEF)) [OR NOPACKCALLSFLG (for X on (CAR FNDEF) do (FRPLACA X (PACK* '; (CAR X) ';] (FRPLACA (CDR FNDEF) (NCONC (CADR FNDEF) (CAR FNDEF))) (SETQ FLG) (CALLS3 (CDDR FNDEF)) (CALLS3 (CDDDR FNDEF)) (CDR FNDEF)) [(EXPRP FNDEF) (* Note that EXPR can be a piece of a function definition, and calls will still  work.) (RESETVARS ((MSRECORDTRANFLG T)) (RETURN (PROG (CALLSDATA LAMFLG) [COND ((FMEMB (CAR FNDEF) LAMBDASPLST) (SETQ LAMFLG T) (COND ((OR (AND (EQ (CAR (CADDR FNDEF)) '*) (EQ (CADR (CADDR FNDEF)) 'DECLARATIONS%:)) (EQ (CAR (CADDR FNDEF)) 'CLISP%:)) (MSPRGDWIM FNDEF EXPR FNDEF))) (SELECTQ (CAR FNDEF) ([LAMBDA NLAMBDA] NIL) (SETQ FNDEF (OR (AND COMPILEUSERFN (APPLY* COMPILEUSERFN NIL FNDEF)) FNDEF] (SETQ CALLSDATA (ALLCALLS FNDEF LAMFLG [UNION (CONSTANT (MSVBNOTICED 'USE 'FREELY)) (AND (NEQ VARSFLG 'FREEVARS) (UNION (CONSTANT (MSVBNOTICED 'BIND)) (AND (NULL VARSFLG) (CONSTANT (MSVBNOTICED 'CALL 'NOTERROR] EXPR T)) [SETQ FREES (NCONC FREES (COLLECTFNDATA (CONSTANT (MSVBNOTICED 'USE 'FREELY] [SETQ FREES (SUBSET FREES (FUNCTION (LAMBDA (VAR) (if (OR (FMEMB VAR GLOBALVARS) (EQ (GETPROP VAR 'GLOBALVAR) T)) then (pushnew GLOBALS VAR) NIL else T] (* ;  "Edited by TT (Date : 8-May-1990)") (RETURN (LIST [COLLECTFNDATA (CONSTANT (MSVBNOTICED 'CALL 'NOTERROR] [COLLECTFNDATA (CONSTANT (MSVBNOTICED 'BIND] FREES GLOBALS] (T '?]) (COLLECTFNDATA (LAMBDA (LST) (* lmm "21-DEC-78 22:56") (COND ((NLISTP LST) (CDR (FASSOC LST CALLSDATA))) (T (PROG (VAL) (for X in LST do (SETQ VAL (UNION (COLLECTFNDATA X) VAL))) (RETURN VAL)))))) (CALLS3 (LAMBDA (LST) (* lmm " 6-JUL-78 00:23") (* lmm%: 13-DEC-75 4 51) (PROG (FLG) (for X on (CAR LST) do (OR (NOT (FMEMB (CAR X) INVISIBLEVARS)) (SETQ FLG (FRPLACA X)))) (COND (FLG (FRPLACA LST (DREMOVE NIL (CAR LST)))))))) ) (RPAQQ MSMACROPROPS (ALTOMACRO DMACRO BYTEMACRO MACRO)) (RPAQQ NOPACKCALLSFLG NIL) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: CALLS CALLS COLLECTFNDATA CALLS3 (LOCALFREEVARS CALLSDATA) (NOLINKFNS . T) (GLOBALVARS INVISIBLEVARS COMPILEUSERFN NOPACKCALLSFLG LAMBDASPLST MSRECORDTRANFLG)) (BLOCK%: NIL VARS FREEVARS (LOCALVARS . T)) ) (DECLARE%: EVAL@COMPILE (RPAQQ MS.VERB.TO.NOTICED ((BIND (NIL BIND ARG)) [CALL (DIRECTLY CALL EFFECT PREDICATE NLAMBDA) (EFFECT EFFECT) (INDIRECTLY APPLY STACK) (NIL CALL ERROR APPLY EFFECT PREDICATE NLAMBDA STACK) (NOTERROR APPLY CALL EFFECT PREDICATE NLAMBDA STACK) (PREDICATE PREDICATE) (TESTING PREDICATE) (VALUE CALL) (NLAMBDA NLAMBDA] (CREATE (NIL CREATE)) (DECLARE (LOCALVARS LOCALVARS) (NIL LOCALVARS SPECVARS) (SPECVARS SPECVARS)) (FETCH (NIL FETCH)) (REFERENCE (FIELDS FETCH) (FREELY REFFREE) (CL:LOCALLY REF) (NIL REFFREE REF)) (REPLACE (NIL REPLACE)) (SET (FIELDS FETCH REPLACE) (FREELY SETFREE) (CL:LOCALLY SET) (NIL SETFREE SET)) (SMASH (FIELDS FETCH REPLACE) (FREELY SMASHFREE) (CL:LOCALLY SMASH) (NIL SMASHFREE SMASH)) (TEST (FREELY TESTFREE) (CL:LOCALLY TEST) (NIL TESTFREE TEST)) (USE (FIELDS FETCH REPLACE) (FREELY SETFREE SMASHFREE REFFREE TESTFREE) (I.S.OPRS CLISP) (INDIRECTLY LOCALFREEVARS) (CL:LOCALLY SET SMASH REF TEST) (NIL SETFREE SET SMASHFREE SMASH REFFREE REF TESTFREE TEST) (PREDICATE TEST TESTFREE) (PROPNAMES PROP) (RECORDS RECORD CREATE) (TESTING TEST TESTFREE) (VALUE SMASH SMASHFREE REF REFFREE) (TYPE TYPE)))) DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS MSVBNOTICED MACRO [OPENLAMBDA (VERB MOD) (CDR (ASSOC MOD (CDR (ASSOC VERB MS.VERB.TO.NOTICED]) ) ) (DEFINEQ (ALLCALLS [LAMBDA (FNDEF LAMFLG ONLYRELS FNNAME INTERNALFLG EACHTIME) (* ; "Edited 21-Apr-88 16:31 by jrb:") (LET (VARS TOPVARS INCLISP ERRORS (PARENT FNDEF) (NOSPELLFLG T)) (DECLARE (CL:SPECIAL NOSPELLFLG)) (MSINITFNDATA) [COND (LAMFLG (MSPRGLAMBDA FNDEF 'ARG)) (T (MSPRGE FNDEF NIL 'RETURN] (COND (INTERNALFLG MSFNDATA) (T (for X in MSFNDATA when (CDR X) collect (CONS (CAR X) (CDR X]) (MSINITFNDATA (LAMBDA NIL (* MSFNDATA is an association list of the "noticed" types, e.g.  CALL, BIND, etc. -- the FRPLACD resets the pointer) (for Y in MSFNDATA do (FRPLACD Y NIL)))) (MSPRGE (LAMBDA (EXPR SUPEXPR EVALCONTEXT) (* lmm "27-May-86 04:44") (* ;; "analyzes EXPR; SUPEXPR is the parent expression and is used in the SHOWUSE case where we are printing occurrances of various things rather than updating data base; EVALCONTEXT is a type of reference for this expression from the template: SMASH etc") (PROG (TEM CALLED CLISP) (COND ((NLISTP EXPR) (RETURN (COND ((AND (LITATOM EXPR) EXPR (NEQ EXPR T) (NOT (FMEMB EXPR INVISIBLEVARS))) (* ; "A variable reference") (COND ((OR (FMEMB EXPR VARS) (SOME TOPVARS (FUNCTION (LAMBDA (Z) (* ;  "bound higher up in the function but but used in a functional argument") (COND ((FMEMB EXPR Z) (ADDTO 'LOCALFREEVARS EXPR SUPEXPR) T)))))) (* ;  "Things were added to VARS only if they were 'noticeable'") (SELECTQ EVALCONTEXT ((SMASH TEST SET) (ADDTO EVALCONTEXT EXPR SUPEXPR)) (CHANGE (ADDTO 'SET EXPR SUPEXPR)) (ADDTO 'REF EXPR SUPEXPR))) (T (SELECTQ EVALCONTEXT (SMASH (ADDTO 'SMASHFREE EXPR SUPEXPR)) (TEST (ADDTO 'TESTFREE EXPR SUPEXPR)) ((SET CHANGE) (ADDTO 'SETFREE EXPR SUPEXPR)) (ADDTO 'REFFREE EXPR SUPEXPR))))))))) (COND ((EQ EVALCONTEXT 'SET) (* ; "in a 'SET' context, but not a variable") (MSPRGERR PARENT))) (COND ((LISTP (SETQ CALLED (CAR EXPR))) (MSPRGLAMBDA CALLED NIL (SELECTQ EVALCONTEXT ((TEST EFFECT SMASH) EVALCONTEXT) NIL)) (SELECTQ (CAR CALLED) (LAMBDA (MSPRGLST (CDR EXPR) EXPR)) NIL) (RETURN))) (COND ((SETQ TEM (LTEMPLATE CALLED)) (RETURN (MSPRGTEMPLATE EXPR TEM EVALCONTEXT)))) (COND ((NOT (FGETD (OR (GETP CALLED 'BROKEN) CALLED))) (COND ((AND DWIMFLG (SETQ TEM (GETPROP CALLED 'CLISPWORD))) (* E.G. IF, FOR, etc.) (SETQ CLISP (MSDWIMTRAN EXPR)) (RETURN (COND (CLISP (COND (TEM (SELECTQ (CAR TEM) (RECORDTRAN (OR (MSPRGRECORD EXPR EVALCONTEXT) MSRECORDTRANFLG (RETURN)) (* optionally also look at translation) ) (IFWORD) (CHANGETRAN (MSPRGE (CADR EXPR) EXPR 'CHANGE)) (for X in EXPR when (AND (LITATOM X) (EQ (CAR TEM) (CAR (GETPROP X 'CLISPWORD)))) do (ADDTO 'CLISP X EXPR))))) (* Analyze the CLISP translation) (PROG ((INCLISP (INCLISP EXPR))) (MSPRGE CLISP EXPR EVALCONTEXT))) ((OR (NULL (GETPROP (CAR EXPR) 'CLISPWORD)) (NEQ (CAR EXPR) CALLED)) (RETURN (MSPRGE EXPR SUPEXPR EVALCONTEXT))) (T (SELECTQ (CAR TEM) (RECORDTRAN (MSPRGRECORD EXPR EVALCONTEXT)) (CHANGETRAN (MSPRGE (CADR EXPR) EXPR 'CHANGE) (MSPRGLST (CDDR EXPR) EXPR)) (PROGN (* CLISP word wouldn't DWIMIFY) (MSPRGCALL CALLED EXPR EVALCONTEXT) (MSPRGERR EXPR) (MSPRGLST (CDR EXPR) EXPR))))))) ((SETQ TEM (CL:MACRO-FUNCTION CALLED)) (LET ((ME (CL:MACROEXPAND EXPR))) (COND ((AND (NOT (EQUAL ME EXPR)) (NOT (EQUAL ME INCLISP))) (MSPRGCALL (CAR EXPR) EXPR EVALCONTEXT) (PROG ((INCLISP (INCLISP EXPR)) (EXPR EXPR)) (MSPRGE ME EXPR 'EVAL)) (RETURN T)))))))) (COND ((NLAMBDAFNP CALLED) (ADDTO 'NLAMBDA CALLED EXPR) (COND ((AND MSMACROPROPS (SETQ TEM (GETMACROPROP CALLED MSMACROPROPS)) (MSPRGMACRO EXPR TEM EVALCONTEXT)) (RETURN))) (MSPRGCALL CALLED EXPR EVALCONTEXT)) (T (* ; "normal lambda function call") (MSPRGCALL CALLED EXPR EVALCONTEXT) (MSPRGLST (CDR EXPR) EXPR 'EVAL)))))) (MSPRGMACRO (LAMBDA (FORM MACDEF CONTEXT) (* lmm "13-DEC-82 23:45") (PROG ((ME (MACROEXPANSION FORM MACDEF))) (COND ((AND (NOT (EQUAL ME FORM)) (NOT (EQUAL ME INCLISP))) (MSPRGCALL (CAR FORM) FORM CONTEXT) (PROG ((INCLISP (INCLISP FORM)) (EXPR FORM)) (MSPRGE ME FORM 'EVAL)) (RETURN T)))))) (MSPRGCALL (LAMBDA (FN PRNT CONTEXT) (* lmm "22-DEC-78 12:57") (ADDTO (COND (TOPVARS 'APPLY) (T (SELECTQ CONTEXT (TEST 'PREDICATE) (EFFECT 'EFFECT) 'CALL))) FN PRNT))) (MSBINDVAR (LAMBDA (VAR TYPE EXPR) (* lmm " 6-JUL-78 00:23") (COND ((AND VAR (LITATOM VAR) (NEQ VAR T)) (COND ((NOT (FMEMB VAR INVISIBLEVARS)) (ADDTO (OR TYPE 'BIND) VAR (OR EXPR PARENT)))) (SETQ VARS (CONS VAR VARS))) (T (MSPRGERR (COND ((LITATOM VAR) (OR EXPR PARENT)) (T VAR))))))) (MSPRGRECORD [LAMBDA (PRNT CNTXT) (* ; "Edited 8-Apr-88 14:49 by jrb:") (* ANALYZE RECORD EXPRESSION PRNT -  RETURN NIL IF ANALYZED SUCCESSFULLY) (PROG (Z) (MSPRGTEMPLATE PRNT (SELECTQ (CAR PRNT) ((create CREATE) (ADDTO 'CREATE (CADR PRNT) PRNT) (SETQ Z (CDDR PRNT)) [while Z do (COND ([EQ 'RECORDTRAN (CAR (GETPROP (CAR Z) 'CLISPWORD] (* e.g. USING or COPYING) (MSPRGE (CADR Z) PRNT (SELECTQ (CAR Z) ((smashing SMASHING) 'SMASH) NIL)) (SETQ Z (CDDR Z))) ((EQ (CADR Z) '_) (* If dwimified correctly, the fields should be separated by _'s) (ADDTO 'REPLACE (CAR Z) PRNT) (MSPRGE (CADDR Z) PRNT) (SETQ Z (CDDDR Z))) ((EQ (CAAR Z) 'SETQ) (* partially dwimified) (ADDTO 'REPLACE (CADAR Z) PRNT) (MSPRGE (CADDAR Z) PRNT) (SETQ Z (CDR Z))) (T (* shouldn't happen, but) (MSPRGE (CAR Z) PRNT) (SETQ Z (CDR Z] (RETURN)) ((fetch FETCH ffetch FFETCH) [LET [(OF? (OR (EQ (CL:THIRD PRNT) 'OF) (EQ (CL:THIRD PRNT) 'of] (COND [(EQ CNTXT 'CHANGE) `(NIL (IF LISTP (BOTH (NIL |..| FETCH (BOTH FETCH REPLACE)) (|..| RECORD NIL)) (BOTH FETCH REPLACE)) ,@(if OF? then '(NIL EVAL |..| PPE) else '(EVAL |..| PPE] (T `(NIL (IF LISTP (BOTH (NIL |..| FETCH) (|..| RECORD NIL)) FETCH) ,@(if OF? then '(NIL EVAL |..| PPE) else '(EVAL |..| PPE]) ((REPLACE /REPLACE replace /replace freplace FREPLACE) (LET* [[OF? (OR (EQ (CL:THIRD PRNT) 'OF) (EQ (CL:THIRD PRNT) 'of] (WITHSLOT (if OF? then (CL:FIFTH PRNT) else (CL:FOURTH PRNT))) (WITH? (OR (EQ WITHSLOT 'WITH) (EQ WITHSLOT 'with] `(NIL (IF LISTP (BOTH (NIL |..| FETCH REPLACE) (|..| RECORD NIL)) REPLACE) ,@(if OF? then '(NIL) else NIL) SMASH ,@(if WITH? then '(NIL) else NIL) EVAL))) ((type? TYPE?) '(CLISP RECORD EVAL . PPE)) ((initrecord INITRECORD) '(CLISP RECORD . PPE)) ((WITH with) [COND ((SETQ Z (RECORDFIELDNAMES (CADR PRNT))) (ADDTO 'RECORD (CADR PRNT) PRNT) (MSPRGE (CADDR PRNT) PRNT) (for X in (PROG1 [for X on MSFNDATA when (FMEMB (CAAR X) '(SETFREE TESTFREE REFFREE)) collect (LIST (CAR X) (RPLACA X (LIST (CAAR X] (PROG [ONLYRELS (EACHTIME (AND EACHTIME (for X inside (PROGN EACHTIME) when [NOT (FMEMB X '(SETFREE TESTFREE REFFREE] collect X] (MSPRGLST (CDDDR PRNT) PRNT))) do (for Y in (PROG1 (CDR (CAADR X)) (RPLACA (CADR X) (CAR X))) do (ADDTO (COND ((FMEMB Y Z) (SELECTQ (CAAR X) (SETFREE 'REPLACE) 'FETCH)) (T (CAAR X))) Y PRNT))) (RETURN)) (T '(RECORD |..| EVAL]) (RETURN T]) (MSPRGERR (LAMBDA (EXPR) (* lmm "21-DEC-78 22:44") (SETQ ERRORS T) (ADDTO 'ERROR MSERRORFN EXPR))) (MSPRGTEMPLATE1 [LAMBDA (X TEMPLATE) (* ; "Edited 19-Feb-88 16:56 by jrb:") (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE ((EVAL SMASH TEST EFFECT SET) (MSPRGE X PARENT TEMPLATE)) ((FUNCTION FUNCTIONAL) (* This is a functional arg to something -  the marker FUNCTIONAL means that it will be a separate function while  FUNCTION is reserved for those things which compile open -  e.g. MAPC is marked (EVAL FUNCTION FUNCTION . PPE) while SORT is marked  (EVAL FUNCTIONAL . PPE)) [OR (COND ((AND (LISTP X) (NULL (CDDR X))) (COND ((EQ (CAR X) 'F/L) (MSPRGDWIM X FNNAME FNDEF))) (SELECTQ (CAR X) ((FUNCTION QUOTE) (MSPRGTEMPLATE (CADR X) (COND ((LISTP (CADR X)) (SELECTQ TEMPLATE (FUNCTIONAL '(REMOTE LAMBDA)) 'LAMBDA)) ((OR (NEQ (CAR X) 'FUNCTION) (EQ TEMPLATE 'FUNCTIONAL)) '(REMOTE CALL)) (T 'CALL)) X) T) NIL))) (EQ X T) (NULL X) (PROGN (* arbitrary expression as  functional argument) (ADDTO 'ERROR 'apply PARENT) (MSPRGE X PARENT 'FUNCTIONAL]) (STACK (* arg to stack fn, e.g.  RETFROM) [OR (AND (LISTP X) (SELECTQ (CAR X) ((FUNCTION QUOTE) (ADDTO 'STACK (CADR X) PARENT) T) NIL)) (PROGN (ADDTO 'ERROR 'stackfn PARENT) (MSPRGE X PARENT 'EVAL]) (PROP (COND ((AND (LISTP X) (EQ (CAR X) 'QUOTE)) (for Y inside (CADR X) do (ADDTO 'PROP Y PARENT))) (T (MSPRGE X PARENT TEMPLATE)))) (NIL (* not used) NIL) (RETURN (* this is sometimes the value of  PARENT expression) (MSPRGTEMPLATE1 X (SELECTQ PARENTCONTEXT ((TEST EFFECT) PARENTCONTEXT) 'EVAL))) (TESTRETURN (* if PARENT is tested, then so is  this) (MSPRGTEMPLATE1 X (SELECTQ PARENTCONTEXT (TEST PARENTCONTEXT) 'EVAL))) (BIND (MSBINDVAR X)) (LAMBDA (MSPRGLAMBDA X)) (PPE (* paren error if not NIL) (COND (X (MSPRGERR PARENT) (MSPRGLST X PARENT)))) (CALL (MSPRGCALL X PARENT PARENTCONTEXT)) (EVALQT [COND ((EQ (CAR X) 'QUOTE) (MSPRGTEMPLATE (CADR X) '(REMOTE EVAL) PARENT)) (T (MSPRGE X PARENT 'EVAL]) (ADDTO TEMPLATE X PARENT T))) (T (SELECTQ (CAR TEMPLATE) (IF [PROG ((EXPR X)) (DECLARE (SPECVARS EXPR)) (MSPRGTEMPLATE1 X (COND ((COND ((LISTP (CADR TEMPLATE)) (* ASSERT%: ((REMOTE EVAL) EXPR)) (EVAL (CADR TEMPLATE))) (T (APPLY* (CADR TEMPLATE) X))) (CADDR TEMPLATE)) (T (CADDDR TEMPLATE]) (|..| [COND [(AND (CADR TEMPLATE) (NULL (CDDR TEMPLATE))) (* Special case to handle most  common cases) (MAPC X (FUNCTION (LAMBDA (X) (MSPRGTEMPLATE1 X (CADR TEMPLATE] (T (FRPTQ (IDIFFERENCE (LENGTH X) (LENGTH (CDDR TEMPLATE))) (MSPRGTEMPLATE1 (CAR X) (CADR TEMPLATE)) (SETQ X (CDR X))) (MSPRGTEMPLATE1 X (CDDR TEMPLATE]) (MACRO (ADDTO 'CALL (CAR X) PARENT) (MSPRGMACRO X (CDR TEMPLATE))) (BOTH (MSPRGTEMPLATE1 X (CADR TEMPLATE)) (MSPRGTEMPLATE1 X (CADDR TEMPLATE))) (@ [PROG ((EXPR X)) (DECLARE (SPECVARS EXPR)) (MSPRGTEMPLATE1 (EVAL (CADR TEMPLATE)) (EVAL (CADDR TEMPLATE]) (REMOTE (PROG (VARS (TOPVARS (CONS VARS TOPVARS))) (MSPRGTEMPLATE1 X (CADR TEMPLATE)))) (KEYWORDS (* ;; "KEYWORDS list of keys...") (* ;; "Specifies list of legal keywords") (* ;; "(FOO (LAMBDA... (BAR :BAZ DREK))) is recorded in the database as") (* ;; "(ADDTO 'KEYCALLS '(BAR . :BAZ) '(BAR :BAZ DREK))") (* ;;  "i.e. there is a table for each keyword relating functions that call functions specifying them.") [LET [(LEGAL-KEYS (OR (CDR TEMPLATE) (GETRELATION (CAR PARENT) 'KEYACCEPT] (while X bind (ALLOW-OTHER-KEYS _ (MEMQ '&ALLOW-OTHER-KEYS LEGAL-KEYS)) KEYSUSED? do (if (AND (CL:KEYWORDP (CAR X)) (OR ALLOW-OTHER-KEYS (MEMQ (CAR X) LEGAL-KEYS))) then (ADDTO 'KEYSPECIFY (CAR X) PARENT) (SETQ KEYSUSED? T) else (* ; "log bogus keyword as ppe") (MSPRGERR PARENT)) (pop X) (if X then (MSPRGTEMPLATE1 (CAR X) 'EVAL) (pop X) else (MSPRGERR PARENT) (* ; "log no value for keyword as ppe") ) finally (if KEYSUSED? then (ADDTO 'KEYCALL (CAR PARENT) PARENT]) (COND ((LISTP X) (MSPRGTEMPLATE1 (CAR X) (CAR TEMPLATE)) (MSPRGTEMPLATE1 (CDR X) (CDR TEMPLATE]) (MSPRGTEMPLATE (LAMBDA (PARENT TEMPLATE PARENTCONTEXT) (* lmm "23-Jul-86 00:15") (BLOCK) (*  "Masterscope should block every once and a while. This is one place to do it.") (PROG ((VARS VARS) TEM) (COND ((EQ TEMPLATE 'MACRO) (COND ((SETQ TEM (GETMACROPROP (CAR PARENT) MSMACROPROPS)) (MSPRGMACRO PARENT TEM)) (T (MSPRGTEMPLATE1 PARENT '(CALL .. EVAL))))) (T (MSPRGTEMPLATE1 PARENT TEMPLATE)))))) (MSPRGLAMBDA [LAMBDA (EXPR FLG TYPE) (* ; "Edited 3-Jun-88 10:23 by jrb:") (SELECTQ (CAR (LISTP EXPR)) (CL:LAMBDA [LET ((PARENT EXPR) (PARENTCONTEXT TYPE) (VARS VARS)) [bind (ARGS _ (CADR EXPR)) ARG (EVALCOUNT _ 0) KEYS? KEYLIST while ARGS do (SETQ ARG (pop ARGS)) (* ;; "We can be in one of two states - keyword scanning or not") [COND [(CL:SYMBOLP ARG) (* ;; "Check and see if it's a keyword thingy") (COND ((EQ ARG '&KEY) (SETQ KEYS? T)) [(FMEMB ARG CL:LAMBDA-LIST-KEYWORDS) (SETQ KEYS? NIL) (if (EQ ARG '&ALLOW-OTHER-KEYS) then (ADDTO 'KEYACCEPT (CAR (push KEYLIST ' &ALLOW-OTHER-KEYS )) (CADR EXPR] (T (if KEYS? then (ADDTO 'KEYACCEPT (CAR (push KEYLIST (MAKE-KEYWORD ARG))) (CADR EXPR)) else (CL:INCF EVALCOUNT)) (MSBINDVAR ARG] [(CL:CONSP ARG) (* ;  "Strangely enough they all EVAL their CADRs.") (MSPRGTEMPLATE1 (CADR ARG) 'EVAL) (if KEYS? then (if (CL:SYMBOLP (CAR ARG)) then (MSBINDVAR (CAR ARG)) (ADDTO 'KEYACCEPT [CAR (push KEYLIST (MAKE-KEYWORD (CAR ARG] (CADR EXPR)) else (ADDTO 'KEYACCEPT [CAR (push KEYLIST (MAKE-KEYWORD (CAAR ARG] (CADR EXPR)) (MSBINDVAR (CADAR ARG))) else (CL:IF (CL:SYMBOLP (CAR ARG)) (MSBINDVAR (CAR ARG)) (MSBINDVAR (CADAR ARG))) (OR (NULL (CDDR ARG)) (NOT (CL:SYMBOLP (CADDR ARG))) (MSBINDVAR ARG] (T (MSPRGTEMPLATE1 ARG 'PPE] finally (if KEYLIST then (* ;;  "Look at old template; if there isn't one or it looks like one we put out") (* ;; "(of the form (EVAL* KEYWORDS keys...))") (* ;;  "replace it with a new template (and somehow mark everything that calls FNNAME for reanalysis") [LET ((OLDTEMP (GETTEMPLATE FNNAME)) (EC EVALCOUNT)) (* ;;  "First pop off all the EVALs at the front and count them") (while (EQ (CAR OLDTEMP) 'EVAL) do (CL:DECF EC) (pop OLDTEMP)) (if (OR (NULL OLDTEMP) (EQ (CAR OLDTEMP) 'KEYWORDS)) then (pop OLDTEMP) (if (AND (CL:ZEROP EC) (NULL (CL:SET-DIFFERENCE OLDTEMP KEYLIST )) (NULL (CL:SET-DIFFERENCE KEYLIST OLDTEMP ))) then (* ; "it matches, don't replace it") NIL else (* ;  "It looks like one of ours; replace it") (SETQ KEYLIST (CONS 'KEYWORDS (CL:NREVERSE KEYLIST))) (while (CL:PLUSP EVALCOUNT) do (push KEYLIST 'EVAL) (CL:DECF EVALCOUNT)) (SETTEMPLATE FNNAME KEYLIST) (* ;; "These templates shouldn't show up in FILES?, since they're solely for Masterscope internal use...") (UNMARKASCHANGED FNNAME 'TEMPLATES) (* ;; "The SETTEMPLATE call marked everyone who calls FNNAME to be reanalyzed; it also marked FNNAME - this gets rid of that") (PUTHASH FNNAME NIL MSCHANGEDARRAY] else (* ;; "It's possible that we created an old template for this function and it no longer has keywords, so we MAY need to delete it") (LET ((OLDTEMP (GETTEMPLATE FNNAME))) (while (EQ (CAR OLDTEMP) 'EVAL) do (pop OLDTEMP)) (if (EQ (CAR OLDTEMP) 'KEYWORDS) then (SETTEMPLATE FNNAME NIL) (* ;; "These templates shouldn't show up in FILES?, since they're solely for Masterscope internal use...") (UNMARKASCHANGED FNNAME 'TEMPLATES) (* ;; "The SETTEMPLATE call marked everyone who calls FNNAME to be reanalyzed; it also marked FNNAME - this gets rid of that") (PUTHASH FNNAME NIL MSCHANGEDARRAY] (MSPRGTEMPLATE1 (CDDR EXPR) '(|..| EVAL RETURN]) ([LAMBDA NLAMBDA OPENLAMBDA] (MSPRGTEMPLATE EXPR '(NIL (IF LISTP (|..| BIND) (IF (PROGN EXPR) BIND)) |..| EFFECT RETURN) TYPE)) (PROG (CLISP TEM) (COND ((AND (SETQ TEM (ASSOC (CAR EXPR) LAMBDATRANFNS)) (SETQ CLISP (CL:FUNCALL (CADR TEM) EXPR))) (PROG ((INCLISP (INCLISP EXPR))) (MSPRGLAMBDA CLISP FLG T))) ((AND DWIMFLG (SETQ CLISP (MSDWIMTRAN EXPR))) (* has a CLISP translation  (e.g. DLAMBDA)) (PROG ((INCLISP (INCLISP EXPR))) (* rebind INCLISP, and try again on  the translation) (MSPRGLAMBDA CLISP FLG TYPE))) (T (MSPRGERR EXPR) (MSPRGE EXPR]) (MSPRGLST (LAMBDA (L PARNT CNTX) (* lmm "27-JUN-78 01:57") (for X in L do (MSPRGE X PARNT CNTX)))) (ADDTO (LAMBDA (RELATION WHAT PRNT FLG) (* lmm "24-DEC-78 11:51") (PROG ((PTR (FASSOC RELATION MSFNDATA))) (OR PTR (COND (FLG (RETURN)) (T (SHOULDNT)))) (OR (NULL ONLYRELS) (FMEMB RELATION ONLYRELS) (RETURN)) (AND EACHTIME (EQMEMB RELATION (CAR EACHTIME)) (APPLY* (CADR EACHTIME) WHAT (CADDR EACHTIME) (CADDDR EACHTIME) PRNT INCLISP)) LP (COND ((NULL (CDR PTR)) (FRPLACD PTR (LIST WHAT))) ((EQ (CAR (SETQ PTR (CDR PTR))) WHAT) (RETURN)) (T (GO LP)))))) (NLAMBDAFNP (LAMBDA (FN) (* lmm "26-Mar-85 12:37") (AND (NOT (EQMEMB 'EVAL (GETPROP FN 'INFO))) (COND ((OR (FGETD (SETQ FN (OR (GETPROP FN 'BROKEN) FN))) (SETQ FN (GETLIS FN '(EXPR CODE)))) (* if the function is defined, check its argtype to tell you whether it is  NLAMBDA or LAMBDA) (SELECTQ (ARGTYPE FN) ((1 3) T) NIL)) (T (* otherwise, rely on NLAMA or NLAML) (OR (FMEMB FN NLAMA) (FMEMB FN NLAML))))))) (MSPRGDWIM [LAMBDA (X FN DEF) (* ; "Edited 8-Apr-88 11:55 by jrb:") (AND DWIMFLG (LET ((NOSPELLFLG T) FILEPKGFLG) (DECLARE (SPECVARS NOSPELLFLG)) (RESETVARS ((DWIMESSGAG T)) (* ;; "JRB Made these RESETVARS to placate the PavCompiler") (PROG (LISPXHIST) (* ASSERT%: ((REMOTE EVAL)  DWIMESSGAG FILEPKGFLG NOSPELLFLG)) (DWIMIFY0 X (OR (AND (LITATOM FN) FN) '?) VARS DEF]) (MSDWIMTRAN (LAMBDA (EXPR) (* DD%: "28-DEC-81 13:46") (AND DWIMFLG (COND ((AND CLISPARRAY (GETHASH EXPR CLISPARRAY))) ((AND CLISPTRANFLG (EQ (CAR (LISTP EXPR)) CLISPTRANFLG)) (CADR EXPR)) (T (MSPRGDWIM EXPR FNNAME FNDEF) (OR (AND CLISPARRAY (GETHASH EXPR CLISPARRAY)) (AND CLISPTRANFLG (EQ (CAR (LISTP EXPR)) CLISPTRANFLG) (CADR EXPR)))))))) ) (RPAQQ MSFNDATA ((BIND) (CALL) (EFFECT) (PREDICATE) (CLISP) (PROP) (SETFREE) (SET) (SMASHFREE) (SMASH) (REFFREE) (REF) (FETCH) (REPLACE) (RECORD) (ERROR) (ARG) (CREATE) (LOCALVARS) (SPECVARS) (APPLY) (TESTFREE) (TEST) (LOCALFREEVARS) [NLAMBDA] (TYPE) (STACK) (KEYACCEPT) (KEYSPECIFY) (KEYCALL) (FLET) (LABEL) (MACROLET) (COMPILER-LET))) (RPAQQ MSERRORFN ppe) (RPAQQ MSRECORDTRANFLG NIL) (ADDTOVAR INVISIBLEVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS INCLISP MACRO ((.X.) (COND ((AND INCLISP EACHTIME (NOT (MSFINDP INCLISP .X.))) INCLISP) (T .X.)))) (PUTPROPS LTEMPLATE MACRO [LAMBDA (Y) (DECLARE (LOCALVARS Y)) (AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES) (GETHASH Y MSTEMPLATES] Y]) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: ALLCALLS ALLCALLS ADDTO MSBINDVAR MSDWIMTRAN MSPRGCALL MSPRGDWIM MSPRGE MSPRGMACRO MSPRGERR MSPRGLAMBDA MSPRGLST MSPRGRECORD MSPRGTEMPLATE MSPRGTEMPLATE1 NLAMBDAFNP (NOLINKFNS . T) (LOCALFREEVARS FNNAME ERRORS FNDEF INCLISP ONLYRELS PARENTCONTEXT TOPVARS PARENT EACHTIME VARS ) (GLOBALVARS CLISPARRAY MSERRORFN MSRECORDTRANFLG MSFNDATA INVISIBLEVARS CLISPARRAY MSTEMPLATES USERTEMPLATES MSRECORDTRANFLG NLAMA NLAML DWIMFLG CLISPTRANFLG DWIMESSGAG) (NOLINKFNS . T)) (BLOCK%: NIL MSINITFNDATA NLAMBDAFNP MSPRGDWIM (LOCALVARS . T) (GLOBALVARS NLAMA NLAML MSFNDATA DWIMFLG DWIMESSGAG)) ) [PUTDQ? MSWORDNAME (LAMBDA (X) X] (RPAQ MSTEMPLATES (HASHARRAY 160)) (RPAQ USERTEMPLATES (HASHARRAY 10)) (RPAQQ INITIALTEMPLATES (((CALL (REMOTE (IF LITATOM CALL LAMBDA)) (IF LITATOM EVAL NIL)) FUNCTION) ((NIL NIL |..| EVAL RETURN) CL:BLOCK) ((CALL |..| EVAL) CL:CATCH CL:THROW) ((NIL NIL EVAL) CL:RETURN-FROM) ([IF (EQ (CADR EXPR) 'ASSERT%:) (NIL NIL |..| (IF LISTP (@ (CDR EXPR) (LIST '|..| (MSWORDNAME (CAR EXPR] *) ((NIL (BOTH (|..| (IF LISTP (NIL EVAL |..| EFFECT) NIL)) (|..| (IF LISTP (BIND) BIND))) |..| EFFECT RETURN) LET CL:COMPILER-LET) ((NIL (|..| (IF LISTP (BIND EVAL . PPE) BIND)) |..| EFFECT RETURN) LET*) ((NIL |..| (IF LISTP EFFECT)) CL:TAGBODY) ((NIL (BOTH (|..| (IF LISTP (NIL EVAL |..| EFFECT) NIL)) (|..| (IF LISTP (BIND) BIND))) |..| (IF LISTP EFFECT)) PROG) (MACRO RESETVARS) ((CALL EVAL) XNLSETQ NLSETQ ERSETQ) ((CALL |..| EVAL) RESETFORM FRPTQ) ((CALL EVAL EVAL FUNCTIONAL FUNCTIONAL . PPE) MAP2C) ((CALL EVAL EVAL SMASH . PPE) /DSUBST DSUBST) ((CALL EVAL FUNCTION FUNCTION . PPE) MAPCAR MAPCON MAPCONC MAPLIST SUBSET EVERY NOTEVERY ANY NOTANY SOME MAPC MAP) ((CALL EVAL FUNCTIONAL . PPE) MAPHASH) ((CALL EVAL PROP . PPE) GETP GETLIS GET GETPROP LISTGET LISTGET1 REMPROP /REMPROP) ((CALL EVAL PROP EVAL . PPE) PUT /PUT PUTPROP /PUTPROP LISTPUT LISTPUT1) ((CALL EVAL SMASH . PPE) /ATTACH ATTACH) ((CALL FUNCTIONAL . PPE) MAPATOMS) ((CALL FUNCTIONAL |..| EVAL) APPLY* BLKAPPLY* APPLY BLKAPPLY) ((CALL EVAL SMASH . PPE) DREMOVE /DREMOVE) ((CALL SET EVAL EVAL . PPE) RESETVAR) ((CALL SET EVAL . PPE) SETN) ((CALL SMASH . PPE) DREVERSE) ((CALL SMASH EVAL . PPE) RPLACD /RPLACD RPLACA /RPLACA RPLNODE2 /RPLNODE2 FRPLACD FRPLNODE2 TCONC /TCONC LCONC /LCONC NCONC1 /NCONC1 FRPLACA) ((CALL SMASH EVAL EVAL . PPE) RPLNODE FRPLNODE /RPLNODE) ((CALL SMASH FUNCTIONAL . PPE) SORT) ((CALL (BOTH SET EVAL) . PPE) ADD1VAR SUB1VAR) ((CALL (IF NULL NIL (IF ATOM SET EVAL)) EVAL . PPE) RESETSAVE) ((CALL (IF (EQ (CAR (LISTP EXPR)) 'QUOTE) (NIL SET) EVAL) EVAL . PPE) SET /SET SETTOPVAL /SETTOPVAL SETATOMVAL /SETATOMVAL) ((CALL (IF (EQ (CAR (LISTP EXPR)) 'QUOTE) (NIL SET) EVAL) EVAL EVAL EVAL . PPE) SAVESET) ((CALL (IF (EQ (CAR (LISTP EXPR)) 'QUOTE) (NIL EVAL) EVAL) |..| EVAL) GETATOMVAL EVAL EVALV) ((NIL |..| TESTRETURN RETURN) OR) ((NIL |..| TEST RETURN) AND) ((NIL |..| EFFECT RETURN) PROGN) ((NIL TEST RETURN RETURN) CL:IF) ((NIL |..| (IF CDR (TEST |..| EFFECT RETURN) (TESTRETURN . PPE))) COND) ([CALL |..| (@ EXPR (CONS NIL (SELECTQ (CAR (LISTP EXPR)) (LOCALVARS '(IF LISTP (|..| LOCALVARS) LOCALVARS)) (SPECVARS '(IF LISTP (|..| SPECVARS) SPECVARS)) NIL] DECLARE) ((NIL RETURN) CLISP% ) ((NIL EVAL . PPE) LISTP NLISTP RETURN) ((NIL TEST . PPE) NOT NULL) ((CALL EVAL |..| (NIL |..| EFFECT RETURN) RETURN) SELECTQ SELCHARQ) ((CALL EVAL |..| (EVAL |..| EFFECT RETURN) RETURN) SELECTC) ((CALL EVAL |..| ((IF LISTP (|..| EVAL) EVAL) |..| EFFECT RETURN) RETURN) SELECT) ((NIL EVAL EVAL . PPE) EQ NEQ) ((NIL NIL . PPE) QUOTE GO) ((NIL EVAL . PPE) CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CDAAR CADDR CDADR CDDAR CDDDR CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR) ((NIL RETURN |..| EFFECT) PROG1) ((NIL SET NIL . PPE) SETQQ) ((NIL SET EVAL . PPE) SETQ ADV-SETQ SAVESETQ) ([@ EXPR (CONS NIL (MAPCON (CDR EXPR) [FUNCTION (LAMBDA (X) (if (LITATOM (CAR X)) then (LIST 'SET 'EVAL) else (LIST 'SMASH 'EVAL] (FUNCTION (LAMBDA (X) (CDDR X] CL:SETQ CL:SETF) ((CALL EVAL (BOTH (@ 'RPTN 'BIND) RETURN) . PPE) RPTQ) ((CALL EVALQT |..| EVAL) EVAL ERRORSET) ((BOTH [IF (EQ (CAR (LISTP (CADDR EXPR))) 'QUOTE) (NIL NIL (NIL (|..| (BIND] (CALL EVALQT EVAL . PPE)) EVALA) ((CALL EVALQT STACK STACK EVAL EVAL . PPE) ENVEVAL) ((CALL FUNCTIONAL EVALQT STACK STACK EVAL EVAL . PPE) ENVAPPLY) ((CALL STACK EVAL EVAL EVAL . PPE) STKAPPLY) ((CALL STACK EVALQT EVAL EVAL . PPE) RETEVAL STKEVAL) ((CALL STACK EVAL EVAL . PPE) RETFROM RETTO) ((NIL NIL RETURN) THE))) (* ;;; "INITIALTEMPLATES is not needed after loading up") [MAPC INITIALTEMPLATES (FUNCTION (LAMBDA (X) (MAPC (CDR X) (FUNCTION (LAMBDA (Y) (PUTHASH Y (CAR X) MSTEMPLATES] (DECLARE%: EVAL@COMPILE DONTCOPY (PUTPROPS LTEMPLATE MACRO [LAMBDA (Y) (DECLARE (LOCALVARS Y)) (AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES) (GETHASH Y MSTEMPLATES] Y]) ) (DEFINEQ (MSFINDP (LAMBDA (STRUC SUB) (* lmm "14-Aug-84 16:38") (PROG NIL LP (RETURN (OR (EQ SUB STRUC) (AND (LISTP STRUC) (OR (MSFINDP (CAR STRUC) SUB) (PROGN (SETQ STRUC (CDR STRUC)) (GO LP))))))))) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSFINDP MSFINDP) ) (PUTPROPS MSANALYZE COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3790 11309 (VARS 3800 . 3941) (FREEVARS 3943 . 4096) (CALLS 4098 . 10439) ( COLLECTFNDATA 10441 . 10820) (CALLS3 10822 . 11307)) (13562 52644 (ALLCALLS 13572 . 14251) ( MSINITFNDATA 14253 . 14497) (MSPRGE 14499 . 21573) (MSPRGMACRO 21575 . 22066) (MSPRGCALL 22068 . 22392 ) (MSBINDVAR 22394 . 22913) (MSPRGRECORD 22915 . 29828) (MSPRGERR 29830 . 29998) (MSPRGTEMPLATE1 30000 . 39161) (MSPRGTEMPLATE 39163 . 39843) (MSPRGLAMBDA 39845 . 49440) (MSPRGLST 49442 . 49610) (ADDTO 49612 . 50403) (NLAMBDAFNP 50405 . 51157) (MSPRGDWIM 51159 . 51978) (MSDWIMTRAN 51980 . 52642)) (61970 62397 (MSFINDP 61980 . 62395))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-Mar-2021 10:31:16" {DSK}larry>ilisp>medley>library>MSANALYZE.;2 62577 changes to%: (VARS MSMACROPROPS) previous date%: "15-Aug-90 13:13:24" {DSK}larry>ilisp>medley>library>MSANALYZE.;1) (* ; " Copyright (c) 1982-1986, 1988, 1990, 2021 by Venue & Xerox Corporation. The following program was created in 1982 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 MSANALYZECOMS) (RPAQQ MSANALYZECOMS [(PROP FILETYPE MSANALYZE) (COMS (FNS VARS FREEVARS CALLS COLLECTFNDATA CALLS3) (VARS MSMACROPROPS (NOPACKCALLSFLG)) (BLOCKS (CALLS CALLS COLLECTFNDATA CALLS3 (LOCALFREEVARS CALLSDATA) (NOLINKFNS . T) (GLOBALVARS INVISIBLEVARS COMPILEUSERFN NOPACKCALLSFLG LAMBDASPLST MSRECORDTRANFLG)) (NIL VARS FREEVARS (LOCALVARS . T))) (DECLARE%: EVAL@COMPILE (VARS MS.VERB.TO.NOTICED) DONTCOPY (MACROS MSVBNOTICED))) [COMS (FNS ALLCALLS MSINITFNDATA MSPRGE MSPRGMACRO MSPRGCALL MSBINDVAR MSPRGRECORD MSPRGERR MSPRGTEMPLATE1 MSPRGTEMPLATE MSPRGLAMBDA MSPRGLST ADDTO NLAMBDAFNP MSPRGDWIM MSDWIMTRAN) (E (MAPC MSFNDATA (FUNCTION RPLACD))) (VARS MSFNDATA MSERRORFN (MSRECORDTRANFLG)) (ADDVARS (INVISIBLEVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17)) (DECLARE%: DONTCOPY (MACROS INCLISP LTEMPLATE)) (BLOCKS (ALLCALLS ALLCALLS ADDTO MSBINDVAR MSDWIMTRAN MSPRGCALL MSPRGDWIM MSPRGE MSPRGMACRO MSPRGERR MSPRGLAMBDA MSPRGLST MSPRGRECORD MSPRGTEMPLATE MSPRGTEMPLATE1 NLAMBDAFNP (NOLINKFNS . T) (LOCALFREEVARS FNNAME ERRORS FNDEF INCLISP ONLYRELS PARENTCONTEXT TOPVARS PARENT EACHTIME VARS) (GLOBALVARS CLISPARRAY MSERRORFN MSRECORDTRANFLG MSFNDATA INVISIBLEVARS CLISPARRAY MSTEMPLATES USERTEMPLATES MSRECORDTRANFLG NLAMA NLAML DWIMFLG CLISPTRANFLG DWIMESSGAG) (NOLINKFNS . T)) (NIL MSINITFNDATA NLAMBDAFNP MSPRGDWIM (LOCALVARS . T) (GLOBALVARS NLAMA NLAML MSFNDATA DWIMFLG DWIMESSGAG))) (P (PUTDQ? MSWORDNAME (LAMBDA (X) X] (COMS (VARS (MSTEMPLATES (HASHARRAY 160)) (USERTEMPLATES (HASHARRAY 10))) (FILEVARS INITIALTEMPLATES) (* ;;; "INITIALTEMPLATES is not needed after loading up") [P (MAPC INITIALTEMPLATES (FUNCTION (LAMBDA (X) (MAPC (CDR X) (FUNCTION (LAMBDA (Y) (PUTHASH Y (CAR X) MSTEMPLATES] (DECLARE%: EVAL@COMPILE DONTCOPY (PROP MACRO LTEMPLATE))) (COMS (FNS MSFINDP) (BLOCKS (MSFINDP MSFINDP]) (PUTPROPS MSANALYZE FILETYPE :COMPILE-FILE) (DEFINEQ (VARS (LAMBDA (FN USEDATABASE) (* lmm%: 29-DEC-75 23 22) (CDR (CALLS FN USEDATABASE T)))) (FREEVARS (LAMBDA (FN USEDATABASE) (* lmm%: 5-DEC-75 11 8) (CADDR (CALLS FN USEDATABASE 'FREEVARS)))) (CALLS [LAMBDA (EXPR USEDATABASE VARSFLG) (* ; "Edited 12-Jun-90 17:25 by teruuchi") (* ;  "This FNS is for the User Interface Function in MSANALYZE(MasterScope)") (* ;  "Edited by Tomoru Teruuchi(12-June-90 : for AR#10020)") (PROG (FREES (GLOBALS NIL) FNDEF FLG) [COND ((AND USEDATABASE (LITATOM EXPR) (GETD 'UPDATEFN)) (UPDATEFN EXPR NIL 'ERROR) [SETQ FREES (GETRELATION EXPR '(USE FREELY] [SETQ FREES (SUBSET FREES (FUNCTION (LAMBDA (VAR) (* ;  "This Function is The Predicate whether the variable is global or not.") (if (OR (FMEMB VAR GLOBALVARS) (EQ (GETPROP VAR 'GLOBALVAR) T)) then (pushnew GLOBALS VAR) NIL else T] (* ;  "Edited by TT (Date : 8-May-1990)") (RETURN (LIST [AND (NOT VARSFLG) (GETRELATION EXPR '(CALL NOTERROR] (AND (NEQ VARSFLG 'FREEVARS) (GETRELATION EXPR 'BIND)) FREES GLOBALS] GETDLP (SETQ FNDEF (COND [(LITATOM EXPR) (OR (GETD (OR (GETP EXPR 'BROKEN) EXPR)) (GETP EXPR 'EXPR) (AND (NEQ EXPR (SETQ EXPR (FNCHECK EXPR NIL NIL T))) (GO GETDLP] (T EXPR))) (RETURN (COND ((NULL FNDEF) NIL) ((SUBRP FNDEF) NIL) ((CCODEP FNDEF) (SETQ FNDEF (CALLSCCODE FNDEF)) [OR NOPACKCALLSFLG (for X on (CAR FNDEF) do (FRPLACA X (PACK* '; (CAR X) ';] (FRPLACA (CDR FNDEF) (NCONC (CADR FNDEF) (CAR FNDEF))) (SETQ FLG) (CALLS3 (CDDR FNDEF)) (CALLS3 (CDDDR FNDEF)) (CDR FNDEF)) [(EXPRP FNDEF) (* Note that EXPR can be a piece of a function definition, and calls will still  work.) (RESETVARS ((MSRECORDTRANFLG T)) (RETURN (PROG (CALLSDATA LAMFLG) [COND ((FMEMB (CAR FNDEF) LAMBDASPLST) (SETQ LAMFLG T) (COND ((OR (AND (EQ (CAR (CADDR FNDEF)) '*) (EQ (CADR (CADDR FNDEF)) 'DECLARATIONS%:)) (EQ (CAR (CADDR FNDEF)) 'CLISP%:)) (MSPRGDWIM FNDEF EXPR FNDEF))) (SELECTQ (CAR FNDEF) ([LAMBDA NLAMBDA] NIL) (SETQ FNDEF (OR (AND COMPILEUSERFN (APPLY* COMPILEUSERFN NIL FNDEF)) FNDEF] (SETQ CALLSDATA (ALLCALLS FNDEF LAMFLG [UNION (CONSTANT (MSVBNOTICED 'USE 'FREELY)) (AND (NEQ VARSFLG 'FREEVARS) (UNION (CONSTANT (MSVBNOTICED 'BIND)) (AND (NULL VARSFLG) (CONSTANT (MSVBNOTICED 'CALL 'NOTERROR] EXPR T)) [SETQ FREES (NCONC FREES (COLLECTFNDATA (CONSTANT (MSVBNOTICED 'USE 'FREELY] [SETQ FREES (SUBSET FREES (FUNCTION (LAMBDA (VAR) (if (OR (FMEMB VAR GLOBALVARS) (EQ (GETPROP VAR 'GLOBALVAR) T)) then (pushnew GLOBALS VAR) NIL else T] (* ;  "Edited by TT (Date : 8-May-1990)") (RETURN (LIST [COLLECTFNDATA (CONSTANT (MSVBNOTICED 'CALL 'NOTERROR] [COLLECTFNDATA (CONSTANT (MSVBNOTICED 'BIND] FREES GLOBALS] (T '?]) (COLLECTFNDATA (LAMBDA (LST) (* lmm "21-DEC-78 22:56") (COND ((NLISTP LST) (CDR (FASSOC LST CALLSDATA))) (T (PROG (VAL) (for X in LST do (SETQ VAL (UNION (COLLECTFNDATA X) VAL))) (RETURN VAL)))))) (CALLS3 (LAMBDA (LST) (* lmm " 6-JUL-78 00:23") (* lmm%: 13-DEC-75 4 51) (PROG (FLG) (for X on (CAR LST) do (OR (NOT (FMEMB (CAR X) INVISIBLEVARS)) (SETQ FLG (FRPLACA X)))) (COND (FLG (FRPLACA LST (DREMOVE NIL (CAR LST)))))))) ) (RPAQQ MSMACROPROPS (ALTOMACRO DMACRO BYTEMACRO MACRO MACRO-FN)) (RPAQQ NOPACKCALLSFLG NIL) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: CALLS CALLS COLLECTFNDATA CALLS3 (LOCALFREEVARS CALLSDATA) (NOLINKFNS . T) (GLOBALVARS INVISIBLEVARS COMPILEUSERFN NOPACKCALLSFLG LAMBDASPLST MSRECORDTRANFLG)) (BLOCK%: NIL VARS FREEVARS (LOCALVARS . T)) ) (DECLARE%: EVAL@COMPILE (RPAQQ MS.VERB.TO.NOTICED ((BIND (NIL BIND ARG)) [CALL (DIRECTLY CALL EFFECT PREDICATE NLAMBDA) (EFFECT EFFECT) (INDIRECTLY APPLY STACK) (NIL CALL ERROR APPLY EFFECT PREDICATE NLAMBDA STACK) (NOTERROR APPLY CALL EFFECT PREDICATE NLAMBDA STACK) (PREDICATE PREDICATE) (TESTING PREDICATE) (VALUE CALL) (NLAMBDA NLAMBDA] (CREATE (NIL CREATE)) (DECLARE (LOCALVARS LOCALVARS) (NIL LOCALVARS SPECVARS) (SPECVARS SPECVARS)) (FETCH (NIL FETCH)) (REFERENCE (FIELDS FETCH) (FREELY REFFREE) (CL:LOCALLY REF) (NIL REFFREE REF)) (REPLACE (NIL REPLACE)) (SET (FIELDS FETCH REPLACE) (FREELY SETFREE) (CL:LOCALLY SET) (NIL SETFREE SET)) (SMASH (FIELDS FETCH REPLACE) (FREELY SMASHFREE) (CL:LOCALLY SMASH) (NIL SMASHFREE SMASH)) (TEST (FREELY TESTFREE) (CL:LOCALLY TEST) (NIL TESTFREE TEST)) (USE (FIELDS FETCH REPLACE) (FREELY SETFREE SMASHFREE REFFREE TESTFREE) (I.S.OPRS CLISP) (INDIRECTLY LOCALFREEVARS) (CL:LOCALLY SET SMASH REF TEST) (NIL SETFREE SET SMASHFREE SMASH REFFREE REF TESTFREE TEST) (PREDICATE TEST TESTFREE) (PROPNAMES PROP) (RECORDS RECORD CREATE) (TESTING TEST TESTFREE) (VALUE SMASH SMASHFREE REF REFFREE) (TYPE TYPE)))) DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS MSVBNOTICED MACRO [OPENLAMBDA (VERB MOD) (CDR (ASSOC MOD (CDR (ASSOC VERB MS.VERB.TO.NOTICED]) ) ) (DEFINEQ (ALLCALLS [LAMBDA (FNDEF LAMFLG ONLYRELS FNNAME INTERNALFLG EACHTIME) (* ; "Edited 21-Apr-88 16:31 by jrb:") (LET (VARS TOPVARS INCLISP ERRORS (PARENT FNDEF) (NOSPELLFLG T)) (DECLARE (CL:SPECIAL NOSPELLFLG)) (MSINITFNDATA) [COND (LAMFLG (MSPRGLAMBDA FNDEF 'ARG)) (T (MSPRGE FNDEF NIL 'RETURN] (COND (INTERNALFLG MSFNDATA) (T (for X in MSFNDATA when (CDR X) collect (CONS (CAR X) (CDR X]) (MSINITFNDATA (LAMBDA NIL (* MSFNDATA is an association list of the "noticed" types, e.g.  CALL, BIND, etc. -- the FRPLACD resets the pointer) (for Y in MSFNDATA do (FRPLACD Y NIL)))) (MSPRGE (LAMBDA (EXPR SUPEXPR EVALCONTEXT) (* lmm "27-May-86 04:44") (* ;; "analyzes EXPR; SUPEXPR is the parent expression and is used in the SHOWUSE case where we are printing occurrances of various things rather than updating data base; EVALCONTEXT is a type of reference for this expression from the template: SMASH etc") (PROG (TEM CALLED CLISP) (COND ((NLISTP EXPR) (RETURN (COND ((AND (LITATOM EXPR) EXPR (NEQ EXPR T) (NOT (FMEMB EXPR INVISIBLEVARS))) (* ; "A variable reference") (COND ((OR (FMEMB EXPR VARS) (SOME TOPVARS (FUNCTION (LAMBDA (Z) (* ;  "bound higher up in the function but but used in a functional argument") (COND ((FMEMB EXPR Z) (ADDTO 'LOCALFREEVARS EXPR SUPEXPR) T)))))) (* ;  "Things were added to VARS only if they were 'noticeable'") (SELECTQ EVALCONTEXT ((SMASH TEST SET) (ADDTO EVALCONTEXT EXPR SUPEXPR)) (CHANGE (ADDTO 'SET EXPR SUPEXPR)) (ADDTO 'REF EXPR SUPEXPR))) (T (SELECTQ EVALCONTEXT (SMASH (ADDTO 'SMASHFREE EXPR SUPEXPR)) (TEST (ADDTO 'TESTFREE EXPR SUPEXPR)) ((SET CHANGE) (ADDTO 'SETFREE EXPR SUPEXPR)) (ADDTO 'REFFREE EXPR SUPEXPR))))))))) (COND ((EQ EVALCONTEXT 'SET) (* ; "in a 'SET' context, but not a variable") (MSPRGERR PARENT))) (COND ((LISTP (SETQ CALLED (CAR EXPR))) (MSPRGLAMBDA CALLED NIL (SELECTQ EVALCONTEXT ((TEST EFFECT SMASH) EVALCONTEXT) NIL)) (SELECTQ (CAR CALLED) (LAMBDA (MSPRGLST (CDR EXPR) EXPR)) NIL) (RETURN))) (COND ((SETQ TEM (LTEMPLATE CALLED)) (RETURN (MSPRGTEMPLATE EXPR TEM EVALCONTEXT)))) (COND ((NOT (FGETD (OR (GETP CALLED 'BROKEN) CALLED))) (COND ((AND DWIMFLG (SETQ TEM (GETPROP CALLED 'CLISPWORD))) (* E.G. IF, FOR, etc.) (SETQ CLISP (MSDWIMTRAN EXPR)) (RETURN (COND (CLISP (COND (TEM (SELECTQ (CAR TEM) (RECORDTRAN (OR (MSPRGRECORD EXPR EVALCONTEXT) MSRECORDTRANFLG (RETURN)) (* optionally also look at translation) ) (IFWORD) (CHANGETRAN (MSPRGE (CADR EXPR) EXPR 'CHANGE)) (for X in EXPR when (AND (LITATOM X) (EQ (CAR TEM) (CAR (GETPROP X 'CLISPWORD)))) do (ADDTO 'CLISP X EXPR))))) (* Analyze the CLISP translation) (PROG ((INCLISP (INCLISP EXPR))) (MSPRGE CLISP EXPR EVALCONTEXT))) ((OR (NULL (GETPROP (CAR EXPR) 'CLISPWORD)) (NEQ (CAR EXPR) CALLED)) (RETURN (MSPRGE EXPR SUPEXPR EVALCONTEXT))) (T (SELECTQ (CAR TEM) (RECORDTRAN (MSPRGRECORD EXPR EVALCONTEXT)) (CHANGETRAN (MSPRGE (CADR EXPR) EXPR 'CHANGE) (MSPRGLST (CDDR EXPR) EXPR)) (PROGN (* CLISP word wouldn't DWIMIFY) (MSPRGCALL CALLED EXPR EVALCONTEXT) (MSPRGERR EXPR) (MSPRGLST (CDR EXPR) EXPR))))))) ((SETQ TEM (CL:MACRO-FUNCTION CALLED)) (LET ((ME (CL:MACROEXPAND EXPR))) (COND ((AND (NOT (EQUAL ME EXPR)) (NOT (EQUAL ME INCLISP))) (MSPRGCALL (CAR EXPR) EXPR EVALCONTEXT) (PROG ((INCLISP (INCLISP EXPR)) (EXPR EXPR)) (MSPRGE ME EXPR 'EVAL)) (RETURN T)))))))) (COND ((NLAMBDAFNP CALLED) (ADDTO 'NLAMBDA CALLED EXPR) (COND ((AND MSMACROPROPS (SETQ TEM (GETMACROPROP CALLED MSMACROPROPS)) (MSPRGMACRO EXPR TEM EVALCONTEXT)) (RETURN))) (MSPRGCALL CALLED EXPR EVALCONTEXT)) (T (* ; "normal lambda function call") (MSPRGCALL CALLED EXPR EVALCONTEXT) (MSPRGLST (CDR EXPR) EXPR 'EVAL)))))) (MSPRGMACRO (LAMBDA (FORM MACDEF CONTEXT) (* lmm "13-DEC-82 23:45") (PROG ((ME (MACROEXPANSION FORM MACDEF))) (COND ((AND (NOT (EQUAL ME FORM)) (NOT (EQUAL ME INCLISP))) (MSPRGCALL (CAR FORM) FORM CONTEXT) (PROG ((INCLISP (INCLISP FORM)) (EXPR FORM)) (MSPRGE ME FORM 'EVAL)) (RETURN T)))))) (MSPRGCALL (LAMBDA (FN PRNT CONTEXT) (* lmm "22-DEC-78 12:57") (ADDTO (COND (TOPVARS 'APPLY) (T (SELECTQ CONTEXT (TEST 'PREDICATE) (EFFECT 'EFFECT) 'CALL))) FN PRNT))) (MSBINDVAR (LAMBDA (VAR TYPE EXPR) (* lmm " 6-JUL-78 00:23") (COND ((AND VAR (LITATOM VAR) (NEQ VAR T)) (COND ((NOT (FMEMB VAR INVISIBLEVARS)) (ADDTO (OR TYPE 'BIND) VAR (OR EXPR PARENT)))) (SETQ VARS (CONS VAR VARS))) (T (MSPRGERR (COND ((LITATOM VAR) (OR EXPR PARENT)) (T VAR))))))) (MSPRGRECORD [LAMBDA (PRNT CNTXT) (* ; "Edited 8-Apr-88 14:49 by jrb:") (* ANALYZE RECORD EXPRESSION PRNT -  RETURN NIL IF ANALYZED SUCCESSFULLY) (PROG (Z) (MSPRGTEMPLATE PRNT (SELECTQ (CAR PRNT) ((create CREATE) (ADDTO 'CREATE (CADR PRNT) PRNT) (SETQ Z (CDDR PRNT)) [while Z do (COND ([EQ 'RECORDTRAN (CAR (GETPROP (CAR Z) 'CLISPWORD] (* e.g. USING or COPYING) (MSPRGE (CADR Z) PRNT (SELECTQ (CAR Z) ((smashing SMASHING) 'SMASH) NIL)) (SETQ Z (CDDR Z))) ((EQ (CADR Z) '_) (* If dwimified correctly, the fields should be separated by _'s) (ADDTO 'REPLACE (CAR Z) PRNT) (MSPRGE (CADDR Z) PRNT) (SETQ Z (CDDDR Z))) ((EQ (CAAR Z) 'SETQ) (* partially dwimified) (ADDTO 'REPLACE (CADAR Z) PRNT) (MSPRGE (CADDAR Z) PRNT) (SETQ Z (CDR Z))) (T (* shouldn't happen, but) (MSPRGE (CAR Z) PRNT) (SETQ Z (CDR Z] (RETURN)) ((fetch FETCH ffetch FFETCH) [LET [(OF? (OR (EQ (CL:THIRD PRNT) 'OF) (EQ (CL:THIRD PRNT) 'of] (COND [(EQ CNTXT 'CHANGE) `(NIL (IF LISTP (BOTH (NIL |..| FETCH (BOTH FETCH REPLACE)) (|..| RECORD NIL)) (BOTH FETCH REPLACE)) ,@(if OF? then '(NIL EVAL |..| PPE) else '(EVAL |..| PPE] (T `(NIL (IF LISTP (BOTH (NIL |..| FETCH) (|..| RECORD NIL)) FETCH) ,@(if OF? then '(NIL EVAL |..| PPE) else '(EVAL |..| PPE]) ((REPLACE /REPLACE replace /replace freplace FREPLACE) (LET* [[OF? (OR (EQ (CL:THIRD PRNT) 'OF) (EQ (CL:THIRD PRNT) 'of] (WITHSLOT (if OF? then (CL:FIFTH PRNT) else (CL:FOURTH PRNT))) (WITH? (OR (EQ WITHSLOT 'WITH) (EQ WITHSLOT 'with] `(NIL (IF LISTP (BOTH (NIL |..| FETCH REPLACE) (|..| RECORD NIL)) REPLACE) ,@(if OF? then '(NIL) else NIL) SMASH ,@(if WITH? then '(NIL) else NIL) EVAL))) ((type? TYPE?) '(CLISP RECORD EVAL . PPE)) ((initrecord INITRECORD) '(CLISP RECORD . PPE)) ((WITH with) [COND ((SETQ Z (RECORDFIELDNAMES (CADR PRNT))) (ADDTO 'RECORD (CADR PRNT) PRNT) (MSPRGE (CADDR PRNT) PRNT) (for X in (PROG1 [for X on MSFNDATA when (FMEMB (CAAR X) '(SETFREE TESTFREE REFFREE)) collect (LIST (CAR X) (RPLACA X (LIST (CAAR X] (PROG [ONLYRELS (EACHTIME (AND EACHTIME (for X inside (PROGN EACHTIME) when [NOT (FMEMB X '(SETFREE TESTFREE REFFREE] collect X] (MSPRGLST (CDDDR PRNT) PRNT))) do (for Y in (PROG1 (CDR (CAADR X)) (RPLACA (CADR X) (CAR X))) do (ADDTO (COND ((FMEMB Y Z) (SELECTQ (CAAR X) (SETFREE 'REPLACE) 'FETCH)) (T (CAAR X))) Y PRNT))) (RETURN)) (T '(RECORD |..| EVAL]) (RETURN T]) (MSPRGERR (LAMBDA (EXPR) (* lmm "21-DEC-78 22:44") (SETQ ERRORS T) (ADDTO 'ERROR MSERRORFN EXPR))) (MSPRGTEMPLATE1 [LAMBDA (X TEMPLATE) (* ; "Edited 19-Feb-88 16:56 by jrb:") (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE ((EVAL SMASH TEST EFFECT SET) (MSPRGE X PARENT TEMPLATE)) ((FUNCTION FUNCTIONAL) (* This is a functional arg to something -  the marker FUNCTIONAL means that it will be a separate function while  FUNCTION is reserved for those things which compile open -  e.g. MAPC is marked (EVAL FUNCTION FUNCTION . PPE) while SORT is marked  (EVAL FUNCTIONAL . PPE)) [OR (COND ((AND (LISTP X) (NULL (CDDR X))) (COND ((EQ (CAR X) 'F/L) (MSPRGDWIM X FNNAME FNDEF))) (SELECTQ (CAR X) ((FUNCTION QUOTE) (MSPRGTEMPLATE (CADR X) (COND ((LISTP (CADR X)) (SELECTQ TEMPLATE (FUNCTIONAL '(REMOTE LAMBDA)) 'LAMBDA)) ((OR (NEQ (CAR X) 'FUNCTION) (EQ TEMPLATE 'FUNCTIONAL)) '(REMOTE CALL)) (T 'CALL)) X) T) NIL))) (EQ X T) (NULL X) (PROGN (* arbitrary expression as  functional argument) (ADDTO 'ERROR 'apply PARENT) (MSPRGE X PARENT 'FUNCTIONAL]) (STACK (* arg to stack fn, e.g.  RETFROM) [OR (AND (LISTP X) (SELECTQ (CAR X) ((FUNCTION QUOTE) (ADDTO 'STACK (CADR X) PARENT) T) NIL)) (PROGN (ADDTO 'ERROR 'stackfn PARENT) (MSPRGE X PARENT 'EVAL]) (PROP (COND ((AND (LISTP X) (EQ (CAR X) 'QUOTE)) (for Y inside (CADR X) do (ADDTO 'PROP Y PARENT))) (T (MSPRGE X PARENT TEMPLATE)))) (NIL (* not used) NIL) (RETURN (* this is sometimes the value of  PARENT expression) (MSPRGTEMPLATE1 X (SELECTQ PARENTCONTEXT ((TEST EFFECT) PARENTCONTEXT) 'EVAL))) (TESTRETURN (* if PARENT is tested, then so is  this) (MSPRGTEMPLATE1 X (SELECTQ PARENTCONTEXT (TEST PARENTCONTEXT) 'EVAL))) (BIND (MSBINDVAR X)) (LAMBDA (MSPRGLAMBDA X)) (PPE (* paren error if not NIL) (COND (X (MSPRGERR PARENT) (MSPRGLST X PARENT)))) (CALL (MSPRGCALL X PARENT PARENTCONTEXT)) (EVALQT [COND ((EQ (CAR X) 'QUOTE) (MSPRGTEMPLATE (CADR X) '(REMOTE EVAL) PARENT)) (T (MSPRGE X PARENT 'EVAL]) (ADDTO TEMPLATE X PARENT T))) (T (SELECTQ (CAR TEMPLATE) (IF [PROG ((EXPR X)) (DECLARE (SPECVARS EXPR)) (MSPRGTEMPLATE1 X (COND ((COND ((LISTP (CADR TEMPLATE)) (* ASSERT%: ((REMOTE EVAL) EXPR)) (EVAL (CADR TEMPLATE))) (T (APPLY* (CADR TEMPLATE) X))) (CADDR TEMPLATE)) (T (CADDDR TEMPLATE]) (|..| [COND [(AND (CADR TEMPLATE) (NULL (CDDR TEMPLATE))) (* Special case to handle most  common cases) (MAPC X (FUNCTION (LAMBDA (X) (MSPRGTEMPLATE1 X (CADR TEMPLATE] (T (FRPTQ (IDIFFERENCE (LENGTH X) (LENGTH (CDDR TEMPLATE))) (MSPRGTEMPLATE1 (CAR X) (CADR TEMPLATE)) (SETQ X (CDR X))) (MSPRGTEMPLATE1 X (CDDR TEMPLATE]) (MACRO (ADDTO 'CALL (CAR X) PARENT) (MSPRGMACRO X (CDR TEMPLATE))) (BOTH (MSPRGTEMPLATE1 X (CADR TEMPLATE)) (MSPRGTEMPLATE1 X (CADDR TEMPLATE))) (@ [PROG ((EXPR X)) (DECLARE (SPECVARS EXPR)) (MSPRGTEMPLATE1 (EVAL (CADR TEMPLATE)) (EVAL (CADDR TEMPLATE]) (REMOTE (PROG (VARS (TOPVARS (CONS VARS TOPVARS))) (MSPRGTEMPLATE1 X (CADR TEMPLATE)))) (KEYWORDS (* ;; "KEYWORDS list of keys...") (* ;; "Specifies list of legal keywords") (* ;; "(FOO (LAMBDA... (BAR :BAZ DREK))) is recorded in the database as") (* ;; "(ADDTO 'KEYCALLS '(BAR . :BAZ) '(BAR :BAZ DREK))") (* ;;  "i.e. there is a table for each keyword relating functions that call functions specifying them.") [LET [(LEGAL-KEYS (OR (CDR TEMPLATE) (GETRELATION (CAR PARENT) 'KEYACCEPT] (while X bind (ALLOW-OTHER-KEYS _ (MEMQ '&ALLOW-OTHER-KEYS LEGAL-KEYS)) KEYSUSED? do (if (AND (CL:KEYWORDP (CAR X)) (OR ALLOW-OTHER-KEYS (MEMQ (CAR X) LEGAL-KEYS))) then (ADDTO 'KEYSPECIFY (CAR X) PARENT) (SETQ KEYSUSED? T) else (* ; "log bogus keyword as ppe") (MSPRGERR PARENT)) (pop X) (if X then (MSPRGTEMPLATE1 (CAR X) 'EVAL) (pop X) else (MSPRGERR PARENT) (* ; "log no value for keyword as ppe") ) finally (if KEYSUSED? then (ADDTO 'KEYCALL (CAR PARENT) PARENT]) (COND ((LISTP X) (MSPRGTEMPLATE1 (CAR X) (CAR TEMPLATE)) (MSPRGTEMPLATE1 (CDR X) (CDR TEMPLATE]) (MSPRGTEMPLATE (LAMBDA (PARENT TEMPLATE PARENTCONTEXT) (* lmm "23-Jul-86 00:15") (BLOCK) (*  "Masterscope should block every once and a while. This is one place to do it.") (PROG ((VARS VARS) TEM) (COND ((EQ TEMPLATE 'MACRO) (COND ((SETQ TEM (GETMACROPROP (CAR PARENT) MSMACROPROPS)) (MSPRGMACRO PARENT TEM)) (T (MSPRGTEMPLATE1 PARENT '(CALL .. EVAL))))) (T (MSPRGTEMPLATE1 PARENT TEMPLATE)))))) (MSPRGLAMBDA [LAMBDA (EXPR FLG TYPE) (* ; "Edited 3-Jun-88 10:23 by jrb:") (SELECTQ (CAR (LISTP EXPR)) (CL:LAMBDA [LET ((PARENT EXPR) (PARENTCONTEXT TYPE) (VARS VARS)) [bind (ARGS _ (CADR EXPR)) ARG (EVALCOUNT _ 0) KEYS? KEYLIST while ARGS do (SETQ ARG (pop ARGS)) (* ;; "We can be in one of two states - keyword scanning or not") [COND [(CL:SYMBOLP ARG) (* ;; "Check and see if it's a keyword thingy") (COND ((EQ ARG '&KEY) (SETQ KEYS? T)) [(FMEMB ARG CL:LAMBDA-LIST-KEYWORDS) (SETQ KEYS? NIL) (if (EQ ARG '&ALLOW-OTHER-KEYS) then (ADDTO 'KEYACCEPT (CAR (push KEYLIST ' &ALLOW-OTHER-KEYS )) (CADR EXPR] (T (if KEYS? then (ADDTO 'KEYACCEPT (CAR (push KEYLIST (MAKE-KEYWORD ARG))) (CADR EXPR)) else (CL:INCF EVALCOUNT)) (MSBINDVAR ARG] [(CL:CONSP ARG) (* ;  "Strangely enough they all EVAL their CADRs.") (MSPRGTEMPLATE1 (CADR ARG) 'EVAL) (if KEYS? then (if (CL:SYMBOLP (CAR ARG)) then (MSBINDVAR (CAR ARG)) (ADDTO 'KEYACCEPT [CAR (push KEYLIST (MAKE-KEYWORD (CAR ARG] (CADR EXPR)) else (ADDTO 'KEYACCEPT [CAR (push KEYLIST (MAKE-KEYWORD (CAAR ARG] (CADR EXPR)) (MSBINDVAR (CADAR ARG))) else (CL:IF (CL:SYMBOLP (CAR ARG)) (MSBINDVAR (CAR ARG)) (MSBINDVAR (CADAR ARG))) (OR (NULL (CDDR ARG)) (NOT (CL:SYMBOLP (CADDR ARG))) (MSBINDVAR ARG] (T (MSPRGTEMPLATE1 ARG 'PPE] finally (if KEYLIST then (* ;;  "Look at old template; if there isn't one or it looks like one we put out") (* ;; "(of the form (EVAL* KEYWORDS keys...))") (* ;;  "replace it with a new template (and somehow mark everything that calls FNNAME for reanalysis") [LET ((OLDTEMP (GETTEMPLATE FNNAME)) (EC EVALCOUNT)) (* ;;  "First pop off all the EVALs at the front and count them") (while (EQ (CAR OLDTEMP) 'EVAL) do (CL:DECF EC) (pop OLDTEMP)) (if (OR (NULL OLDTEMP) (EQ (CAR OLDTEMP) 'KEYWORDS)) then (pop OLDTEMP) (if (AND (CL:ZEROP EC) (NULL (CL:SET-DIFFERENCE OLDTEMP KEYLIST )) (NULL (CL:SET-DIFFERENCE KEYLIST OLDTEMP ))) then (* ; "it matches, don't replace it") NIL else (* ;  "It looks like one of ours; replace it") (SETQ KEYLIST (CONS 'KEYWORDS (CL:NREVERSE KEYLIST))) (while (CL:PLUSP EVALCOUNT) do (push KEYLIST 'EVAL) (CL:DECF EVALCOUNT)) (SETTEMPLATE FNNAME KEYLIST) (* ;; "These templates shouldn't show up in FILES?, since they're solely for Masterscope internal use...") (UNMARKASCHANGED FNNAME 'TEMPLATES) (* ;; "The SETTEMPLATE call marked everyone who calls FNNAME to be reanalyzed; it also marked FNNAME - this gets rid of that") (PUTHASH FNNAME NIL MSCHANGEDARRAY] else (* ;; "It's possible that we created an old template for this function and it no longer has keywords, so we MAY need to delete it") (LET ((OLDTEMP (GETTEMPLATE FNNAME))) (while (EQ (CAR OLDTEMP) 'EVAL) do (pop OLDTEMP)) (if (EQ (CAR OLDTEMP) 'KEYWORDS) then (SETTEMPLATE FNNAME NIL) (* ;; "These templates shouldn't show up in FILES?, since they're solely for Masterscope internal use...") (UNMARKASCHANGED FNNAME 'TEMPLATES) (* ;; "The SETTEMPLATE call marked everyone who calls FNNAME to be reanalyzed; it also marked FNNAME - this gets rid of that") (PUTHASH FNNAME NIL MSCHANGEDARRAY] (MSPRGTEMPLATE1 (CDDR EXPR) '(|..| EVAL RETURN]) ([LAMBDA NLAMBDA OPENLAMBDA] (MSPRGTEMPLATE EXPR '(NIL (IF LISTP (|..| BIND) (IF (PROGN EXPR) BIND)) |..| EFFECT RETURN) TYPE)) (PROG (CLISP TEM) (COND ((AND (SETQ TEM (ASSOC (CAR EXPR) LAMBDATRANFNS)) (SETQ CLISP (CL:FUNCALL (CADR TEM) EXPR))) (PROG ((INCLISP (INCLISP EXPR))) (MSPRGLAMBDA CLISP FLG T))) ((AND DWIMFLG (SETQ CLISP (MSDWIMTRAN EXPR))) (* has a CLISP translation  (e.g. DLAMBDA)) (PROG ((INCLISP (INCLISP EXPR))) (* rebind INCLISP, and try again on  the translation) (MSPRGLAMBDA CLISP FLG TYPE))) (T (MSPRGERR EXPR) (MSPRGE EXPR]) (MSPRGLST (LAMBDA (L PARNT CNTX) (* lmm "27-JUN-78 01:57") (for X in L do (MSPRGE X PARNT CNTX)))) (ADDTO (LAMBDA (RELATION WHAT PRNT FLG) (* lmm "24-DEC-78 11:51") (PROG ((PTR (FASSOC RELATION MSFNDATA))) (OR PTR (COND (FLG (RETURN)) (T (SHOULDNT)))) (OR (NULL ONLYRELS) (FMEMB RELATION ONLYRELS) (RETURN)) (AND EACHTIME (EQMEMB RELATION (CAR EACHTIME)) (APPLY* (CADR EACHTIME) WHAT (CADDR EACHTIME) (CADDDR EACHTIME) PRNT INCLISP)) LP (COND ((NULL (CDR PTR)) (FRPLACD PTR (LIST WHAT))) ((EQ (CAR (SETQ PTR (CDR PTR))) WHAT) (RETURN)) (T (GO LP)))))) (NLAMBDAFNP (LAMBDA (FN) (* lmm "26-Mar-85 12:37") (AND (NOT (EQMEMB 'EVAL (GETPROP FN 'INFO))) (COND ((OR (FGETD (SETQ FN (OR (GETPROP FN 'BROKEN) FN))) (SETQ FN (GETLIS FN '(EXPR CODE)))) (* if the function is defined, check its argtype to tell you whether it is  NLAMBDA or LAMBDA) (SELECTQ (ARGTYPE FN) ((1 3) T) NIL)) (T (* otherwise, rely on NLAMA or NLAML) (OR (FMEMB FN NLAMA) (FMEMB FN NLAML))))))) (MSPRGDWIM [LAMBDA (X FN DEF) (* ; "Edited 8-Apr-88 11:55 by jrb:") (AND DWIMFLG (LET ((NOSPELLFLG T) FILEPKGFLG) (DECLARE (SPECVARS NOSPELLFLG)) (RESETVARS ((DWIMESSGAG T)) (* ;; "JRB Made these RESETVARS to placate the PavCompiler") (PROG (LISPXHIST) (* ASSERT%: ((REMOTE EVAL)  DWIMESSGAG FILEPKGFLG NOSPELLFLG)) (DWIMIFY0 X (OR (AND (LITATOM FN) FN) '?) VARS DEF]) (MSDWIMTRAN (LAMBDA (EXPR) (* DD%: "28-DEC-81 13:46") (AND DWIMFLG (COND ((AND CLISPARRAY (GETHASH EXPR CLISPARRAY))) ((AND CLISPTRANFLG (EQ (CAR (LISTP EXPR)) CLISPTRANFLG)) (CADR EXPR)) (T (MSPRGDWIM EXPR FNNAME FNDEF) (OR (AND CLISPARRAY (GETHASH EXPR CLISPARRAY)) (AND CLISPTRANFLG (EQ (CAR (LISTP EXPR)) CLISPTRANFLG) (CADR EXPR)))))))) ) (RPAQQ MSFNDATA ((BIND) (CALL) (EFFECT) (PREDICATE) (CLISP) (PROP) (SETFREE) (SET) (SMASHFREE) (SMASH) (REFFREE) (REF) (FETCH) (REPLACE) (RECORD) (ERROR) (ARG) (CREATE) (LOCALVARS) (SPECVARS) (APPLY) (TESTFREE) (TEST) (LOCALFREEVARS) [NLAMBDA] (TYPE) (STACK) (KEYACCEPT) (KEYSPECIFY) (KEYCALL) (FLET) (LABEL) (MACROLET) (COMPILER-LET))) (RPAQQ MSERRORFN ppe) (RPAQQ MSRECORDTRANFLG NIL) (ADDTOVAR INVISIBLEVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS INCLISP MACRO ((.X.) (COND ((AND INCLISP EACHTIME (NOT (MSFINDP INCLISP .X.))) INCLISP) (T .X.)))) (PUTPROPS LTEMPLATE MACRO [LAMBDA (Y) (DECLARE (LOCALVARS Y)) (AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES) (GETHASH Y MSTEMPLATES] Y]) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: ALLCALLS ALLCALLS ADDTO MSBINDVAR MSDWIMTRAN MSPRGCALL MSPRGDWIM MSPRGE MSPRGMACRO MSPRGERR MSPRGLAMBDA MSPRGLST MSPRGRECORD MSPRGTEMPLATE MSPRGTEMPLATE1 NLAMBDAFNP (NOLINKFNS . T) (LOCALFREEVARS FNNAME ERRORS FNDEF INCLISP ONLYRELS PARENTCONTEXT TOPVARS PARENT EACHTIME VARS ) (GLOBALVARS CLISPARRAY MSERRORFN MSRECORDTRANFLG MSFNDATA INVISIBLEVARS CLISPARRAY MSTEMPLATES USERTEMPLATES MSRECORDTRANFLG NLAMA NLAML DWIMFLG CLISPTRANFLG DWIMESSGAG) (NOLINKFNS . T)) (BLOCK%: NIL MSINITFNDATA NLAMBDAFNP MSPRGDWIM (LOCALVARS . T) (GLOBALVARS NLAMA NLAML MSFNDATA DWIMFLG DWIMESSGAG)) ) [PUTDQ? MSWORDNAME (LAMBDA (X) X] (RPAQ MSTEMPLATES (HASHARRAY 160)) (RPAQ USERTEMPLATES (HASHARRAY 10)) (RPAQQ INITIALTEMPLATES (((CALL (REMOTE (IF LITATOM CALL LAMBDA)) (IF LITATOM EVAL NIL)) FUNCTION) ((NIL NIL |..| EVAL RETURN) CL:BLOCK) ((CALL |..| EVAL) CL:CATCH CL:THROW) ((NIL NIL EVAL) CL:RETURN-FROM) ([IF (EQ (CADR EXPR) 'ASSERT%:) (NIL NIL |..| (IF LISTP (@ (CDR EXPR) (LIST '|..| (MSWORDNAME (CAR EXPR] *) ((NIL (BOTH (|..| (IF LISTP (NIL EVAL |..| EFFECT) NIL)) (|..| (IF LISTP (BIND) BIND))) |..| EFFECT RETURN) LET CL:COMPILER-LET) ((NIL (|..| (IF LISTP (BIND EVAL . PPE) BIND)) |..| EFFECT RETURN) LET*) ((NIL |..| (IF LISTP EFFECT)) CL:TAGBODY) ((NIL (BOTH (|..| (IF LISTP (NIL EVAL |..| EFFECT) NIL)) (|..| (IF LISTP (BIND) BIND))) |..| (IF LISTP EFFECT)) PROG) (MACRO RESETVARS) ((CALL EVAL) XNLSETQ NLSETQ ERSETQ) ((CALL |..| EVAL) RESETFORM FRPTQ) ((CALL EVAL EVAL FUNCTIONAL FUNCTIONAL . PPE) MAP2C) ((CALL EVAL EVAL SMASH . PPE) /DSUBST DSUBST) ((CALL EVAL FUNCTION FUNCTION . PPE) MAPCAR MAPCON MAPCONC MAPLIST SUBSET EVERY NOTEVERY ANY NOTANY SOME MAPC MAP) ((CALL EVAL FUNCTIONAL . PPE) MAPHASH) ((CALL EVAL PROP . PPE) GETP GETLIS GET GETPROP LISTGET LISTGET1 REMPROP /REMPROP) ((CALL EVAL PROP EVAL . PPE) PUT /PUT PUTPROP /PUTPROP LISTPUT LISTPUT1) ((CALL EVAL SMASH . PPE) /ATTACH ATTACH) ((CALL FUNCTIONAL . PPE) MAPATOMS) ((CALL FUNCTIONAL |..| EVAL) APPLY* BLKAPPLY* APPLY BLKAPPLY) ((CALL EVAL SMASH . PPE) DREMOVE /DREMOVE) ((CALL SET EVAL EVAL . PPE) RESETVAR) ((CALL SET EVAL . PPE) SETN) ((CALL SMASH . PPE) DREVERSE) ((CALL SMASH EVAL . PPE) RPLACD /RPLACD RPLACA /RPLACA RPLNODE2 /RPLNODE2 FRPLACD FRPLNODE2 TCONC /TCONC LCONC /LCONC NCONC1 /NCONC1 FRPLACA) ((CALL SMASH EVAL EVAL . PPE) RPLNODE FRPLNODE /RPLNODE) ((CALL SMASH FUNCTIONAL . PPE) SORT) ((CALL (BOTH SET EVAL) . PPE) ADD1VAR SUB1VAR) ((CALL (IF NULL NIL (IF ATOM SET EVAL)) EVAL . PPE) RESETSAVE) ((CALL (IF (EQ (CAR (LISTP EXPR)) 'QUOTE) (NIL SET) EVAL) EVAL . PPE) SET /SET SETTOPVAL /SETTOPVAL SETATOMVAL /SETATOMVAL) ((CALL (IF (EQ (CAR (LISTP EXPR)) 'QUOTE) (NIL SET) EVAL) EVAL EVAL EVAL . PPE) SAVESET) ((CALL (IF (EQ (CAR (LISTP EXPR)) 'QUOTE) (NIL EVAL) EVAL) |..| EVAL) GETATOMVAL EVAL EVALV) ((NIL |..| TESTRETURN RETURN) OR) ((NIL |..| TEST RETURN) AND) ((NIL |..| EFFECT RETURN) PROGN) ((NIL TEST RETURN RETURN) CL:IF) ((NIL |..| (IF CDR (TEST |..| EFFECT RETURN) (TESTRETURN . PPE))) COND) ([CALL |..| (@ EXPR (CONS NIL (SELECTQ (CAR (LISTP EXPR)) (LOCALVARS '(IF LISTP (|..| LOCALVARS) LOCALVARS)) (SPECVARS '(IF LISTP (|..| SPECVARS) SPECVARS)) NIL] DECLARE) ((NIL RETURN) CLISP% ) ((NIL EVAL . PPE) LISTP NLISTP RETURN) ((NIL TEST . PPE) NOT NULL) ((CALL EVAL |..| (NIL |..| EFFECT RETURN) RETURN) SELECTQ SELCHARQ) ((CALL EVAL |..| (EVAL |..| EFFECT RETURN) RETURN) SELECTC) ((CALL EVAL |..| ((IF LISTP (|..| EVAL) EVAL) |..| EFFECT RETURN) RETURN) SELECT) ((NIL EVAL EVAL . PPE) EQ NEQ) ((NIL NIL . PPE) QUOTE GO) ((NIL EVAL . PPE) CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CDAAR CADDR CDADR CDDAR CDDDR CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR) ((NIL RETURN |..| EFFECT) PROG1) ((NIL SET NIL . PPE) SETQQ) ((NIL SET EVAL . PPE) SETQ ADV-SETQ SAVESETQ) ([@ EXPR (CONS NIL (MAPCON (CDR EXPR) [FUNCTION (LAMBDA (X) (if (LITATOM (CAR X)) then (LIST 'SET 'EVAL) else (LIST 'SMASH 'EVAL] (FUNCTION (LAMBDA (X) (CDDR X] CL:SETQ CL:SETF) ((CALL EVAL (BOTH (@ 'RPTN 'BIND) RETURN) . PPE) RPTQ) ((CALL EVALQT |..| EVAL) EVAL ERRORSET) ((BOTH [IF (EQ (CAR (LISTP (CADDR EXPR))) 'QUOTE) (NIL NIL (NIL (|..| (BIND] (CALL EVALQT EVAL . PPE)) EVALA) ((CALL EVALQT STACK STACK EVAL EVAL . PPE) ENVEVAL) ((CALL FUNCTIONAL EVALQT STACK STACK EVAL EVAL . PPE) ENVAPPLY) ((CALL STACK EVAL EVAL EVAL . PPE) STKAPPLY) ((CALL STACK EVALQT EVAL EVAL . PPE) RETEVAL STKEVAL) ((CALL STACK EVAL EVAL . PPE) RETFROM RETTO) ((NIL NIL RETURN) THE))) (* ;;; "INITIALTEMPLATES is not needed after loading up") [MAPC INITIALTEMPLATES (FUNCTION (LAMBDA (X) (MAPC (CDR X) (FUNCTION (LAMBDA (Y) (PUTHASH Y (CAR X) MSTEMPLATES] (DECLARE%: EVAL@COMPILE DONTCOPY (PUTPROPS LTEMPLATE MACRO [LAMBDA (Y) (DECLARE (LOCALVARS Y)) (AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES) (GETHASH Y MSTEMPLATES] Y]) ) (DEFINEQ (MSFINDP (LAMBDA (STRUC SUB) (* lmm "14-Aug-84 16:38") (PROG NIL LP (RETURN (OR (EQ SUB STRUC) (AND (LISTP STRUC) (OR (MSFINDP (CAR STRUC) SUB) (PROGN (SETQ STRUC (CDR STRUC)) (GO LP))))))))) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSFINDP MSFINDP) ) (PUTPROPS MSANALYZE COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1988 1990 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3762 11281 (VARS 3772 . 3913) (FREEVARS 3915 . 4068) (CALLS 4070 . 10411) ( COLLECTFNDATA 10413 . 10792) (CALLS3 10794 . 11279)) (13538 52620 (ALLCALLS 13548 . 14227) ( MSINITFNDATA 14229 . 14473) (MSPRGE 14475 . 21549) (MSPRGMACRO 21551 . 22042) (MSPRGCALL 22044 . 22368 ) (MSBINDVAR 22370 . 22889) (MSPRGRECORD 22891 . 29804) (MSPRGERR 29806 . 29974) (MSPRGTEMPLATE1 29976 . 39137) (MSPRGTEMPLATE 39139 . 39819) (MSPRGLAMBDA 39821 . 49416) (MSPRGLST 49418 . 49586) (ADDTO 49588 . 50379) (NLAMBDAFNP 50381 . 51133) (MSPRGDWIM 51135 . 51954) (MSDWIMTRAN 51956 . 52618)) (61946 62373 (MSFINDP 61956 . 62371))))) STOP \ No newline at end of file diff --git a/library/MSANALYZE.DFASL b/library/MSANALYZE.DFASL index 60ccfe5fdff88b4eb20e38216acb9429669c5c55..31663630a5a1058ac2c1f63a0d16461338e0dc90 100644 GIT binary patch delta 5121 zcmb_fdr*|u760z{ErJMYA`hX!E-=VL5O$Y`f*{MffUqo&T_l($hA1i)Ys8pF#4geJ z!0~~5go3q?NvnONX~wQjY;ihyG*dFuN03h4Y3n5YBa=46AGMJ*wyE^qbMChb7@KJ) z!|;8-d(Q8ibMLw5-23h8SJ|(xvcas)>)rJS*Y4Q8tFxlJqo-$oMOSy%-lr;db#CqM z++We%^<+;67dE(UE}OG`lVeqxCEC4vU(c3K)3&bePScj2&W@)$x0+1WyoQdRJWGMa zY%&*=TFs^A;^=Cd+j;iUggC2->$dDL32kmreff>th`N|hGaNc;Iq*ME%WqlOyFfD+ zSo|+984PD(P#K>SH8ONEqQPcwY0Rs3`FF;98SC|bu>7W`^)6ZfUoTC7TS=SQQ7BK| z!+PQ6y;QK0by4) z0tOt>{@)k@4TqB)^phbz%XGy!4!4u8Ot@IBtL}4d;m(ODRcp~01Fw8=U}-~&R8)Tq57L{PY7Gt6l z4b)G8tf5!7cqtznapWsGq%2enr)dD) zRtpQjx2z^!!>?Mi`17w;Q$`;*&|Vl#6t5m+P7Bycl6Gmks<41f!{$PF_Fb-3FOIf} z*9D+`Xk26X>ImQtsDLgV8P>PD{27vfckOnss&Kkm zjuNrabo{HLpww6)RlmR=?4uxoy^B&|#&Dz213MHVJcdvlR?0sRVp04d1jmA0CFwAU zci`(DohCC>xA)+=@^!}G`HF?ZaBr0<{TQ2ocgmCVX~PxtAv!|!>Uz@9DcUCs;s~s) zFsVmWc)}h79Th2ydihMT8Tf^GqT(QbMyzXRCt!c&;RRxuCsern@G`i!&K=>St?)s6 z(3b!(;L+dg|Eyk(0Gr#tdCY_=bU9aSqev!xh@tA4() zO18v4c+7r+)xuxwDG!@1C2Fy7quj|tZ%%lz%0czjL=!#(JJvY_!+&oXWH+ z^o1g6u%O16iz~0XrLh71(Umv>wwkp3X>owq+-^sUr&L^TGLpVg!EHtx zz8+sqTKF_hZyd&I@@o0TDk~tk5Y+OUckW$@QlUAy`IB~ zC{vUneBv=LC38IRwHurcPYx~m(^m$8TGQvch^2hWGQpGx*t(&JUkm3q6ol(LGqE8v zfr_7=cacfY06bKexNNqT?%V)W)U8gCYz_R!ObgBZiB2a;^?c%a~99@^OQ4N zO7vKloayqzEdXyjjePchn1ARz6FwKWlSF`7! zdtBVOsr~cxNPcziuQeJw{(tYYeaVgF8H%iNctnym+VBkJWov7S^^%@0jXs`PwXub- zJJ{f)-iV16YR%?af4^RKwP2~H*=lJRG*>rNqgwx7A6cz$A@0EU^&KTU3ND?GoTIad zrW%0g=7dPS9mQGPY<~0xI>Bu$;$bi<-^F=98sw2SS~MCYm3$@}t~VRKeLRZ`?9L7D zCca1mFIXxMxoH^ghM>4O#Y279N0m)PT2(-#(beb?d@WMw0Y7nN|B*LwHj+^&2}=}4 zUyAtD?9kPcoE4&Dd^toc6Nk7De%z8&9U?z4E8_Se+Jjv!b;s4r=HPL}+lv3hb2*yj zifQ(!V$-6qY8pqtI6rBy%bmc!;y>m#uy9)3IQTqi*#Yh>%;^IxTT_h@o?6v^pimygT&Sn?>4!;%1a^_$~o@a@br$(FH639Fu47gtGc;EpP+Yk z@9lg5y=gw3S02CH=`I8QTNmDLUCj2vJFS^t@<}-pzga~vmA9H+s60$dlgAYl;AH7C zq|}I{2nwc{%32o9M>ugR6}dC8XJdS;9)|t5!$bzup2dLJKB5YOr=Zr)^Qnq|iUPMb z#z#{`iWLCXmS`jiap*axMxeAUDT9vv&te{EOP_N|>QOFp`Rus5{Qb7Pc~?y8BdM&< pZ-1nWE#vnI!+HN(2cN*%_V-yN?B7(mm@hQ^J>@)q8RBMU{sT1oB)I?p delta 5273 zcmcIo3v83u75?x4I|+{jC?UO6GB2Bw(}%_3C1`$cCejx$U3yOuzSw=e>(}V zY11ac@9&=boyWcB+;e~XS7*iBXT?xSq|NDZHnes$IK3Udz`hk8cc87==Xb93xYzg{ z{;rj+0f*P&>DugE-e}JVJlWf`EoAx9BaekF+j>GVzYG=C^fn4lrMbnL0@ zh!EkitDlQ&T6k_M+>^c-F6BNb4ncF?j_mM$MbRooZ$Qk8SLq;W`- zj^?#Gn*BcKrZ$H+;P!dNDw>Ka$_eJcvI2+P;l~SV!~lG!;M?LPtS_|X4lbwZ0ksf6 zl`Gk!6^6>uu~^}VCXT}LVr%(vIje1EF2W3gl$u_GVJTG~Wda;4u5LYp_I{n1Q{GC# zvrIz*B&7o^eS{^HC*^Vx3n8QAWcrV!g7_&3#^BA8NH%R_4hdexxpacBL2&7jStB+Y z48x_RR+)h8((PH%kwLAk&56wGF%UE#1t@J2<8YyLQDmGX+xzLmg*0CbG^WvWT<)`B z!5sq=Gow65&p2wWkyA7}PtOa6k&6?-wb`MtZvRav6jLWrbo8Y-Pn_VC?>~j1(~ek5*YDctlLeq?x$vu{uoK$O0Z* zlb0Y?hsjA051FZoARawa0l||JYOfLuBm6!=bfIlYO7$a!QhQmFp(YsWWJ0R);xHcd zVaU(RgfCRjYYxkyc%MiU2;WKY#VZ6cJpK3);TuWmGt7n4)g_T@NL!Brmk?;mV>N|r>2+JBv^*Ft*;QAdTxgO$)`cX6boLGuOY-pS8JHbc-2cU zZF75^{&J5K9$&v;>-bF9!xXJ$#%(@h`S9U-%l~(!GaOP9 z6$}lJ4ec51a~H_WebZf;$YtDJypC7L&l{x1&$!HMN~@!-x>=fz4X4oZsf5H-6~2n& zu(svCxzW*1`47)d9C};!W=u62hnp?ASTqnB&dO zdir@6JZ$TC!Nnm4nLij|Y8n!&4*8_#1>pI*bkLi`J7)dKZx6m6RYK#6D^V zI*~U4SE_k^LF8+*aUO1O7uaLj>$E)^-9HD@N~&w%Nq=61ohMqdKBQRmeI|^trv>DX zDa}FIq44TLu`;zop^dxlBkl~_p6(%n6BLguHo0_mL5rStAF&oSGPPF{HLr7{zBRl| zni7*(urB$n(R`=fRbHl`Pf@8j9DX^{6m|F5(SS*$aS-DW3l_*$buRdMy*;tvx8YK- zFo*9v*(a!=G>6fF)Yrk%UMoVdsom_|o2V1oxt8feJawkfV>?5-5p@Q=Z3Z1G+84uz z?Wv*%F1Hu2it1_tzssV1RU{P9vcE0pO$cbUe24Pt;;^A(apbQQm);l%V^Fi4e!tHj zkXJUQmux4Th=0|Kba&cU$ldKtRO`pL2>j1}AJD)0%XiLUI(2##aaekyWkA%M92m`T z8ky!|V;bAy=hV82!|Kl5BEGEt9rNkV!py0yKhKL^iLUtvoMNWy-pB>z_a?QT+e_