![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to scopy.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / pearl|
Return to scopy.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / pearl |
1.1 ! root 1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; scopy.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ! 2: ; Functions for copying structures in various ways. ! 3: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ! 4: ; Copyright (c) 1983 , The Regents of the University of California. ! 5: ; All rights reserved. ! 6: ; Authors: Joseph Faletti and Michael Deering. ! 7: ! 8: ; Internal slot processor of SCOPY. ! 9: (dm scopyslot (none) ! 10: '(progn ! 11: (setq slotvalue (getslotvalue slotnum oldvalblock)) ! 12: (selectq (setq valuetype (getslotvaluetype slotnum oldvalblock)) ! 13: (CONSTANT (setq slotvalue (insidescopy slotvalue))) ! 14: (LOCAL (and (equivclassp (cdr slotvalue)) ! 15: (progn ! 16: (setq oldvarcell (cdr slotvalue)) ! 17: (setq slotvalue (cons (car slotvalue) (punbound))))) ! 18: (cond ((eq *any*conscell* slotvalue) nil) ! 19: ; Bound variable. ! 20: ((neq (cdr slotvalue) (punbound)) ! 21: (setq valuetype 'CONSTANT) ! 22: (setq slotvalue (insidescopy (cdr slotvalue)))) ! 23: ; Test for previously seen unbound variable. ! 24: ((setq newvarcell ! 25: (assq (car slotvalue) ! 26: (getalist *currenttopcopy*))) ! 27: (setq slotvalue newvarcell)) ! 28: ; Otherwise it is a new unbound variable. ! 29: ( t (setq slotvalue ! 30: (addalist (car slotvalue) ! 31: *currenttopcopy*)) ! 32: (and (equivclassp oldvarcell) ! 33: (progn ! 34: (rplacd slotvalue oldvarcell) ! 35: (rplacd oldvarcell ! 36: (cons slotvalue ! 37: (cdr oldvarcell)))))))) ! 38: (ADJUNCT (setq oldvarcell (cdr slotvalue)) ! 39: (setq slotvalue (insidescopy (car slotvalue))) ! 40: (cond ((eq *any*conscell* oldvarcell) ! 41: (setq slotvalue (cons slotvalue *any*conscell*))) ! 42: ((atom oldvarcell) ! 43: (setq slotvalue (cons slotvalue oldvarcell))) ! 44: ; Used to throw away bound adjunct variables. ! 45: ;((neq (cdr oldvarcell) (punbound)) ! 46: ; (setq valuetype 'CONSTANT) ! 47: ; (setq slotvalue (insidescopy (car slotvalue))) ! 48: ; ) ! 49: ; Test for previously seen variable. ! 50: ((setq newvarcell ! 51: (assq (car oldvarcell) ! 52: (getalist *currenttopcopy*))) ! 53: (setq slotvalue (cons slotvalue newvarcell))) ! 54: ; Otherwise it is a new variable. ! 55: ( t (setq newvarcell ! 56: (addalist (car oldvarcell) ! 57: *currenttopcopy*)) ! 58: (setq slotvalue (cons slotvalue newvarcell))))) ! 59: (GLOBAL nil)) ! 60: (putslotvaluetype slotnum valuetype valblock) ! 61: (putslotvalue slotnum slotvalue valblock) ! 62: (putpred slotnum (copy (getpred slotnum oldvalblock)) valblock) ! 63: (putslothooks slotnum (copy (getslothooks slotnum oldvalblock)) valblock))) ! 64: ! 65: ! 66: ; Internal item processor of SCOPY. ! 67: (de insidescopy (item) ! 68: (let ! 69: (defblock valblock length slotvalue valuetype oldvalblock ! 70: oldvarcell newvarcell abbrev) ! 71: (cond ((null item) nil) ! 72: ((numberp item) item) ; Integer ! 73: ((dtpr item) ; Lisp or Setof ! 74: (mapcar (function insidescopy) item)) ! 75: ((psymbolp item) item) ; Symbol ! 76: ((atom item) item) ; Lisp Atom ! 77: ; Otherwise, an instance of a structure ! 78: ((structurep item) ! 79: (cond ((setq valblock (cdr (assq item *scopieditems*))) valblock) ! 80: ( t (setq oldvalblock item) ! 81: (setq defblock (getdefinition oldvalblock)) ! 82: (setq valblock ! 83: (allocval (setq length (getstructlength defblock)))) ! 84: (puttypetag '*pearlinst* valblock) ! 85: (push (cons item valblock) *scopieditems*) ! 86: (cond (*toplevelp* ! 87: (setq *currenttopcopy* valblock) ! 88: (setq *currentpearlstructure* valblock) ! 89: (initbothalists valblock) ! 90: (setq *currenttopalists* (getbothalists valblock)) ! 91: ; Include the current environment in ! 92: ; the variable assoc-list. ! 93: (and *blockstack* ! 94: (putalist (cdar *blockstack*) valblock)) ! 95: (setq *toplevelp* nil)) ! 96: ( t (putbothalists *currenttopalists* valblock))) ! 97: ! 98: (putdef defblock valblock) ! 99: (and (setq abbrev (getabbrev oldvalblock)) ! 100: ; Make new abbrev and store struct in abbrev. ! 101: (setq abbrev (eval `(newsym ,abbrev))) ! 102: (set abbrev valblock) ! 103: ; and abbrev in struct. ! 104: (putabbrev abbrev valblock)) ! 105: (for slotnum 1 length ! 106: (scopyslot)) ! 107: valblock)))))) ! 108: ! 109: ; Copy a structure. Bound variables are replaced by their values. ! 110: ; Unbound variables are installed as new local variables in the ! 111: ; copy, subject to overruling by the current open blocks. ! 112: (de scopy (item) ! 113: (setq *scopieditems* nil) ! 114: (setq *toplevelp* t) ! 115: (insidescopy item)) ! 116: ! 117: ! 118: ! 119: ; Internal slot processor of PATTERNIZE. ! 120: (dm patternizeslot (none) ! 121: '(progn ! 122: (setq slotvalue (getslotvalue slotnum oldvalblock)) ! 123: (selectq (setq valuetype (getslotvaluetype slotnum oldvalblock)) ! 124: (CONSTANT (setq slotvalue (insidepatternize slotvalue))) ! 125: (LOCAL (cond ((eq *any*conscell* slotvalue) nil) ! 126: ; Bound variable. ! 127: ((and (neq (cdr slotvalue) (punbound)) ! 128: (not (equivclassp (cdr slotvalue)))) ! 129: (setq valuetype 'CONSTANT) ! 130: (setq slotvalue (insidepatternize (cdr slotvalue)))) ! 131: ; Otherwise it is an unbound variable to ! 132: ; be replaced by ?*any*. ! 133: ( t (setq slotvalue *any*conscell*)))) ! 134: (ADJUNCT (setq slotvalue (insidepatternize (car slotvalue))) ! 135: (setq valuetype 'CONSTANT)) ! 136: (GLOBAL nil)) ! 137: (putslotvaluetype slotnum valuetype valblock) ! 138: (putslotvalue slotnum slotvalue valblock) ! 139: (putpred slotnum (copy (getpred slotnum oldvalblock)) valblock) ! 140: (putslothooks slotnum (copy (getslothooks slotnum oldvalblock)) valblock))) ! 141: ! 142: ; Internal item processor of PATTERNIZE. ! 143: (de insidepatternize (item) ! 144: (let ! 145: (defblock valblock length slotvalue valuetype oldvalblock abbrev) ! 146: (cond ((null item) nil) ! 147: ((numberp item) item) ; Integer ! 148: ((dtpr item) ; Setof ! 149: (mapcar (function insidepatternize) item)) ! 150: ((psymbolp item) item) ; Symbol ! 151: ((atom item) item) ; Lisp Atom ! 152: ; Otherwise, an instance of a structure ! 153: ((structurep item) ! 154: (cond ((setq valblock (cdr (assq item *scopieditems*))) valblock) ! 155: ( t (setq oldvalblock item) ! 156: (setq defblock (getdefinition oldvalblock)) ! 157: (setq valblock ! 158: (allocval (setq length (getstructlength defblock)))) ! 159: (puttypetag '*pearlinst* valblock) ! 160: (push (cons item valblock) *scopieditems*) ! 161: (cond (*toplevelp* ! 162: (setq *currenttopcopy* valblock) ! 163: (setq *currentpearlstructure* valblock) ! 164: (initbothalists valblock) ! 165: (setq *currenttopalists* (getbothalists valblock)) ! 166: ; Include the current environment in ! 167: ; the variable assoc-list. ! 168: (and *blockstack* ! 169: (putalist (cdar *blockstack*) valblock)) ! 170: (setq *toplevelp* nil)) ! 171: ( t (putbothalists *currenttopalists* valblock))) ! 172: ! 173: (putdef defblock valblock) ! 174: (and (setq abbrev (getabbrev oldvalblock)) ! 175: ; Make new abbrev and store struct in abbrev. ! 176: (setq abbrev (eval `(newsym ,abbrev))) ! 177: (set abbrev valblock) ! 178: ; and abbrev in struct. ! 179: (putabbrev abbrev valblock)) ! 180: (for slotnum 1 length ! 181: (patternizeslot)) ! 182: valblock)))))) ! 183: ! 184: ; Do an scopy but replace all local variables with ?*any*. ! 185: (de patternize (item) ! 186: (setq *scopieditems* nil) ! 187: (setq *toplevelp* t) ! 188: (insidepatternize item)) ! 189: ! 190: ; Internal environment Scopy. ! 191: ; Do an scopy of <item> as if it were a recursive call within ! 192: ; an scopy of <outer>. ! 193: (de intscopy (item outer) ! 194: (let ! 195: (defblock valblock length slotvalue valuetype oldvalblock ! 196: newvarcell oldvarcell abbrev) ! 197: (setq *scopieditems* nil) ! 198: (cond ((null item) nil) ! 199: ((numberp item) item) ; Integer ! 200: ((dtpr item) ; Lisp or Setof ! 201: (mapcar (function insidescopy) item)) ! 202: ((psymbolp item) item) ; Symbol ! 203: ((atom item) item) ; Lisp Atom ! 204: ; Otherwise, an instance of a structure ! 205: ((structurep item) ! 206: (setq oldvalblock item) ! 207: (setq defblock (getdefinition oldvalblock)) ! 208: (setq valblock (allocval (setq length (getstructlength defblock)))) ! 209: (puttypetag '*pearlinst* valblock) ! 210: (push (cons item valblock) *scopieditems*) ! 211: (initbothalists valblock) ! 212: (setq *currenttopcopy* outer) ! 213: (setq *currentpearlstructure* outer) ! 214: (setq *toplevelp* nil) ! 215: (putdef defblock valblock) ! 216: (and (setq abbrev (getabbrev oldvalblock)) ! 217: ; Make new abbrev and store struct in abbrev. ! 218: (setq abbrev (eval `(newsym ,abbrev))) ! 219: (set abbrev valblock) ! 220: ; and abbrev in struct. ! 221: (putabbrev abbrev valblock)) ! 222: (for slotnum 1 length ! 223: (scopyslot)) ! 224: valblock)))) ! 225: ! 226: ; Internal slot processor of VARREPLACE ! 227: (dm varreplaceslot (none) ! 228: '(progn ! 229: (setq slotvalue (getslotvalue slotnum item)) ! 230: (selectq (setq valuetype (getslotvaluetype slotnum item)) ! 231: (CONSTANT (insidevarreplace slotvalue)) ! 232: (LOCAL (cond ((eq *any*conscell* slotvalue) nil) ! 233: ; Bound variable, so replace with value. ! 234: ((and (neq (cdr slotvalue) (punbound)) ! 235: (not (equivclassp (cdr slotvalue)))) ! 236: (putslotvaluetype slotnum 'CONSTANT item) ! 237: ; Should the value be varreplaced like this? ! 238: (putslotvalue slotnum ! 239: (insidevarreplace (cdr slotvalue)) ! 240: item)) ! 241: ; Otherwise an unbound variable. ! 242: ( t nil))) ! 243: (ADJUNCT (insidevarreplace (car slotvalue))) ! 244: (GLOBAL (and (neq (setq slotvalue (eval slotvalue)) (punbound)) ! 245: (not (equivclassp slotvalue)) ! 246: (progn (putslotvaluetype slotnum 'CONSTANT item) ! 247: (putslotvalue slotnum ! 248: (insidevarreplace slotvalue) ! 249: item))))))) ! 250: ! 251: ; Internal item processor of VARREPLACE ! 252: (de insidevarreplace (item) ! 253: (let ! 254: (length slotvalue valuetype) ! 255: (cond ((null item) nil) ! 256: ((numberp item) item) ; Integer ! 257: ((dtpr item) ; Lisp or Setof ! 258: (mapcar (function insidevarreplace) item)) ! 259: ((psymbolp item) item) ; Symbol ! 260: ((atom item) item) ; Lisp Atom ! 261: ; Otherwise, an instance of a structure ! 262: ((structurep item) ! 263: (cond ((memq item *scopieditems*) item) ! 264: ( t (setq length (getstructlength (getdefinition item))) ! 265: (cond (*toplevelp* ! 266: (setq *currentpearlstructure* item) ! 267: (setq *toplevelp* nil))) ! 268: (push item *scopieditems*) ! 269: (for slotnum 1 length ! 270: (varreplaceslot)) ! 271: item)))))) ! 272: ! 273: ; Go through a structure replacing bound variables by their values. ! 274: (de varreplace (item) ! 275: (setq *scopieditems* nil) ! 276: (setq *toplevelp* t) ! 277: (insidevarreplace item)) ! 278: ! 279: ! 280: ; Merge ITEM2 into ITEM1 by copying all bound slots of ITEM2 into ! 281: ; any unfrozen slots of ITEM1. ! 282: (de smerge (item1 item2) ! 283: (let ((defblock1 (getdefinition item1)) ! 284: (defblock2 (getdefinition item2))) ! 285: (and (neq defblock1 defblock2) ! 286: (not (memq defblock1 (getexpansionlist defblock2))) ! 287: (progn (msg t "SMERGE: Values not mergeable: " item2 ! 288: t " and " item1) ! 289: (pearlbreak))) ! 290: (prog (length oldvalue potential result newitem1 newitem2) ! 291: ; unbind all non-frozen vars first. ! 292: (mapc (funl (cell) (rplacd cell (punbound))) (getalist item1)) ! 293: (setq length (getstructlength defblock2)) ! 294: (setq result (punbound)) ! 295: (dobasehooks2< '<smerge *runsmergehooks*) ! 296: (for slotnum 1 length ! 297: (setq potential (getvalue slotnum item2)) ! 298: (setq oldvalue (getvalue slotnum item1)) ! 299: (and (pboundp potential) ! 300: (not (pboundp oldvalue)) ! 301: (progn (putslotvalue slotnum potential item1) ! 302: (putslotvaluetype slotnum 'CONSTANT item1)))) ! 303: (setq result item1) ! 304: (dobasehooks2> '>smerge *runsmergehooks*) ! 305: (return result)))) ! 306: ! 307: ! 308: ; vi: set lisp:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.