source: trunk/source/tests/ansi-tests/pattern-match.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 1.6 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Dec  4 18:59:27 2004
4;;;; Contains: Macro for pattern matching on S-exprs
5
6(in-package :cl-test)
7
8(defmacro pmatch (pattern form)
9  (cond
10   ((consp pattern)
11    (let ((pcar (car pattern))
12          (pcdr (cdr pattern))
13          (v (gensym)))
14      (case pcar
15        ((:or)
16         `(let ((,v ,form)) (or ,@(mapcar (lambda (sub) `(pmatch ,sub ,v))
17                                          pcdr))))
18        ((:and)
19         `(let ((,v ,form)) (and ,@(mapcar (lambda (sub) `(pmatch ,sub ,v))
20                                           pcdr))))
21        ((:not)
22         (assert (eql (length pcdr) 1))
23         `(not (pmatch ,(car pcdr) ,form)))
24        (t
25         `(let ((,v ,form))
26            (and (pmatch ,pcar (car ,v))
27                 (pmatch ,pcdr (cdr ,v))))))))
28   ((eql pattern '_) t)
29   ((null pattern)
30    `(null ,form))
31   ((symbolp pattern)
32    `(eql (quote ,pattern) ,form))
33   (t
34    `(eql ,pattern ,form))))
35
36(defmacro matchcase (form &body cases)
37  (let* ((v (gensym))
38         (cond-cases
39          (mapcar
40           #'(lambda (case)
41               (assert (consp case))
42               (let ((pattern (car case))
43                     (body (cdr case)))
44                 `((pmatch ,pattern ,v) ,@body)))
45           cases)))
46    `(let ((,v ,form))
47       (cond ,@cond-cases))))
48
49(defmacro matchcase* (form &body cases)
50  (let* ((block-name (gensym "DONE"))
51         (v (gensym)))
52    `(block ,block-name
53       (let ((,v ,form))
54         (cond
55          ,@(mapcar
56             #'(lambda (case)
57                 (assert (consp case))
58                 (let ((pat (car case))
59                       (forms (cdr case))
60                       (fail-name (gensym "FAIL")))
61                   `((block ,fail-name
62                       (and (pmatch ,pat ,v)
63                            (macrolet ((fail () '(return-from ,fail-name nil)))
64                              (return-from ,block-name
65                                (progn ,@forms))))))))
66             cases))))))
67
68               
Note: See TracBrowser for help on using the repository browser.