Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Stop exporting with-timeout from LIFT

This lets you use-package without name conflicts in SBCL.

Also moved things around a bit to clean up compile order
dependencies.
  • Loading branch information...
commit 46dc0f2d46e9877725253c466df199fd990c529d 1 parent 259fd62
Gary King authored committed
View
49 dev/lift.lisp
@@ -158,40 +158,6 @@
(defun lift-report-condition (c)
(format *debug-io* "~&~A." c))
-(defun %build-ensure-comparison
- (form values guard-fn test test-specified-p report arguments
- ignore-multiple-values?)
- (setf test (remove-leading-quote test))
- (when (and (consp test)
- (eq (first test) 'function))
- (setf test (second test)))
- (let ((gblock (gensym "block-"))
- (ga (gensym "a-"))
- (gb (gensym "b-"))
- (gtest (gensym "test-")))
- `(block ,gblock
- (flet ((,gtest (,ga ,gb)
- (,@(cond (test-specified-p
- (if (atom test)
- (list test)
- `(funcall ,test)))
- (t
- `(funcall *lift-equality-test*)))
- ,ga ,gb)))
- (loop for value in (,(if ignore-multiple-values?
- 'list 'multiple-value-list) ,form)
- for other-value in (,(if ignore-multiple-values?
- 'list 'multiple-value-list) ,values) do
- (,guard-fn (,gtest value other-value)
- (,(ecase guard-fn
- (unless 'maybe-raise-not-same-condition)
- (when 'maybe-raise-ensure-same-condition))
- value other-value
- ,(if test-specified-p (list 'quote test) '*lift-equality-test*)
- ,report ,@arguments)
- (return-from ,gblock nil))))
- (values t))))
-
(defun maybe-raise-not-same-condition (value-1 value-2 test
report &rest arguments)
(let ((condition (make-condition 'ensure-not-same
@@ -323,12 +289,6 @@
(values value))
-(defun def (name &optional (definition *current-definition*))
- (when definition (cdr (assoc name definition))))
-
-(defun (setf def) (value name)
- (set-definition name value))
-
(defstruct (code-block (:type list) (:conc-name nil))
block-name (priority 0) filter code operate-when)
@@ -1423,15 +1383,6 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(subseq parsed-spec (+ pos 2))))
parsed-spec))))
-;; some handy properties
-(defclass-property test-slots)
-(defclass-property test-code->name-table)
-(defclass-property test-name->code-table)
-(defclass-property test-case-documentation)
-(defclass-property testsuite-tests)
-(defclass-property testsuite-dynamic-variables)
-(defclass-property test-name->methods)
-
;;?? issue 27: break encapsulation of code blocks
(defclass-property testsuite-function-specs)
View
9 dev/macros.lisp
@@ -19,6 +19,15 @@ For example, compile without cross-reference information."
(defmethod (setf ,property) (value (class-name symbol))
(setf (get class-name ,real-name) value)))))
+;; some handy properties
+(defclass-property test-slots)
+(defclass-property test-code->name-table)
+(defclass-property test-name->code-table)
+(defclass-property test-case-documentation)
+(defclass-property testsuite-tests)
+(defclass-property testsuite-dynamic-variables)
+(defclass-property test-name->methods)
+
(defmacro undefmeasure (name)
(let ((gname (gensym "name-")))
`(let ((,gname ,(form-keyword name)))
View
6 dev/packages.lisp
@@ -17,6 +17,9 @@
#:class-direct-subclasses
#:class-direct-superclasses
#:class-precedence-list)
+ (:import-from #:trivial-timeout
+ #:with-timeout
+ #:timeout-error)
(:export
#:generate-log-entry
#:testsuite-log-data
@@ -37,7 +40,6 @@
#:while-counting-events
#:while-counting-repetitions*
#:while-counting-events*
- #:with-timeout
#:did-event
#:testsuite-ambiguous
@@ -159,7 +161,9 @@
#:setup-test
)
+ #+no
(:export
+ #:with-timeout
#:timeout-error))))
(unless (and (find-package :asdf)
View
4 dev/reports.lisp
@@ -835,10 +835,6 @@ lift::(progn
;;;;
-(defun encode-symbol (symbol)
- (cons (symbol-name symbol)
- (package-name (symbol-package symbol))))
-
(defmethod brief-problem-output ((glitch testsuite-problem-mixin))
(if (test-method glitch)
(list (encode-symbol (testsuite glitch))
View
44 dev/utilities.lisp
@@ -502,3 +502,47 @@ if `putative-pair` is a cons cell with a non-nil cdr."
(format nil "~a" thing))
(t
thing)))
+
+(defun encode-symbol (symbol)
+ (cons (symbol-name symbol)
+ (package-name (symbol-package symbol))))
+
+(defun def (name &optional (definition *current-definition*))
+ (when definition (cdr (assoc name definition))))
+
+(defun (setf def) (value name)
+ (set-definition name value))
+
+(defun %build-ensure-comparison
+ (form values guard-fn test test-specified-p report arguments
+ ignore-multiple-values?)
+ (setf test (remove-leading-quote test))
+ (when (and (consp test)
+ (eq (first test) 'function))
+ (setf test (second test)))
+ (let ((gblock (gensym "block-"))
+ (ga (gensym "a-"))
+ (gb (gensym "b-"))
+ (gtest (gensym "test-")))
+ `(block ,gblock
+ (flet ((,gtest (,ga ,gb)
+ (,@(cond (test-specified-p
+ (if (atom test)
+ (list test)
+ `(funcall ,test)))
+ (t
+ `(funcall *lift-equality-test*)))
+ ,ga ,gb)))
+ (loop for value in (,(if ignore-multiple-values?
+ 'list 'multiple-value-list) ,form)
+ for other-value in (,(if ignore-multiple-values?
+ 'list 'multiple-value-list) ,values) do
+ (,guard-fn (,gtest value other-value)
+ (,(ecase guard-fn
+ (unless 'maybe-raise-not-same-condition)
+ (when 'maybe-raise-ensure-same-condition))
+ value other-value
+ ,(if test-specified-p (list 'quote test) '*lift-equality-test*)
+ ,report ,@arguments)
+ (return-from ,gblock nil))))
+ (values t))))
View
6 lift.asd
@@ -2,7 +2,7 @@
(in-package #:lift-system)
(defsystem lift
- :version "1.7.0"
+ :version "1.7.1"
:author "Gary Warren King <gwking@metabang.com>"
:maintainer "Gary Warren King <gwking@metabang.com>"
:licence "MIT Style License; see file COPYING for details"
@@ -21,9 +21,9 @@
:components
((:file "packages")
(:file "utilities"
- :depends-on ("packages" "macros" "definitions"))
- (:file "macros"
:depends-on ("packages" "definitions"))
+ (:file "macros"
+ :depends-on ("packages" "utilities" "definitions"))
(:file "definitions"
:depends-on ("packages"))
(:file "class-defs"
View
1  timeout/package.lisp
@@ -8,6 +8,7 @@
(defpackage #:com.metabang.trivial-timeout
(:use #:common-lisp)
(:nicknames #:trivial-timeout)
+; #+no
(:export
#:with-timeout
#:timeout-error)))
Please sign in to comment.
Something went wrong with that request. Please try again.