Coverage report: /home/ati/workspace/perec/query/macro.lisp

KindCoveredAll%
expression4766 71.2
branch912 75.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
2
 ;;;
3
 ;;; Copyright (c) 2006 by the authors.
4
 ;;;
5
 ;;; See LICENCE for details.
6
 
7
 (in-package :cl-perec)
8
 
9
 ;;;;
10
 ;;;; This is a macro facility for QUERY forms.
11
 ;;;; Expanders can be associated to symbols in the global environment.
12
 ;;;; Forms having a query macro symbol as their operators will
13
 ;;;; be expanded by the query compiler.
14
 ;;;;
15
 ;;;; Example:
16
 ;;;;
17
 ;;;; (define-query-macro topic-title-of (m)
18
 ;;;;   `(title-of (topic-of ,m)))
19
 ;;;; (select ((m message))
20
 ;;;;   (assert (equal (topic-title-of m) "topic"))
21
 ;;;;   (collect m))
22
 ;;;; =>
23
 ;;;; (select ((m message))
24
 ;;;;   (assert (equal (title-of (topic-of m) "topic")))
25
 ;;;;   (collect m))
26
 ;;;;
27
 
28
 (defmacro define-query-macro (name (&rest args) &body body)
29
   "Defines name as a query macro."
30
   `(progn
31
     (setf (query-macro-expander-of ',name) #'(lambda ,args ,@body))
32
     ',name))
33
 
34
 (defun query-macro-expander-of (name)
35
   "Returns the expander of the query macro named NAME, or NIL."
36
   (get name 'query-macro))
37
 
38
 (defun (setf query-macro-expander-of) (value name)
39
   "Sets the expander of the query macro named NAME."
40
   (setf (get name 'query-macro)
41
         value))
42
 
43
 (defun query-macroexpand1 (form)
44
   "Expand the query macro at the top of the FORM."
45
   (bind ((name (if (consp form) (car form)))
46
          (args (if (consp form) (cdr form)))
47
          (expander (query-macro-expander-of name)))
48
    (if expander
49
        (apply expander args)
50
        form)))
51
 
52
 (defun query-macroexpand (form)
53
   "Expand all query macros in the FORM recursively."
54
   (cond
55
     ((atom form) form)
56
     ((constantp form) form)
57
     ((query-macro-expander-of (car form))
58
      (bind (((values expanded-form expanded-p) (query-macroexpand1 form)))
59
        (if (or expanded-form expanded-p)
60
            (query-macroexpand ; TODO: detect infinite loops
61
             expanded-form)
62
            form)))
63
     (t
64
      (cons
65
       (car form)
66
       (mapcar 'query-macroexpand (cdr form))))))