(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(filecreated " 2-Jun-87 14:51:46" {dsk}<lispfiles>work>eval-when-patch.\;1 30488
|changes| |to:| (vars eval-when-patchcoms)
(fns addtocom delfromcom getdefcurrent importeval infilecom))
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(prettycomprint eval-when-patchcoms)
(rpaqq eval-when-patchcoms ((fns addtocom delfromcom getdefcurrent importeval infilecom)))
(defineq
(addtocom
(lambda (com name type near listname) (* \; "Edited 2-May-87 19:04 by Pavel")
(* \;
"tries to insert NAME into the prettycom COM; returns NIL if unsuccessful")
(prog (tem)
(cond
((and near (not (infilecoms? near type (list com))))
(return)))
(cond
((setq tem (|fetch| add |of| (car com)))
(return (cond
((or (null listname)
(infilecoms? listname 'filevars (list com)))
(and (setq tem (apply* tem com name type near))
(markaschanged comsname 'vars))
tem)))))
(return
(selectq (car com)
(fns (and (eq type 'fns)
(addtocom1 com name near listname)))
((vars initvars)
(cond
((or (eq (car com)
'vars)
near listname) (* \;
"Don't stick on INITVARS unless NEAR or LISTNAME says we should.")
(selectq type
(expressions (cond
((eq (car name)
'setq)
(addtocom1 com (cdr name)
near listname))))
(vars (addtocom1 com name near listname))
nil))))
(coms (addtocoms (cond
((eq (cadr com)
'*)
(cond
((litatom (caddr com))
(caddr com))
(t (return))))
(t (cdr com)))
name type near listname))
(declare\: (and (or listname near)
(addtocoms (cond
((eq (cadr com)
'*)
(cond
((litatom (caddr com))
(caddr com))
(t (return))))
(t (cdr com)))
name type near listname)))
(cl:eval-when (and (or listname near)
(addtocoms (cond
((eq (cl:third com)
'*)
(cond
((litatom (cl:fourth com))
(cl:fourth com))
(t (return))))
(t (cddr com)))
name type near listname)))
((prop ifprop)
(selectq type
(props (cond
((eq (cadr com)
(cadr name))
(addtocom1 (cdr com)
(car name)
near listname))
((and (eq (car name)
(caddr com))
(null (cdddr com)))
(/rplaca (cdr com)
(union (mklist (cdr name))
(mklist (cadr com))))
(markaschanged comsname 'vars)
t)))
(macros (cond
((and (|for| prop |inside| (cadr com)
|always|
(eqmemb prop macroprops))
(|for| prop |in| macroprops |always|
(or (eqmemb prop (cadr com))
(not (getprop name prop)))))
(* |;;| "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed")
(addtocom1 (cdr com)
name near listname))))
nil))
((props alists)
(and (eq type (car com))
(addtocom1 com
(/nconc1 (or (assoc (car name)
(cond
((eq (cadr com)
'*)
(cond
((litatom (caddr com))
(and (or (null listname)
(eq (caddr com)
listname))
(gettopval (caddr com))))
(t (return))))
(t (cdr com))))
(list (car name)))
(cadr name))
near listname)))
(p (cond
((and (eq type 'expressions)
(neq (car name)
'setq))
(addtocom1 com name near listname))))
(and (eq (car com)
type)
(addtocom1 com name near listname)))))))
(delfromcom
(lambda (com name type) (* \; "Edited 2-May-87 19:02 by Pavel")
(* \; "Tries to delete NAME from COM")
(prog (tem var new)
(cond
((setq tem (|fetch| delete |of| (car com)))
(and (setq tem (apply* tem com name type))
(markaschanged comsname 'vars))
(return tem)))
(return (selectq (car com)
((declare\: coms)
(delfromcoms (cond
((eq (cadr com)
'*)
(cond
((litatom (caddr com))
(caddr com))
(t (return))))
(t (cdr com)))
name type))
((cl:eval-when)
(delfromcoms (cond
((eq (cl:third com)
'*)
(cond
((litatom (cl:fourth com))
(cl:fourth com))
(t (return))))
(t (cddr com)))
name type))
((alists props)
(and (eq type (car com))
(cond
((eq (cadr com)
'*)
(cond
((and (litatom (setq var (caddr com)))
(setq tem (assoc (car name)
(gettopval var)))
(neq (cdr tem)
(setq tem (removeitem (cadr name)
(cdr tem)))))
(saveset var tem t 'noprint)
t)))
((and (cdr (setq tem (assoc (car name)
(cdr com))))
(neq (cdr tem)
(setq new (removeitem (cadr name)
(cdr tem)))))
(/rplacd tem new)
(markaschanged comsname 'vars)
t))))
(blocks
(* |;;| "Remove function name from blocks declarations. This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.")
(and (eq type 'fns)
(|for| block |in| (infilecomtail com t)
|do|
(and (memb name block)
(/dremove name block))
(|for| x |in| block |when| (and (listp x)
(memb name (cdr x)))
|do|
(/rplacd x (remove name (cdr x)))))))
((prop ifprop)
(selectq type
(props (return (cond
((eq (cadr com)
(cadr name))
(delfromcom1 (cdr com)
(car name)))
((and (eqmemb (cadr name)
(cadr com))
(null (cdr (setq tem (prettycom1 (cdr com)))))
(eq (car tem)
(car name)))
(/rplaca (cdr com)
(remove (cadr name)
(mklist (cadr com))))
(markaschanged comsname 'vars)
t))))
(cond
((|for| prop |inside| (cadr com)
|always|
(eq type (getprop prop 'proptype)))
(delfromcom1 (cdr com)
name)))))
((records initrecords sysrecords)
(and (eq type 'records)
(delfromcom1 com name)))
(p (and (eq type 'expressions)
(delfromcom1 com name)))
((vars initvars)
(and (eq type 'vars)
(delfromcom1 com name t)))
(and (eq type (car com))
(delfromcom1 com name)))))))
(getdefcurrent
(lambda (name type options) (* \; "Edited 2-May-87 19:00 by Pavel")
(* \;
"Gets the current definition--source=0")
(let
(def)
(cond
((and (setq def (|fetch| getdef |of| type))
(neq def t))
(* |;;| "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.")
(or (neq (setq def (apply* def name type options))
(|fetch| nulldef |of| type))
(getdeferr name type options))
def)
(t
(or
(neq
(setq def
(selectq type
(fns (and (litatom name)
(exprp (setq def (virginfn name)))
def))
(vars (|if| (litatom name)
|then|
(gettopval name)
|else|
'nobind))
((fields records)
(|if| (litatom name)
|then|
(setq def (selectq type
(records (reclook name))
(mkprogn (fieldlook name))))
(|if| (eqmemb 'edit options)
|then|
(copy def)
|else| def)))
(files (* \;
"what is the `definition' of a file? -- I guess the COMS which say what it contains")
(|if| (litatom name)
|then|
(|if| (setq def (getfiledef name))
|then|
(updatefiles)
(list (listp (gettopval (filecoms def)))
(|fetch| tobedumped |of| (|fetch| fileprop |of| def))
(listp (|fetch| filedates |of| def))))))
(templates (|if| (and (litatom name)
(setq def (gettemplate name)))
|then|
(list 'settemplate (kwote name)
(kwote def))))
(macros (|if| (and (litatom name)
(setq def (|for| x |on| (getproplist name)
|by|
(cddr x)
|when|
(fmemb (car x)
macroprops)
|join|
(list (car x)
(cadr x)))))
|then|
`(putprops ,name ,@def)))
(expressions (listp name))
(props (and (listp name)
(and (setq def (some (getproplist (car name))
(function (lambda (x)
(eq x (cadr name))))
(function cddr)))
(list 'putprops (car name)
(cadr name)
(cadr def)))))
(filepkgcoms (and (litatom name)
(prog ((com (filepkgcom name))
(typ (filepkgtype name)))
(return (cond
((and com typ)
(list (cons 'com com)
(cons 'type typ)))
(com (list (cons 'com com)))
(typ (list (cons 'type typ))))))))
(filevars (cond
((and (litatom name)
(listp (setq def (gettopval name)))
(whereis name 'filevars))
def)
(t 'nobind)))
(let
((coms (list (makenewcom name type)))
file)
(cond
((not (setq def (getdefcom coms)))
(with-reader-environment
*old-interlisp-read-environment*
(resetlst
(resetsave prettyflg)
(resetsave fontchangeflg)
(resetsave (output (setq file (openstream '{nodircore} 'both))))
(prettydefcoms coms)
(setfileptr file 0)
(setq def
(|for| x |in| (readfile file)
|join|
(selectq (car x)
((*)
nil)
(declare\: (|for| y |on| (cdr x)
|unless|
(selectq (car y)
((copywhen eval@loadwhen eval@compilewhen)
(return (list y)))
(fmemb (car y)
declaretagslst))
|collect|
(car y)))
(cl:eval-when (cddr x))
(progn (cdr x))
(list x))))
(setq nocopy t)))))
(mkprogn def))))
(|fetch| nulldef |of| type))
(getdeferr name type options))
def)))))
(importeval
(lambda (form returnflg) (* \; "Edited 2-May-87 18:57 by Pavel")
(* |;;| "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms")
(and (listp form)
(selectq (car form)
(declare\: (for z in (cdr form)
join
(importeval z returnflg)))
(cl:eval-when (for z in (cddr form)
join
(importeval z returnflg)))
(/declaredatatype (* \;
"Ignore datatype initializations -- we only need the record declaration itself")
nil)
(progn (* \; "default: eval and/or return it")
(and (neq returnflg t)
(eval form))
(and returnflg (list form)))))))
(infilecom
(lambda (com) (* \; "Edited 2-May-87 19:03 by Pavel")
(cond
((nlistp com)
(cond
((eq type 'vars)
(infilecomsval com))))
((eq (car com)
commentflg)
(* |;;|
"must be special case'd first so that (* * values) doesn't make it look like `values' is a variable")
(* \;
"don't know why I should bother, but someone might want to know all of the comments on a file???")
(cond
((eq type commentflg)
(infilecomsval com t)))
nil)
(t
(prog ((comname (car com))
(tail (cdr com))
cfn tem)
(cond
((cond
((setq cfn (|fetch| (filepkgcom contents)
|of| comname))
(setq tem (apply* cfn com (cond
((and (null onfiletype)
(listp name))
(* \;
"call from WHEREIS of a name which is a list")
(list name))
(t name))
type onfiletype)))
((setq cfn (|fetch| (filepkgcom prettytype)
|of| comname)) (* \; "for compatability")
(setq tem (apply* cfn com type name))))
(cond
((nlistp tem)
(cond
((eq tem t)
(cond
((or (eq name t)
(null onfiletype))
(retfrom 'infilecoms? t))))))
(t (infilecomsvals tem))))
((listp tail)
(* |;;| "this SELECTQ handles the `exceptional cases' for the built in types. There is an explicit RETURN in the SELECTQ clause if the default is handled")
(selectq comname
((prop ifprop)
(setq tail (cdr tail)))
nil)
(cond
((eq (car tail)
'*)
(cond
((litatom (cadr tail))
(selectq type
((vars filevars)
(infilecomsval (cadr tail)))
nil))
((and (listp (cadr tail))
(eq onfiletype 'update)
(eq type 'vars)
(eq (caadr tail)
'progn)
(fmemb (car (last (cadr tail)))
name))
(setq val (cons (cadr tail)
val))))))
(selectq comname
((coms export)
(infilecoms (infilecomtail com)))
(cl:eval-when (infilecoms (infilecomtail (cdr com))))
(declare\: (* \; "skip over DECLARE: tags")
(return (and (not (fmemb 'compilervars com))
(ifcdeclare (infilecomtail com)
(eq type 'declare\:)))))
(original (* \; "dont expand macros")
(prog ((origflg t))
(infilecoms (infilecomtail com))))
((prop ifprop) (* \;
"this currently does not handle `pseudo-types' of PROPNAMES")
(selectq type
(props (ifcpropscan (infilecomtail (cdr com))
(cadr com)))
(macros (infilecomsmacro (infilecomtail (cdr com))
(cadr com)))
nil))
(props (return (ifcprops com)))
(macros (return (selectq type
(props (ifcpropscan (infilecomtail com)
macroprops))
(macros (infilecomsvals (infilecomtail com)))
nil)))
(alists (* \;
"sigh. This should probably also `coerce' when asking for LISPXMACROS, etc.")
(return (selectq type
(alists (infilepairs (infilecomtail com)))
nil)))
(p (return (selectq type
((expressions p)
(infilecomsvals (infilecomtail com t)
t))
(cond
((null onfiletype) (* \; "for WHEREIS and FILECOMSLST")
(selectq type
(i.s.oprs (ifcexprtype com 'i.s.opr))
(templates (ifcexprtype com 'settemplate))
nil))))))
((addvars appendvars)
(selectq type
(vars (return (and (null onfiletype)
(|for| x |in| (infilecomtail com t)
|do|
(infilecomsval (car x)
t)))))
(alists (return (|for| x |in| (infilecomtail com)
|when|
(eqmemb 'alist (getprop (car x)
'vartype))
|do|
(|for| z |in| (cdr x)
|do|
(infilecomsval (list (car x)
(car z))
t)))))
(or (eq type comname)
(return))))
((vars initvars filevars uglyvars horriblevars constants array)
(return (cond
((eq type 'expressions)
(|for| x |in| (infilecomtail com)
|when|
(listp x)
|do|
(infilecomsval (cons 'setq x)
t)))
((or (eq type 'vars)
(eq type comname))(* \;
"either want all VARS, or else want all FILEVARS and this is a FILEVARS command")
(|for| x |in| (infilecomtail com)
|do|
(cond
((listp x)
(and (car x)
(infilecomsval (car x)
t)))
(x (infilecomsval x (eq comname 'initvars)))))))))
(defs (return (|for| x |in| (infilecomtail com)
|when|
(eq type (car x))
|do|
(infilecomsvals (cdr x)))))
(files (return))
nil)
(* |;;| "Exceptional cases now handled. If TYPE matches (CAR COM) then scan the tail as usual. Else expand the com's MACRO, if it has one, unless there was a CONTENTS function")
(cond
((eq comname type)
(infilecomsvals (infilecomtail com)))
((and (or (null cfn)
(and (eq cfn t)
(null onfiletype)))
(null origflg)
(setq tem (|fetch| (filepkgcom macro)
|of| comname)))
(infilecoms (subpair (car tem)
(infilecomtail com)
(cdr tem))))))))))))
)
(putprops eval-when-patch copyright ("Xerox Corporation" 1987))
(declare\: dontcopy
(filemap (nil (475 30395 (addtocom 485 . 7020) (delfromcom 7022 . 12896) (getdefcurrent 12898 . 19529)
(importeval 19531 . 20542) (infilecom 20544 . 30393)))))
stop