Commit | Line | Data |
---|---|---|
6cbecd82 C |
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: |