(in-package :mma) (defun m1 (p e name gh c) ;; p is pattern, e is expression, name (maybe nil) is the variable name ;; that would be bound in case a binding is indicated. m1 doesn't make ;; bindings directly, but through mblanks or related subroutines. ;; oddly, the "main" program here can't truly process, directly, ;; most interesting patterns. Mlist, below, is usually doing the job. ;; Why is this? While a pattern like x_ can "match anything", a pattern ;; like x__ {match a sequence} does not make much sense alone. ;; Rather f[x__] makes sense, where x__ will match all the arguments to f. ;; the |Alternatives| clause shows how backtracking can be done. ;; gh stands for governing head. ;; gh is the |Head| of the pattern that governs the attributes to make the pattern ;; e.g. in (f (|Pattern| x ...) (|Pattern| y ...) z ...) ;; in the arguments of |Pattern| [x] and [y], as well as z, the governing head is f. ;; c is a function to be called, accumulated in the matching, ;; that must return t for the match to succeed. That is, ;; The success of m1 matching requires that (funcall c) ;; result in a non-nil value. As a side effect, the global variable env ;; will contain the bindings for pattern variables. ;; ;;(print env) (let* ((hp (|Head| p)) (ha (and gh (cdr (|Attributes| gh)))) ;; if non-null gh, get attributes. could cache. (hpa (|Attributes| hp)) ) (format t "~% hp=~s, hpa=~s name=~s" hp hpa name) ;; could this be called at rule-definition time?? ;; (if (and *anyopts* (hasoptionalp p))(return-from m1 (m1 (remopts p hp) e name gh c))) (if (or (member '|Flat| hpa :test 'eq) (member '|Orderless| hpa :test 'eq)) (return-from m1 (m2 p e name gh c))) (dformat t "~%ha=~s" ha) ;; attributes of head of p (cond ;; first check for simple termination conditions in which ;; the pattern is exhausted and all that needs to be checked ;; is the functional condition that has been accumulated to this ;; point and is the 'c' function ((null p)(if (null e) (funcall c) nil)) ; check the conditions. ((atom p)(if (and (equal p e)(bindifposs name e))(funcall c) 'True nil)) ((equal p e)(and (bindifposs name e) (funcall c))) ((and (atom e)*extended-atom-match* (member hp '(|Rational| |Complex|) :test 'eq)) ;; (print 'hi) ;; check below is for "ratiop" not in GCL? (cond ((and (rationalp e) (not (integerp e))) (m1 p `(|Rational| ,(numerator e),(denominator e)) name gh c)) ;; the expression is a complex number ((complexp e) ; (print 'AHA) (let ((re (realpart e)) (im (imagpart e))) #+ignore (m1 p `(|Plus| ,re (|Times| ,im #c(0 1))) name gh c) (m1 p `(Complex ,re ,im) name gh c) ) ))) ;; check for a |Pattern|. This construction provides a NAME for ;; the result of the sub-expression matching. That is, matching ;; (|Pattern| Q <stuff>) is exactly the same as matching <stuff> ;; but with the side consequence of making the binding of the name Q ;; to the expression matching <stuff> ((eq hp '|Pattern|) (dformat t "~% calling mpattern from m1 with p=~s, e=~s gh=~s" p e gh) (mpattern p e ;the expression name;; ?? ;;nil gh ;governing head, whose |Attributes| may be important c)) ;condition, necessary for the rest of the pattern match ;; generally, the execution of this next clause signals a problem ;; in the composition of a pattern if gh has attribute Flat ((member hp '(|Blank|) :test 'eq) (dformat t "~% ~s match to expr ~s with name ~s" p e name) (mblanks p e name gh c) ) ;; generally, the execution of this next clause signals a problem ;; in the composition of a pattern anytime. ;; the reason is, we need to have the context in the pattern -- what ;; else follows the X=blank[Null]sequence, to see how much X should ;; absorb. ((member hp '(|BlankSequence| |BlankNullSequence| :test 'eq)) (dformat t "~% ~s match to expr ~s with name ~s" p e name) (mblanks p e name gh c)) ;; next, go through the cases ;; Condition belongs only on the top level of a function, and ;; probably should not be encountered here, ever ((eq hp '|Condition|) (dformat t "~%processing |Condition| ~s "(caddr p)) ;; transform the condition to be THIS condition AND whatever else. (m1 (cadr p)e name gh (let ((ccc (caddr p))) (eformat t "~%x2 p=~s e=~s c=~s" p e ccc) #'(lambda()(and (meval ccc)(funcall c))))) ) ((eq hp '|Alternatives|) ;; if we change |Alternatives| to be n-ary, ;; this still works. (dolist (alt (cdr p) nil) ; range through alternatives. (dformat t "~% check alternative ~s" alt) ;; (spushframe env '|Alternatives|) (if (m1 alt e name gh c) (return t) nil;; (spopframe env) ; if this choice failed, try another til exhausted ))) ((eq hp '|Action|) ;; would be (Action pattern (Bind name val)) ;; only case now handled (let* ((apat (cadr p)) (act (caddr p)) ; action clause looks like (Bind name val) (theact (car act)) (bindvar (cadr act)) (bindval (caddr act))) ;; assume it is a bind (dformat t "~% processing Action ~s" p) (if (eq '|Bind| theact) (m1 `(|Pattern| , bindvar (|Blank|)) bindval name gh #'(lambda()(m1 apat e name gh c))) (format t "~%invalid action specified in ~s" act)) )) ((eq hp '|Except|) (not (m1 (cadr p) e name gh c)));; not really right since bindings are lost!! ((member hp '(|Repeated| |RepeatedNull|)) (error "Matching of |Pattern| objects with |Head| ~s not installed, used in ~s" hp p)) ((eq hp '|PatternTest|) ;; a_?pred for example (m1 (cadr p)e name gh (let ((ccc (caddr p))) #'(lambda() (eformat t "~%x3 p=~s e=~s c=~s" p e c) (and (meval (list ccc e)) (funcall c)))))) ;; mlist takes care of the rest here.. ;; if (|Head| p) is neither flat nor orderless, match in order. ;; Here, we match the heads and go through the rest via mlist. ;; simplified coding here ;; Note. (|Head| p) is NOT "|Pattern|" at this point in m1 ;; now both p and e are expressions. ;; we match (recursively) their heads, and match, ;; in sequence, elements in their cdrs, by mlist. ;; in mlist we worry about attributes of phead, e.g. flat, orderless ((and (member '|Flat| ha :test 'eq) (member '|Orderless| ha :test 'eq)) (matchfol p e phead (|Default| phead) name phead c)) ;;; THIS NEXT CLAUSE IS THE MAIN LOCUS OF ACTIVITY, usually (t (print 'yy) (format t "~%name=~s" name) ;; start matching in order. ;; (format t "~%in m1 should bind name ~s to ~s" name e) (cond (name (multiple-value-bind (val found) (sfind-loc env name) (print 'xx) ;;(sfind env name) ;; (print 'ww) (cond (found (and (equal val e) ; if found and equal, don't change (m1 hp (|Head| e) nil gh #'(lambda() (eformat t "~%x4 p=~s e=~s c=~s" p e c) (mlist (rest p)(rest e) nil gh c))))) ;; no binding for name was found (t (spush env name e) (if (m1 hp (|Head| e) nil gh #'(lambda() (eformat t "~%x5 p=~s e=~s c=~s" p e c) (mlist (rest p)(rest e) nil gh c))) t (let ()(spop env) nil)))))) ((atom e) ; (format t"~% atomic e e=~s p=~s" e p) nil) ;; if no name (t (m1 hp (|Head| e) name gh #'(lambda() (eformat t "~%x6 p=~s e=~s c=~s" p e c) (mlist (rest p)(rest e) nil hp c) ))))))))