![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to match.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / pearl|
Return to match.l CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / pearl |
1.1 root 1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; match.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2: ; Functions for matching, comparing, and testing structures.
3: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4: ; Copyright (c) 1983 , The Regents of the University of California.
5: ; All rights reserved.
6: ; Authors: Joseph Faletti and Michael Deering.
7: ; Unification added by David Chin.
8:
9: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10: ; Functions which accomplish unification of two variables.
11:
12: ; Turns on unification (irrevocably).
13: (de useunification ()
14: (setq *unifyunbounds* t)
15: 'UsingUnification)
16:
17: ; sets all variables in the var list of the equiv class (first arg) which are
18: ; still bound to the equiv class to the new value (second arg).
19: (defmacro setequivclass (equiv value)
20: `(mapc (funl (var)
21: (cond ((dtpr var) ; a local var cell
22: ; If bound to equiv class, then save the old value
23: ; and set the var to value.
24: (and (eq (cdr var) ,equiv)
25: (push (cons var (cdr var)) *equivsavestack*)
26: (rplacd var ,value)))
27: ( t ; otherwise a global var.
28: (and (eq (eval var) ,equiv)
29: (push (cons var (eval var)) *equivsavestack*)
30: (set var ,value)))))
31: (cdr ,equiv)))
32:
33: ; unifies two unbound variables (0, one or both may already be equiv classes).
34: (dm unifytwovars (none)
35: '(progn (setq xval (cond ((dtpr xvar) (cdr xvar))
36: ( t (eval xvar))))
37: (setq yval (cond ((dtpr yvar) (cdr yvar))
38: ( t (eval yvar))))
39: (cond ((eq xvar yvar)
40: ; Same variable, so leave xvar and yvar alone.
41: (setq newval nil))
42: ; Both values are unbound so create a new equiv class.
43: ((and (eq xval (punbound))
44: (eq yval (punbound)))
45: (setq newval (cons (equivclass) (list xvar yvar))))
46: ; Same equiv class (not "unbound"), so leave xvar & yvar alone.
47: ((eq xval yval)
48: (setq newval nil))
49: ; Both are equiv classes, so merge into a new equiv class.
50: ((and (pboundp xval)
51: (pboundp yval))
52: (setq newval
53: (cons (equivclass)
54: (cond ((<& (length (cdr xval))
55: (length (cdr yval)))
56: (append (cdr xval) (cdr yval)))
57: ( t (append (cdr yval) (cdr xval))))))
58: ; And change the equiv class for the other vars in the list.
59: (setequivclass xval newval)
60: (setequivclass yval newval))
61: ((punboundatomp xval) ; xvar is not an equiv class.
62: (cond ((memq xvar (cdr yval)) ; but used to be in yvar's.
63: (setq newval yval))
64: ( t ; else build a new equiv class with yvar added.
65: (setq newval (cons (equivclass)
66: (cons xvar (cdr yval))))
67: (setequivclass yval newval))))
68: ( t ; otherwise yvar is not an equiv class.
69: (cond ((memq yvar (cdr xval)) ; but used to be in xvar's.
70: (setq newval xval))
71: ( t ; else build a new equiv class with xvar added.
72: (setq newval (cons (equivclass)
73: (cons yvar (cdr xval))))
74: (setequivclass xval newval)))))
75: ; Set the variables to a new equiv class created above.
76: (and newval
77: (progn
78: ; Save the old values in case match fails
79: (push (cons xvar xval) *equivsavestack*)
80: (push (cons yvar yval) *equivsavestack*)
81: ; And set variables (either local or global).
82: (cond ((dtpr xvar) (rplacd xvar newval))
83: ( t (set xvar newval)))
84: (cond ((dtpr yvar) (rplacd yvar newval))
85: ( t (set yvar newval)))))
86: ))
87:
88: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
89: ; Low level macros for matching.
90:
91: ; Fast macro for minimum of two lengths.
92: (defmacro min& (n1 n2)
93: `(let ((min ,n1)
94: (other ,n2))
95: (and (>& min other)
96: (setq min other))
97: min))
98:
99: ; Unbind all vars on the item's assoc list
100: (defmacro unbindvars (item)
101: `(mapc (funl (cell) (rplacd cell (punbound))) (getalist ,item)))
102:
103: ; Set the GLOBAL or VAR variable to the value.
104: (defmacro varset (var val)
105: `(let ((localvar ,var)
106: (localval ,val)
107: savevarval)
108: (cond ((dtpr localvar)
109: (setq savevarval (cdr localvar))
110: (rplacd localvar localval))
111: ( t (push localvar *globalsavestack*)
112: (setq savevarval (eval localvar))
113: (set localvar localval)))
114: (and *unifyunbounds*
115: (equivclassp savevarval)
116: (setequivclass savevarval localval))))
117:
118: ; Set the GLOBAL or VAR adjunct variable to the value.
119: (defmacro adjvarset (var val)
120: `(let ((localvar ,var)
121: (localval ,val)
122: savevarval)
123: (and localvar
124: (progn (cond ((dtpr localvar)
125: (setq savevarval (cdr localvar))
126: (rplacd localvar localval))
127: ( t (push localvar *globalsavestack*)
128: (setq savevarval (eval localvar))
129: (set localvar localval)))
130: (and *unifyunbounds*
131: (equivclassp savevarval)
132: (setequivclass savevarval localval))))))
133:
134: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
135: ; Macros for matching individual values.
136:
137: ; Check whether VAL is consistent with the predicates in PREDLIST.
138: (defmacro consistentvalue (val predlist type item defblock)
139: `(prog (restriction)
140: loop
141: (cond ((null ,predlist) (return t)) ; all predicates were true.
142: ; Otherwise, execute the next one.
143: ((cond ((reallitatom (setq restriction (pop ,predlist)))
144: ; The name of a function to be applied.
145: (apply* restriction (ncons ,val)))
146: ; An s-expression predicate -- fill in and execute.
147: ((dtpr restriction)
148: (eval (fillin1 restriction ,val ,item ,defblock)))
149: ; Otherwise, a value.
150: ( t
151: (selectq ,type
152: (0 (or (let ((def (getdefinition ,val)))
153: (eq restriction def))
154: (disguisedas ,val restriction)))
155: (1 (disguisedas ,val restriction))
156: (2 (\=& restriction ,val))
157: (3 (eq restriction ,val))
158: (otherwise
159: ; A better way needed ?? Never done????
160: (eq restriction (car ,val))))))
161: (go loop))
162: ; Otherwise this predicate failed, so we fail.
163: ( t (return nil)))))
164:
165: ; Check two values for "equality".
166: (defmacro equalvalue (xval yval type)
167: `(selectq ,type
168: (0 (basicmatch ,xval ,yval))
169: (1 (eq ,xval ,yval))
170: (2 (\=& ,xval ,yval))
171: (3 (equal ,xval ,yval))
172: (otherwise
173: ; A better way needed!!!!!!!!!!!!!!!!!!! something like:
174: ; (apply (function and)
175: ; (mapcar (function equalvalue) ,xval ,yval (strip ,type)))
176: t)))
177:
178: ; Check to see if two slots whose number is passed are matchable,
179: ; binding any variables and running any predicates.
180: ; Assumes slotnum, item1, item2, def1, def2 already set and others declared
181: ; in main PROG. The local PROG is necessary for slothooks processing.
182: (dm compatible (none)
183: '(prog ()
184: ; *val and *var are both set by these calls.
185: ; *var are set to nil if no local, global, or adjunct variable.
186: (setq xval (getvarandvalue slotnum item1 'xvar))
187: (setq yval (getvarandvalue slotnum item2 'yvar))
188: ;
189: ; *ANY* => always match
190: (and (or (eq xvar *any*conscell*)
191: (eq yvar *any*conscell*))
192: (return t))
193: ;
194: ; If both are unbound, return *matchunboundsresult* (initially nil).
195: (setq xvalunbound (punboundatomp xval))
196: (setq yvalunbound (punboundatomp yval))
197: (setq bothunbound (and xvalunbound yvalunbound))
198: (and bothunbound
199: (or *unifyunbounds*
200: (return *matchunboundsresult*)))
201: ;
202: ; Get the slots' common type and individual predicates.
203: (setq slottype (getslottype slotnum def1))
204: (setq xpredlist (getpred slotnum item1))
205: (setq ypredlist (getpred slotnum item2))
206: (doslothooks2< '<match *runmatchhooks*)
207: ;
208: ; Otherwise we check to see if one of the slots can be
209: ; bound to the other.
210: (cond (bothunbound ; Two unbound variables to be unified.
211: (unifytwovars)
212: (setq result t))
213: (xvalunbound ; Match x's variable against y's value.
214: (and (setq result
215: (consistentvalue yval xpredlist slottype item2 def2))
216: (varset xvar yval)))
217: (yvalunbound ; Match y's variable against x's value.
218: (and (setq result
219: (consistentvalue xval ypredlist slottype item1 def1))
220: (varset yvar xval)))
221: ( t ; both are bound values -- check "equality".
222: (and (setq result (equalvalue xval yval slottype))
223: ; and set the adjunct variables (if any)
224: (progn (adjvarset xvar yval)
225: (adjvarset yvar xval)))))
226: (doslothooks2> '>match *runmatchhooks*)
227: (return result)))
228:
229: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
230: ; Principle match functions.
231:
232: ; Match two structures slot by slot, WITHOUT unbinding variables first,
233: ; but binding along the way.
234: (de basicmatch (item1 item2)
235: (prog (newitem1 newitem2 result slottype xvar yvar xval yval def1 def2
236: xvalunbound yvalunbound length
237: newxval newyval xpredlist ypredlist xhooks yhooks
238: newval bothunbound)
239: (setq def1 (getdefinition item1))
240: (setq def2 (getdefinition item2))
241: (setq length (getstructlength def1))
242: (dobasehooks2< '<match *runmatchhooks*)
243: (cond ((eq item1 item2) (setq result t)) ; Same structure -> t.
244: ; Not even related -> nil.
245: ((not (eq def1 def2)) (setq result nil))
246: ; No slots -> t.
247: ((\=& 0 length) (setq result t))
248: ; Otherwise, compare slot by slot.
249: ( t (setq result
250: (for slotnum 1 length
251: (or (compatible)
252: (return nil))))))
253: (dobasehooks2> '>match *runmatchhooks*)
254: (return result)))
255:
256: ; Match two structures slot by slot, unbinding variables first.
257: (de standardmatch (item1 item2)
258: (prog (newitem1 newitem2 result slottype xvar yvar xval yval def1 def2
259: xvalunbound yvalunbound length *globalsavestack*
260: newxval newyval xpredlist ypredlist xhooks yhooks
261: newval bothunbound *equivsavestack*)
262: (unbindvars item1)
263: (unbindvars item2)
264: (setq def1 (getdefinition item1))
265: (setq def2 (getdefinition item2))
266: (setq length (getstructlength def1))
267: (dobasehooks2< '<match *runmatchhooks*)
268: (cond ((eq item1 item2) (setq result t)) ; Same structure -> t.
269: ; Not even related -> nil.
270: ((not (eq def1 def2)) (setq result nil))
271: ; No slots -> t.
272: ((\=& 0 length) (setq result t))
273: ; Otherwise, compare slot by slot.
274: ( t (setq result
275: (for slotnum 1 length
276: (or (compatible)
277: (return nil))))))
278: (dobasehooks2> '>match *runmatchhooks*)
279: (or result
280: ; Clean up the variables because of the failure.
281: (progn (unbindvars item1)
282: (unbindvars item2)
283: (and *globalsavestack*
284: (mapc (funl (var)
285: (set var (punbound)))
286: *globalsavestack*))
287: ; *equivsavestack* is only non-nil when *unifyunbounds* is t.
288: (and *equivsavestack*
289: (mapc (funl (pair)
290: (cond ((dtpr (car pair))
291: (rplacd (car pair) (cdr pair)))
292: ( t (set (car pair) (cdr pair)))))
293: *equivsavestack*))))
294: (return result)))
295:
296: (aliasdef 'match 'standardmatch)
297:
298: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
299: ; Functions similar to above but for expanded structures.
300:
301: ; Check to see either defblock is an expansion of the other.
302: (defmacro relatedhier (defblock1 defblock2)
303: `(or (eq ,defblock1 ,defblock2)
304: (memq ,defblock2 (getexpansionlist ,defblock1))
305: (memq ,defblock1 (getexpansionlist ,defblock2))))
306:
307: ; Check whether VAL is consistent with the predicates in PREDLIST.
308: (defmacro expconsistentvalue (val predlist type item defblock)
309: `(prog (restriction)
310: loop
311: (cond ((null ,predlist) (return t)) ; all predicates were true.
312: ; Otherwise, execute the next one.
313: ((cond ((reallitatom (setq restriction (pop ,predlist)))
314: ; The name of a function to be applied.
315: (apply* restriction (ncons ,val)))
316: ; An s-expression predicate -- fill in and execute.
317: ((dtpr restriction)
318: (eval (fillin1 restriction ,val ,item ,defblock)))
319: ; Otherwise, a value.
320: ( t
321: (selectq ,type
322: (0 (or (let ((def (getdefinition ,val)))
323: (relatedhier restriction def))
324: (disguisedas ,val restriction)))
325: (1 (disguisedas ,val restriction))
326: (2 (\=& restriction ,val))
327: (3 (eq restriction ,val))
328: (otherwise
329: ; A better way needed ?? Never done????
330: (eq restriction (car ,val))))))
331: (go loop))
332: ; Otherwise this predicate failed, so we fail.
333: ( t (return nil)))))
334:
335: ; Check two values for "equality".
336: (defmacro expequalvalue (xval yval type)
337: `(selectq ,type
338: (0 (basicexpandedmatch ,xval ,yval))
339: (1 (eq ,xval ,yval))
340: (2 (\=& ,xval ,yval))
341: (3 (equal ,xval ,yval))
342: (otherwise
343: ; A better way needed!!!!!!!!!!!!!!!!!!! something like:
344: ; (apply (function and)
345: ; (mapcar (function expequalvalue) ,xval ,yval (strip ,type)))
346: t)))
347:
348: ; Check to see if two slots whose number is passed are matchable,
349: ; binding any variables and running any predicates.
350: ; Assumes slotnum, item1, item2, def1, def2 already set and others declared
351: ; in main PROG. The local PROG is necessary for slothooks processing.
352: (dm expcompatible (none)
353: '(prog ()
354: ; *val and *var are both set by these calls.
355: ; *var are set to nil if no local, global, or adjunct variable.
356: (setq xval (getvarandvalue slotnum item1 'xvar))
357: (setq yval (getvarandvalue slotnum item2 'yvar))
358: ;
359: ; *ANY* => always match
360: (and (or (eq xvar *any*conscell*)
361: (eq yvar *any*conscell*))
362: (return t))
363: ;
364: ; If both are unbound, return *matchunboundsresult* (initially nil).
365: (setq xvalunbound (punboundatomp xval))
366: (setq yvalunbound (punboundatomp yval))
367: (setq bothunbound (and xvalunbound yvalunbound))
368: (and bothunbound
369: (or *unifyunbounds*
370: (return *matchunboundsresult*)))
371: ;
372: ; Get the slots' common type and individual predicates.
373: (setq slottype (getslottype slotnum def1))
374: (setq xpredlist (getpred slotnum item1))
375: (setq ypredlist (getpred slotnum item2))
376: (doslothooks2< '<match *runmatchhooks*)
377: ;
378: ; Otherwise we check to see if one of the slots can be
379: ; bound to the other.
380: (cond (bothunbound ; Two unbound variables to be unified.
381: (unifytwovars)
382: (setq result t))
383: (xvalunbound ; Match x's variable against y's value.
384: (and (setq result
385: (expconsistentvalue yval xpredlist slottype
386: item2 def2))
387: (varset xvar yval)))
388: (yvalunbound ; Match y's variable against x's value.
389: (and (setq result
390: (expconsistentvalue xval ypredlist slottype
391: item1 def1))
392: (varset yvar xval)))
393: ( t ; both are bound values -- check "equality".
394: (and (setq result (expequalvalue xval yval slottype))
395: ; and set the adjunct variables (if any)
396: (progn (adjvarset xvar yval)
397: (adjvarset yvar xval)))))
398: (doslothooks2> '>match *runmatchhooks*)
399: (return result)))
400:
401: ; Match two structures slot by slot, WITHOUT unbinding variables first,
402: ; but binding along the way.
403: (de basicexpandedmatch (item1 item2)
404: (prog (newitem1 newitem2 result slottype xvar yvar xval yval def1 def2
405: xvalunbound yvalunbound length
406: newxval newyval xpredlist ypredlist xhooks yhooks
407: newval bothunbound)
408: (setq def1 (getdefinition item1))
409: (setq def2 (getdefinition item2))
410: (setq length (min& (getstructlength def1)
411: (getstructlength def2)))
412: (dobasehooks2< '<match *runmatchhooks*)
413: (cond ((eq item1 item2) (setq result t)) ; Same structure -> t.
414: ; Not even related hierarchically -> nil.
415: ((not (relatedhier def1 def2)) (setq result nil))
416: ; No slots -> t.
417: ((\=& 0 length) (setq result t))
418: ; Otherwise, compare slot by slot.
419: ( t (setq result
420: (for slotnum 1 length
421: (or (expcompatible)
422: (return nil))))))
423: (dobasehooks2> '>match *runmatchhooks*)
424: (return result)))
425:
426: ; Match two structures slot by slot, unbinding variables first.
427: (de standardexpandedmatch (item1 item2)
428: (prog (newitem1 newitem2 result slottype xvar yvar xval yval def1 def2
429: xvalunbound yvalunbound length *globalsavestack*
430: newxval newyval xpredlist ypredlist xhooks yhooks
431: newval bothunbound *equivsavestack*)
432: (unbindvars item1)
433: (unbindvars item2)
434: (setq def1 (getdefinition item1))
435: (setq def2 (getdefinition item2))
436: (setq length (min& (getstructlength def1)
437: (getstructlength def2)))
438: (dobasehooks2< '<match *runmatchhooks*)
439: (cond ((eq item1 item2) (setq result t)) ; Same structure -> t.
440: ; Not even related hierarchically -> nil.
441: ((not (relatedhier def1 def2)) (setq result nil))
442: ; No slots -> t.
443: ((\=& 0 length) (setq result t))
444: ; Otherwise, compare slot by slot.
445: ( t (setq result
446: (for slotnum 1 length
447: (or (expcompatible)
448: (return nil))))))
449: (dobasehooks2> '>match *runmatchhooks*)
450: (or result
451: ; Clean up the variables because of the failure.
452: (progn (unbindvars item1)
453: (unbindvars item2)
454: (and *globalsavestack*
455: (mapc (funl (var)
456: (set var (punbound)))
457: *globalsavestack*))
458: ; *equivsavestack is only non-nil when *unifyunbounds* is t.
459: (and *equivsavestack*
460: (mapc (funl (var)
461: (cond ((dtpr (car var))
462: (rplacd (car var) (cdr var)))
463: ( t (set (car var) (cdr var)))))
464: *equivsavestack*))
465: ))
466: (return result)))
467:
468: (aliasdef 'expandedmatch 'standardexpandedmatch)
469:
470: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
471: ; Functions for testing for equality and other comparisons.
472:
473: ; Check to see if two slots passed (with a type number) are EQUAL,
474: ; NOT binding any variables OR checking any predicates.
475: (dm slotequal (none)
476: '(prog ()
477: ; *val and *var are both set by these calls.
478: ; *var are set to nil if no local, global, or adjunct variable.
479: (setq xval (getvarandvalue slotnum item1 'xvar))
480: (setq yval (getvarandvalue slotnum item2 'yvar))
481: ;
482: ; If the slot of the first ITEM is unbound, fail
483: (and (punboundatomp xval)
484: (progn (msg t "Unbound variables not allowed in STREQUAL" t)
485: (pearlbreak)))
486: ; If the slot of the second ITEM is unbound, fail
487: (and (punboundatomp yval)
488: (progn (msg t "Unbound variables not allowed in STREQUAL" t)
489: (pearlbreak)))
490: ;
491: ; Get the slots' common type.
492: (setq slottype (getslottype slotnum def1))
493: (doslothooks2< '<strequal *runstrequalhooks*)
494: (setq result
495: (selectq slottype
496: (0 (strequal xval yval))
497: (1 (eq xval yval))
498: (2 (\=& xval yval))
499: (3 (equal xval yval))
500: (otherwise
501: ; A better way needed!!!!!!!!!!!!!!!!!!!
502: (equal xval yval))))
503: (doslothooks2> '>strequal *runstrequalhooks*)
504: (return result)))
505:
506: ; Test two structures for "EQUAL"ity slot by slot, without unbinding
507: ; variables first, and NOT binding along the way.
508: (de strequal (item1 item2)
509: (prog (newitem1 newitem2 result slottype xvar yvar xval yval
510: def1 def2 length newxval newyval xhooks yhooks)
511: (setq def1 (getdefinition item1))
512: (setq def2 (getdefinition item2))
513: (setq length (getstructlength def1))
514: (dobasehooks2< '<strequal *runmatchhooks*)
515: (cond ((eq item1 item2) (setq result t)) ; Same structure -> t.
516: ; Not even same type -> nil.
517: ((neq def1 def2) (setq result nil))
518: ; No slots -> t.
519: ((\=& 0 length) (setq result t))
520: ; Otherwise, compare slot by slot.
521: ( t (setq result
522: (for slotnum 1 length
523: (or (slotequal)
524: (return nil))))))
525: (dobasehooks2> '>strequal *runmatchhooks*)
526: (return result)))
527:
528: ; Check to see if ITEM1 is an expansion of ITEM2.
529: (de isanexpanded (item1 item2)
530: (let ((defblock1 (getdefinition item1))
531: (defblock2 (getdefinition item2)))
532: (or (eq defblock1 defblock2)
533: (memq defblock1 (getexpansionlist defblock2)))))
534:
535: ; Check to see if ITEM1 is (an expansion of) the base with name NAME.
536: (de isa (item1 name)
537: (let ((defblock (getdefinition item1))
538: (typedef (eval (defatom name))))
539: (or (eq defblock typedef)
540: (memq defblock (getexpansionlist typedef)))))
541:
542: ; Test item to see if it's a nilstruct.
543: (de nullstruct (item)
544: (eq (getdefinition item)
545: (eval (defatom 'nilstruct))))
546:
547: ; Test item to see if it's a nilsym.
548: (de nullsym (item)
549: (eq item
550: (eval (symatom 'nilsym))))
551:
552: (de memmatch (item list)
553: (cond ((null list) nil)
554: ((not (dtpr list)) nil)
555: ((match item (car list)) list)
556: ( t (memmatch item (cdr list)))))
557:
558: (de memstrequal (item list)
559: (cond ((null list) nil)
560: ((not (dtpr list)) nil)
561: ((strequal item (car list)) list)
562: ( t (memstrequal item (cdr list)))))
563:
564: ; vi: set lisp:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.