[Openmcl-devel] pattern matching

[Taoufik Dachraoui]

Hello

I wrote a matching pattern function and would like to share in order
to improve it (remove the compiler warnings for example, see below).

I started with the destruc function found in onLisp book by Paul Graham.

I modified the destruc function in order to not use the nth function (I
found it
is not efficient); instead I bind partial results in generated symbols.

Also, unlike the dbind (see onLisp), the matching pattern function returns
nil
if the structure is not matched otherwise it runs the given parameter body;
this allows us to check for alternative matches (used in compiler).

Any matching symbol x can be typed  and must be of the form (:type x #'name)
where name is a boolean function with one argument (eg. numberp, consp,
symbolp,
atom, ...)

Examples:

A pattern is a tree of symbols with possibly typed symbols

? (with-match-destruc (a (b (:type c #'symbolp))) (2 (3 4)) (list a b c))
;Compiler warnings :
;   In an anonymous lambda form: Unused lexical variable #:G2554
;   In an anonymous lambda form: Unused lexical variable #:G2555
NIL
? (with-match-destruc (a (b (:type c #'symbolp))) (2 (3 x)) (list a b c))
;Compiler warnings :
;   In an anonymous lambda form: Unused lexical variable #:G2565
;   In an anonymous lambda form: Unused lexical variable #:G2566
(2 3 X)
? (with-match-destruc (a (b c) (d (:type e #'symbolp)) f) (2 (3 4) (5 x) 6)
(list a b c d e f))
;Compiler warnings :
;   In an anonymous lambda form: Unused lexical variable #:G2598
;   In an anonymous lambda form: Unused lexical variable #:G2601
;   In an anonymous lambda form: Unused lexical variable #:G2604
(2 3 4 5 X 6)
?



(defmacro with-match-destruc (pat seq &body body)
  (let ((x (gensym)))
    `(block nil
      (let* ((,x ',seq)
     ,@(match-destruc pat x))
, at body)))))
(defun match-destruc (pat seq)
  (cond
    ((null pat) nil)
    ((symbolp pat) `(,pat (if (symbolp ,seq) ,seq (return-from nil nil))))
    ((atom pat)
     (list `(,pat
     (if (atom ,seq) ,seq (return-from nil nil)))))
    ((eq :type (car pat))
     (list `(,(second pat)
     (if (and (atom ,seq) (funcall ,(third pat) ,seq))
 ,seq (return-from nil nil)))))
    (t
     (let ((r
    (let* ((p (car pat))
   (var (gensym))
   (rec (if (null (cdr pat))
    nil
    (cons `(,var (if (consp ,seq) (cdr ,seq)
     (return-from nil nil)))
  (match-destruc (cdr pat) var)))))
      (if (atom p)
  (cons `(,p (if (consp ,seq) (car ,seq)
 (return-from nil nil))) rec)
  (if (eq (car p) :type)
      (cons `(,(second p)
      (if (and (consp ,seq) (funcall ,(third p) (car ,seq)))
  (car ,seq)
  (return-from nil nil))) rec)
      (append (match-destruc
       p
       `(if (consp ,seq)
    (car ,seq)
    (return-from nil nil)))
      rec))))))
       (if (null (cdr pat))
   (cons `(,(gensym) ; dummy (should be declared to ignore)
   (if (not (and (consp ,seq) (null (cdr ,seq))))
       (return-from nil nil)))
 r)
   r)))))


Kind regards
Taoufik
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://lists.clozure.com/pipermail/openmcl-devel/attachments/20101204/0ef7ccd0/attachment.htm>