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

Kind	Covered	All	%
expression	258	271	95.2
branch	37	46	80.4

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

;;;; Type specifier:

10

;;;;

11

;;;; persistent-class (type of persistent classes)

12

;;;; persistent classes (types of persistent objects)

13

;;;; names of persistent classes

14

;;;; lisp type specifiers for slots

15

;;;; and,or,not combinations

16

;;;;

17

;;;; Type expression:

18

;;;; an expression that evaluates to a type specifier

19

;;;;

20

21

(defun infer-types (query)

22

"Annotates types to the SYNTAX nodes of the query."

23

(mapcan-asserts #L(aif (infer-types-pass-1 !1 query) (list it) nil) query)

24

(mapc-query #L(infer-types-pass-2 !1 query #t) query))

25

26

(defun mapcan-asserts (fn query)

27

(setf (asserts-of query) (mapcan fn (asserts-of query))))

28

29

(defun mapc-query (fn query)

30

(mapc fn (asserts-of query))

31

(mapc fn (action-args-of query))

32

(mapc #L(when (syntax-object-p !1) (funcall fn !1)) (order-by-of query)))

33

34

(defgeneric infer-types-pass-1 (syntax query)

35

(:method (syntax query)

36

syntax)

37

38

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

39

            (infer-types-pass-1-function-call (fn-of call) (first (args-of call)) (second (args-of call)) call query))

40

41

)

42

43

(defgeneric infer-types-pass-1-function-call (fn arg1 arg2 call query)

44

(:method (fn arg1 arg2 call query)

45

call)

46

47

;; toplevel (typep <query-variable> <type>)

48

(:method ((fn (eql 'typep)) (variable query-variable) type call query)

49

(restrict-variable-type variable (type-syntax->type type))

50

nil))

51

52

(defgeneric infer-types-pass-2 (syntax query &optional toplevel)

53

(:method (syntax query &optional toplevel)

54

(declare (ignore syntax query toplevel))

55

(values))

56

57

(:method ((form compound-form) query &optional toplevel)

58

(declare (ignore toplevel))

59

(mapc #L(infer-types-pass-2 !1 query #f) (operands-of form)))

60

61

(:method ((access slot-access) query &optional toplevel)

62

(declare (ignore toplevel))

63

(call-next-method)

64

(setf (slot-of access) (slot-for-slot-access access))

65

(when (slot-of access)

66

(setf (xtype-of access)

67

(slot-definition-type (slot-of access)))))

68

69

;; toplevel (eq <obj1> <obj2>) -> (type-of <obj1>) == (type-of <obj2>)

70

(:method ((call function-call) query &optional toplevel)

71

(call-next-method)

72

(when (and toplevel

73

(member (fn-of call) '(eq eql equal = string=))

74

(= (length (args-of call)) 2))

75

(bind ((obj1 (first (args-of call)))

76

(obj2 (second (args-of call))))

77

(cond

78

((and (not (has-default-type-p obj1)) (has-default-type-p obj2))

79

(setf (xtype-of obj2) (xtype-of obj1)))

80

((and (has-default-type-p obj1) (not (has-default-type-p obj2)))

81

(setf (xtype-of obj1) (xtype-of obj2))))))))

82

83

(defun type-syntax->type (type)

84

(if (and (literal-value-p type)

85

(typep (value-of type) 'persistent-class))

86

(value-of type)

87

type))

88

89

(defun normalized-type-for* (type)

90

(if (eq type +unknown-type+)

91

+unknown-type+

92

(awhen (normalized-type-for type)

93

(cond

94

((set-type-p it) (find-class (set-type-class-for it)))

95

((persistent-class-name-p it) (find-class it))

96

(t type)))))

97

98

(defun restrict-variable-type (variable type)

99

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

100

(cond

101

((eq orig-type +persistent-object-class+) (setf (xtype-of variable) type))

102

((and (listp orig-type) (eq (first orig-type) 'and)) (appendf (xtype-of variable) type))

103

(t (setf (xtype-of variable) (list 'and orig-type type))))))

104

105

(defgeneric slot-for-slot-access (access)

106

(:method ((access slot-access))

107

(find-slot-by-owner-type (arg-of access)

108

                                     (effective-slots-for-accessor (accessor-of access))

109

(accessor-of access)))

110

(:method ((access association-end-access))

111

(find-slot-by-owner-type (arg-of access)

112

                                     (effective-association-ends-for-accessor (accessor-of access))

113

(accessor-of access))))

114

115

(defun find-slot-by-owner-type (owner slots accessor)

116

(flet ((qualified-name-of (slot)

117

(concatenate-symbol (class-name (slot-definition-class slot))

118

":"

119

(slot-definition-name slot))))

120

(bind ((owner-type (normalized-type-for* (xtype-of owner))))

121

(acond

122

((length=1 slots)

123

(first slots))

124

((and (not (eq owner-type +unknown-type+))

125

(not (contains-syntax-p owner-type))

126

(find owner-type slots :key 'slot-definition-class :test 'subtypep))

127

it)

128

(t

129

(warn "Cannot find the slot for the acccessor ~A.

130

Possible candidates are ~A, owner type is ~A."

131

accessor

132

(mapcar #'qualified-name-of slots)

133

owner-type)

134

nil)))))

135

136

(defgeneric backquote-type-syntax (type)

137

(:documentation "Generates a type expression that evaluates to the type.")

138

139

(:method ((self-evaluating t))

140

self-evaluating)

141

142

(:method ((class persistent-class))

143

class)

144

145

(:method ((type-name symbol))

146

`(quote ,type-name))

147

148

(:method ((type syntax-object))

149

type)

150

151

(:method ((combined-type list))

152

`(list

153

',(first combined-type)

154

,@(mapcar 'backquote-type-syntax (rest combined-type)))))

155

156

(defun has-default-type-p (syntax)

157

(eq (xtype-of syntax)

158

(funcall (slot-definition-initfunction

159

(find-slot (class-name (class-of syntax)) 'xtype)))))

160

161

(defun contains-syntax-p (type)

162

(or (typep type 'syntax-object)

163

(and (consp type)

164

(some #'contains-syntax-p type))))

165

166

(defun maybe-null-subtype-p (type)

167

(or (eq type +unknown-type+)

168

(null-subtype-p type)))