Coverage report: /home/ati/workspace/perec/query/partial-eval.lisp

Kind	Covered	All	%
expression	242	282	85.8
branch	34	46	73.9

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

4

;;;

5

;;; See LICENCE for details.

6

7

(in-package :cl-perec)

8

9

(enable-pattern-reader #\M)

10

11

;;;

12

;;; Partial eval

13

;;;

14

(defun partial-eval (syntax query &optional static-vars)

15

"Returns the partially evaluated SYNTAX. The SYNTAX can be a SYNTAX-OBJECT or a lisp form

16

containing syntax objects. The result is always a SYNTAX-OBJECT."

17

(syntax-from-value (%partial-eval-syntax syntax query static-vars) syntax))

18

19

(defgeneric %partial-eval-syntax (syntax query static-vars)

20

(:documentation

21

"Partially evaluates SYNTAX and returns a partially evaluated SYNTAX-OBJECT or the value

22

if it was fully evaluated.")

23

24

(:method (syntax query static-vars)

25

(%partial-eval-syntax (parse-query-form syntax (get-variables query)) query static-vars))

26

27

(:method ((syntax syntax-object) query static-vars)

28

(error "Unknown syntax: ~S~%" syntax))

29

30

(:method ((unparsed unparsed-form) query static-vars)

31

unparsed)

32

33

(:method ((literal literal-value) query static-vars)

34

(value-of literal))

35

36

(:method ((variable variable) query static-vars)

37

variable)

38

39

(:method ((variable dynamic-variable) query static-vars)

40

(bind ((variable-name (name-of variable)))

41

(if (and (boundp variable-name) (member variable-name static-vars))

42

(symbol-value variable-name)

43

variable)))

44

45

(:method ((call macro-call) query static-vars)

46

(bind ((args (args-of call)))

47

(%partial-eval-macro-call

48

               (macro-of call) (length args) (first args) (second args) args call query static-vars)))

49

50

(:method ((call function-call) query static-vars)

51

(bind ((args (mapcar #L(%partial-eval-syntax !1 query static-vars) (args-of call))))

52

(%partial-eval-function-call

53

(fn-of call) (length args) (first args) (second args) args call)))

54

55

(:method ((form special-form) query static-vars)

56

            (%partial-eval-special-form (operator-of form) (operands-of form) form query static-vars)))

57

58

(defgeneric %partial-eval-function-call (fn n-args arg-1 arg-2 args call)

59

60

(:method (fn n-args arg-1 arg-2 args call)

61

(if (some 'syntax-object-p args)

62

                (progn (setf (args-of call) (mapcar 'syntax-from-value args (args-of call))) call)

63

(apply fn args)))

64

65

;; (typep query-variable t1) -> nil

66

;; when the types t1 and (xtype-of query-variable) does not have common subtypes

67

   (:method ((fn (eql 'typep)) (n-args (eql 2)) (variable query-variable) (type persistent-class) args call)

68

(let ((variable-type (xtype-of variable)))

69

(if (and (persistent-class-p variable-type)

70

                       (null (intersection (adjoin type (persistent-effective-sub-classes-of type))

71

                                           (adjoin variable-type (persistent-effective-sub-classes-of variable-type)))))

72

nil

73

(call-next-method))))

74

75

;; (member x nil) -> nil

76

;; (member x <list>) -> (member x <list2>) where list2 contains those elements of list,

77

;; that have matching type

78

(:method ((fn (eql 'member)) (n-args (eql 2)) object (list list) args call)

79

(bind ((type (xtype-of object))

80

                   (list (if (persistent-class-p type) (collect-if #L(typep !1 type) list) list)))

81

(cond

82

((null list) nil)

83

(t (setf args (list object list))

84

(call-next-method 'member 2 object list args call))))))

85

86

(defgeneric %partial-eval-macro-call (macro n-args arg-1 arg-2 args call query static-vars)

87

88

(:method (macro n-args arg-1 arg-2 args call query static-vars)

89

call)

90

91

(:method ((macro (eql 'and)) n-args arg-1 arg-2 args call query static-vars)

92

(%partial-eval-and/or call query static-vars))

93

94

(:method ((macro (eql 'or)) n-args arg-1 arg-2 args call query static-vars)

95

(%partial-eval-and/or call query static-vars)))

96

97

(defun %partial-eval-and/or (call query static-vars)

98

(bind ((args (mapcar #L(%partial-eval-syntax !1 query static-vars) (args-of call))))

99

(if (some 'syntax-object-p args)

100

(progn (setf (args-of call) (mapcar 'syntax-from-generalized-boolean args))

101

(simplify-boolean-syntax call))

102

(eval (cons (macro-of call) (mapcar 'boolean-from-generalized-boolean args))))))

103

104

(defgeneric %partial-eval-special-form (operator args form query static-vars)

105

;; special forms (currently not evaluated, TODO)

106

(:method (operator args form query static-vars)

107

form))

108

109

(defun syntax-from-value (value orig-syntax)

110

(cond

111

((syntax-object-p value) value)

112

((syntax-object-p orig-syntax) (make-literal-value :value value :xtype (xtype-of orig-syntax)))

113

(t (make-literal-value :value value))))

114

115

(defun syntax-from-generalized-boolean (value)

116

(if (syntax-object-p value)

117

value

118

(make-literal-value :value (if value #t #f))))

119

120

(defun boolean-from-generalized-boolean (value)

121

(assert (not (syntax-object-p value)))

122

(if value #t #f))

123

124

(defun is-true-literal (syntax)

125

"Returns #t if SYNTAX is a true literal as generalized boolean."

126

(and (typep syntax 'literal-value)

127

(not (eq (value-of syntax) #f))))

128

129

(defun is-false-literal (syntax)

130

"Returns #t if SYNTAX is a false literal."

131

(and (typep syntax 'literal-value)

132

(eq (value-of syntax) #f)))

133

134

(defun simplify-boolean-syntax (syntax)

135

"Makes the following simplifications on SYNTAX:

136

(not false) -> true

137

(not true) -> false

138

(not (not x)) -> x

139

(or) -> false

140

(or x) -> x

141

(or x... false y...) -> (or x... y...)

142

(or x... true y...) -> true

143

(or x... (or y...) z...) -> (or x... y... z...)

144

(and) -> true

145

(and x) -> x

146

(and x... true y...) -> (and x... y...)

147

(and x... false y...) -> false

148

(and x... (and y...) z...) -> (and x... y... z...)

149

150

where x, y and z are arbitrary objects and '...' means zero or more occurence,

151

and false/true means a generalized boolean literal."

152

153

(flet ((simplify-args (operator args)

154

(iter (for arg in args)

155

(for simplified = (simplify-boolean-syntax arg))

156

(if (and (macro-call-p simplified) (eq (macro-of simplified) operator))

157

(appending (args-of simplified))

158

(collect simplified)))))

159

(pattern-case syntax

160

(#M(function-call :fn not :args (?arg))

161

(bind ((arg (simplify-boolean-syntax ?arg)))

162

(pattern-case arg

163

(#M(function-call :fn not :args (?arg)) ?arg)

164

(#M(literal-value :value #f) (make-literal-value :value #t))

165

(#M(literal-value :value ?true) (make-literal-value :value #f))

166

(?otherwise syntax))))

167

(#M(macro-call :macro or :args ?args)

168

(bind ((operands (remove-if 'is-false-literal (simplify-args 'or ?args))))

169

(cond

170

((null operands) (make-literal-value :value #f))

171

((length=1 operands) (first operands))

172

((find-if 'is-true-literal operands) (make-literal-value :value #t))

173

(t (make-macro-call :macro 'or :args operands)))))

174

(#M(macro-call :macro and :args ?args)

175

(bind ((operands (remove-if 'is-true-literal (simplify-args 'and ?args))))

176

(cond

177

((null operands) (make-literal-value :value #t))

178

((length=1 operands) (first operands))

179

((find-if 'is-false-literal operands) (make-literal-value :value #f))

180

(t (make-macro-call :macro 'and :args operands)))))

181

(?otherwise syntax))))