darcs - smoke

1 ;;; NOTE -using-type is disabled for now, since it is not used.

3 (in-package :smoke)

5 (defmacro with-object-as-object (object &body body)

6 `(macrolet ((,(symbolicate object '.typep)

7 (type)

8 `(typep ,',object ,type))

9 (,(symbolicate object '.type-of) ()

10 `(class-of ,',object))

11 (using-typep () nil)

12 (call-using-types (function-name &rest args)

13 `(,function-name ,@args))

14 (call-using-type (function-name &rest args)

15 `(,function-name ,@args)))

16 ,@body))

18 (defun typep-using-type (object-type type)

19 "Returns true when OBJECT-TYPE is a subtype of TYPE,

20 false when it is not."

21 (declare (values (member t nil :maybe)))

22 (multiple-value-bind (subtype-p valid-p)

23 (subtypep object-type type)

24 (if subtype-p

25 t

26 (if valid-p

27 (multiple-value-bind (subtype-p valid-p)

28 (subtypep type object-type)

29 (if subtype-p

30 (throw 'unspecific-type (values object-type type))

31 (if valid-p

32 (if (and (subtypep type 'integer)

33 (not (integer-types-disjunct-p object-type type)))

34 (throw 'unspecific-type (values object-type type))

35 nil)

36 (throw 'unspecific-type (values object-type type)))))

37 (throw 'unspecific-type (values object-type))))))

39 (defmacro with-object-as-type (object-type &body body)

40 `(macrolet ((,(symbolicate object-type '.typep)

41 (type)

42 `(typep-using-type ,',object-type ,type))

43 (,(symbolicate object-type '.type-of) ()

44 (quote ,object-type))

45 (using-typep () t)

46 (call-using-types (function-name &rest args)

47 `(,(symbolicate function-name '-using-types)

48 ,@args))

49 (call-using-type (function-name &rest args)

50 `(,(symbolicate function-name '-using-type)

51 ,@args)))

52 ,@body))

54 (defmacro defun+using-type (name object lambda-list &body body)

55 "Defines the functions NAME and NAME-using-type where the argument

56 OBJECT of LAMBDA-LIST is an object respective its type.

57 For OBJECT the functions OBJECT.typep and OBJECT.type-of can be used."

58 `(progn

59 (with-object-as-object ,object

60 (defun ,name ,lambda-list

61 ,@body))

62 (with-object-as-type ,object

63 (defun ,(symbolicate name '-using-type) ,lambda-list

64 ,@body))))

66 (defmacro defun+using-types (name lambda-list &body body)

67 `(progn (macrolet ((call-using-types (function-name &rest args)

68 `(,function-name ,@args))

69 (call-using-type (function-name &rest args)

70 `(,function-name ,@args))

71 (using-typep () nil)

72 (function-using-types (name)

73 `(function ,name)))

74 (defun ,name ,lambda-list

75 ,@body))

76 (macrolet ((call-using-types (function-name &rest args)

77 `(,(symbolicate function-name '-using-types)

78 ,@args))

79 (call-using-type (function-name &rest args)

80 `(,(symbolicate function-name '-using-type)

81 ,@args))

82 (using-typep () t)

83 (function-using-types (name)

84 `(function ,(symbolicate name '-using-types))))

85 (defun ,(symbolicate name '-using-types) ,lambda-list

86 ,@body))))

88 (defun integer-types-disjunct-p (type1 type2)

89 ;; FIXME implement this

90 (declare (ignore type1 type2))

91 nil)