;;;;;;;;;;;;;;;;;;;;;;;;;;;;; scopy.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Functions for copying structures in various ways.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Copyright (c) 1983 , The Regents of the University of California.
; Authors: Joseph Faletti and Michael Deering.
; Internal slot processor of SCOPY.
(setq slotvalue (getslotvalue slotnum oldvalblock))
(selectq (setq valuetype (getslotvaluetype slotnum oldvalblock))
(CONSTANT (setq slotvalue (insidescopy slotvalue)))
(LOCAL (and (equivclassp (cdr slotvalue))
(setq oldvarcell (cdr slotvalue))
(setq slotvalue (cons (car slotvalue) (punbound)))))
(cond ((eq *any*conscell* slotvalue) nil)
((neq (cdr slotvalue) (punbound))
(setq valuetype 'CONSTANT)
(setq slotvalue (insidescopy (cdr slotvalue))))
; Test for previously seen unbound variable.
(getalist *currenttopcopy*)))
(setq slotvalue newvarcell))
; Otherwise it is a new unbound variable.
(addalist (car slotvalue)
(and (equivclassp oldvarcell)
(rplacd slotvalue oldvarcell)
(ADJUNCT (setq oldvarcell (cdr slotvalue))
(setq slotvalue (insidescopy (car slotvalue)))
(cond ((eq *any*conscell* oldvarcell)
(setq slotvalue (cons slotvalue *any*conscell*)))
(setq slotvalue (cons slotvalue oldvarcell)))
; Used to throw away bound adjunct variables.
;((neq (cdr oldvarcell) (punbound))
; (setq valuetype 'CONSTANT)
; (setq slotvalue (insidescopy (car slotvalue)))
; Test for previously seen variable.
(getalist *currenttopcopy*)))
(setq slotvalue (cons slotvalue newvarcell)))
; Otherwise it is a new variable.
(addalist (car oldvarcell)
(setq slotvalue (cons slotvalue newvarcell)))))
(putslotvaluetype slotnum valuetype valblock)
(putslotvalue slotnum slotvalue valblock)
(putpred slotnum (copy (getpred slotnum oldvalblock)) valblock)
(putslothooks slotnum (copy (getslothooks slotnum oldvalblock)) valblock)))
; Internal item processor of SCOPY.
(defblock valblock length slotvalue valuetype oldvalblock
oldvarcell newvarcell abbrev)
((numberp item) item) ; Integer
((dtpr item) ; Lisp or Setof
(mapcar (function insidescopy) item))
((psymbolp item) item) ; Symbol
((atom item) item) ; Lisp Atom
; Otherwise, an instance of a structure
(cond ((setq valblock (cdr (assq item *scopieditems*))) valblock)
( t (setq oldvalblock item)
(setq defblock (getdefinition oldvalblock))
(allocval (setq length (getstructlength defblock))))
(puttypetag '*pearlinst* valblock)
(push (cons item valblock) *scopieditems*)
(setq *currenttopcopy* valblock)
(setq *currentpearlstructure* valblock)
(initbothalists valblock)
(setq *currenttopalists* (getbothalists valblock))
; Include the current environment in
; the variable assoc-list.
(putalist (cdar *blockstack*) valblock))
( t (putbothalists *currenttopalists* valblock)))
(putdef defblock valblock)
(and (setq abbrev (getabbrev oldvalblock))
; Make new abbrev and store struct in abbrev.
(setq abbrev (eval `(newsym ,abbrev)))
(putabbrev abbrev valblock))
; Copy a structure. Bound variables are replaced by their values.
; Unbound variables are installed as new local variables in the
; copy, subject to overruling by the current open blocks.
(setq *scopieditems* nil)
; Internal slot processor of PATTERNIZE.
(dm patternizeslot (none)
(setq slotvalue (getslotvalue slotnum oldvalblock))
(selectq (setq valuetype (getslotvaluetype slotnum oldvalblock))
(CONSTANT (setq slotvalue (insidepatternize slotvalue)))
(LOCAL (cond ((eq *any*conscell* slotvalue) nil)
((and (neq (cdr slotvalue) (punbound))
(not (equivclassp (cdr slotvalue))))
(setq valuetype 'CONSTANT)
(setq slotvalue (insidepatternize (cdr slotvalue))))
; Otherwise it is an unbound variable to
( t (setq slotvalue *any*conscell*))))
(ADJUNCT (setq slotvalue (insidepatternize (car slotvalue)))
(setq valuetype 'CONSTANT))
(putslotvaluetype slotnum valuetype valblock)
(putslotvalue slotnum slotvalue valblock)
(putpred slotnum (copy (getpred slotnum oldvalblock)) valblock)
(putslothooks slotnum (copy (getslothooks slotnum oldvalblock)) valblock)))
; Internal item processor of PATTERNIZE.
(de insidepatternize (item)
(defblock valblock length slotvalue valuetype oldvalblock abbrev)
((numberp item) item) ; Integer
(mapcar (function insidepatternize) item))
((psymbolp item) item) ; Symbol
((atom item) item) ; Lisp Atom
; Otherwise, an instance of a structure
(cond ((setq valblock (cdr (assq item *scopieditems*))) valblock)
( t (setq oldvalblock item)
(setq defblock (getdefinition oldvalblock))
(allocval (setq length (getstructlength defblock))))
(puttypetag '*pearlinst* valblock)
(push (cons item valblock) *scopieditems*)
(setq *currenttopcopy* valblock)
(setq *currentpearlstructure* valblock)
(initbothalists valblock)
(setq *currenttopalists* (getbothalists valblock))
; Include the current environment in
; the variable assoc-list.
(putalist (cdar *blockstack*) valblock))
( t (putbothalists *currenttopalists* valblock)))
(putdef defblock valblock)
(and (setq abbrev (getabbrev oldvalblock))
; Make new abbrev and store struct in abbrev.
(setq abbrev (eval `(newsym ,abbrev)))
(putabbrev abbrev valblock))
; Do an scopy but replace all local variables with ?*any*.
(setq *scopieditems* nil)
; Internal environment Scopy.
; Do an scopy of <item> as if it were a recursive call within
(de intscopy (item outer)
(defblock valblock length slotvalue valuetype oldvalblock
newvarcell oldvarcell abbrev)
(setq *scopieditems* nil)
((numberp item) item) ; Integer
((dtpr item) ; Lisp or Setof
(mapcar (function insidescopy) item))
((psymbolp item) item) ; Symbol
((atom item) item) ; Lisp Atom
; Otherwise, an instance of a structure
(setq defblock (getdefinition oldvalblock))
(setq valblock (allocval (setq length (getstructlength defblock))))
(puttypetag '*pearlinst* valblock)
(push (cons item valblock) *scopieditems*)
(initbothalists valblock)
(setq *currenttopcopy* outer)
(setq *currentpearlstructure* outer)
(putdef defblock valblock)
(and (setq abbrev (getabbrev oldvalblock))
; Make new abbrev and store struct in abbrev.
(setq abbrev (eval `(newsym ,abbrev)))
(putabbrev abbrev valblock))
; Internal slot processor of VARREPLACE
(dm varreplaceslot (none)
(setq slotvalue (getslotvalue slotnum item))
(selectq (setq valuetype (getslotvaluetype slotnum item))
(CONSTANT (insidevarreplace slotvalue))
(LOCAL (cond ((eq *any*conscell* slotvalue) nil)
; Bound variable, so replace with value.
((and (neq (cdr slotvalue) (punbound))
(not (equivclassp (cdr slotvalue))))
(putslotvaluetype slotnum 'CONSTANT item)
; Should the value be varreplaced like this?
(insidevarreplace (cdr slotvalue))
; Otherwise an unbound variable.
(ADJUNCT (insidevarreplace (car slotvalue)))
(GLOBAL (and (neq (setq slotvalue (eval slotvalue)) (punbound))
(not (equivclassp slotvalue))
(progn (putslotvaluetype slotnum 'CONSTANT item)
(insidevarreplace slotvalue)
; Internal item processor of VARREPLACE
(de insidevarreplace (item)
(length slotvalue valuetype)
((numberp item) item) ; Integer
((dtpr item) ; Lisp or Setof
(mapcar (function insidevarreplace) item))
((psymbolp item) item) ; Symbol
((atom item) item) ; Lisp Atom
; Otherwise, an instance of a structure
(cond ((memq item *scopieditems*) item)
( t (setq length (getstructlength (getdefinition item)))
(setq *currentpearlstructure* item)
(push item *scopieditems*)
; Go through a structure replacing bound variables by their values.
(setq *scopieditems* nil)
; Merge ITEM2 into ITEM1 by copying all bound slots of ITEM2 into
; any unfrozen slots of ITEM1.
(let ((defblock1 (getdefinition item1))
(defblock2 (getdefinition item2)))
(and (neq defblock1 defblock2)
(not (memq defblock1 (getexpansionlist defblock2)))
(progn (msg t "SMERGE: Values not mergeable: " item2
(prog (length oldvalue potential result newitem1 newitem2)
; unbind all non-frozen vars first.
(mapc (funl (cell) (rplacd cell (punbound))) (getalist item1))
(setq length (getstructlength defblock2))
(dobasehooks2< '<smerge *runsmergehooks*)
(setq potential (getvalue slotnum item2))
(setq oldvalue (getvalue slotnum item1))
(progn (putslotvalue slotnum potential item1)
(putslotvaluetype slotnum 'CONSTANT item1))))
(dobasehooks2> '>smerge *runsmergehooks*)