Permalink
Browse files

Support contracts on non-generic functions on SBCL.

  • Loading branch information...
1 parent 04ff5d0 commit 7ab4df4c3318b95ae72bf3a18e93d8fe234dc49e @orivej orivej committed Aug 11, 2012
Showing with 49 additions and 4 deletions.
  1. +6 −4 quid-pro-quo.asd
  2. +43 −0 src/sbcl-encapsulate.lisp
View
@@ -20,12 +20,14 @@
(:file "method-combination" :depends-on ("package"))
(:file #+allegro "acl-fwrap"
#+ccl "ccl-advice"
- #-(or allegro ccl) "missing-advice"
+ #+sbcl "sbcl-encapsulate"
+ #-(or allegro ccl sbcl) "missing-advice"
:depends-on ("package"))
(:file "macros" :depends-on ("method-combination"
#+allegro "acl-fwrap"
#+ccl "ccl-advice"
- #-(or allegro ccl)
+ #+sbcl "sbcl-encapsulate"
+ #-(or allegro ccl sbcl)
"missing-advice"))
(:file "metaclass" :depends-on ("macros"))
(:file "system-connections" :depends-on ("metaclass")
@@ -45,6 +47,6 @@
:maintainer "Greg Pfeil <greg@technomadic.org>"
:depends-on (quid-pro-quo fiveam)
:components ((:file "quid-pro-quo-test")
- (:file #+(or allegro ccl) "advice-tests"
- #-(or allegro ccl) "missing-advice-tests"
+ (:file #+(or allegro ccl sbcl) "advice-tests"
+ #-(or allegro ccl sbcl) "missing-advice-tests"
:depends-on ("quid-pro-quo-test"))))
View
@@ -0,0 +1,43 @@
+(in-package #:quid-pro-quo)
+
+(defmacro defcontract (name type lambda-list &body body)
+ "This macro makes it possible to add pre- and postconditions to non-generic
+ functions as well."
+ (multiple-value-bind (remaining-forms declarations doc-string)
+ (parse-body body :documentation t)
+ (let ((arglist (gensym "ARGLIST"))
+ (fdefn (gensym "FDEFN")))
+ `(progn
+ (sb-int:unencapsulate ',name ',(intern doc-string))
+ (sb-int:encapsulate
+ ',name ',(intern doc-string)
+ '(let ((,arglist (eval 'sb-int:arg-list))
+ (,fdefn (eval 'sb-int:basic-definition)))
+ (destructuring-bind ,lambda-list ,arglist
+ ,@declarations
+ ,(ecase type
+ (:require `(if (progn ,@remaining-forms)
+ (apply ,fdefn ,arglist)
+ (error 'precondition-error
+ :failed-check (fdefinition ',name)
+ :arguments ,arglist
+ :description ,doc-string)))
+ (:guarantee (let ((%results (gensym "%RESULTS")))
+ `(let ((,%results nil))
+ (flet ((results ()
+ (values-list ,%results)))
+ (ignore-errors
+ (let ((*preparing-postconditions* t)
+ (*inside-contract-p* t))
+ ,@remaining-forms))
+ (setf ,%results
+ (multiple-value-list
+ (apply ,fdefn ,arglist)))
+ (or (let ((*inside-contract-p* t))
+ ,@remaining-forms)
+ (error 'postcondition-error
+ :failed-check (fdefinition ',name)
+ :arguments ,arglist
+ :results (results)
+ :description ,doc-string))
+ (results)))))))))))))

0 comments on commit 7ab4df4

Please sign in to comment.