Return to match.l CVS log

Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / pearl

Annotation of 43BSD/ucb/lisp/pearl/match.l, revision 1.1

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.