mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-16 16:50:21 +02:00
No more VM objects visible to Scheme
* libguile/vm.h:
* libguile/vm.c (scm_the_vm): Don't expose to Scheme.
(scm_vm_p): Remove, as it is not needed.
* module/system/vm/vm.scm: Remove the-vm and vm? exports.
* doc/ref/api-coverage.texi (Code Coverage):
* test-suite/tests/coverage.test:
* module/system/vm/coverage.scm (with-code-coverage): Don't take a VM
argument. Adapt documentation and tests.
* module/ice-9/command-line.scm: Remove the-vm autoload.
* module/system/vm/trace.scm (trace-calls-to-procedure):
(trace-calls-in-procedure):
(trace-instructions-in-procedure):
(call-with-trace): Remove #:vm kwarg, and adapt to trap changes.
* module/system/vm/trap-state.scm (the-trap-state): Rework to use a
parameter underneath instead of a weak key on (the-vm).
* module/system/vm/traps.scm (new-disabled-trap):
(new-enabled-trap): Remove vm argument.
(trap-at-procedure-call):
(trap-in-procedure):
(trap-instructions-in-procedure):
(trap-at-procedure-ip-in-range):
(trap-at-source-location):
(trap-frame-finish):
(trap-in-dynamic-extent):
(trap-calls-in-dynamic-extent):
(trap-instructions-in-dynamic-extent):
(trap-calls-to-procedure):
(trap-matching-instructions): Remove vm keyword arguments.
* test-suite/tests/control.test ("unwind"): Adapt test.
* test-suite/tests/eval.test (test-suite): Remove the-vm import.
This commit is contained in:
Andy Wingo
parent
972275eee5
commit
a222cbc9d1
13 changed files with 82 additions and 115 deletions
|
|
@ -1,6 +1,6 @@
|
|||
@c -*-texinfo-*-
|
||||
@c This is part of the GNU Guile Reference Manual.
|
||||
@c Copyright (C) 2010 Free Software Foundation, Inc.
|
||||
@c Copyright (C) 2010, 2013 Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
|
||||
|
|
@ -14,10 +14,10 @@ part of the code is @dfn{covered} by the test suite. The @code{(system vm
|
|||
coverage)} module provides tools to gather code coverage data and to present
|
||||
them, as detailed below.
|
||||
|
||||
@deffn {Scheme Procedure} with-code-coverage vm thunk
|
||||
Run @var{thunk}, a zero-argument procedure, using @var{vm}; instrument @var{vm}
|
||||
to collect code coverage data. Return code coverage data and the values
|
||||
returned by @var{thunk}.
|
||||
@deffn {Scheme Procedure} with-code-coverage thunk
|
||||
Run @var{thunk}, a zero-argument procedure, while instrumenting Guile's
|
||||
virtual machine to collect code coverage data. Return code coverage
|
||||
data and the values returned by @var{thunk}.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} coverage-data? obj
|
||||
|
|
@ -43,7 +43,7 @@ Here's an example use:
|
|||
(system vm vm))
|
||||
|
||||
(call-with-values (lambda ()
|
||||
(with-code-coverage (the-vm)
|
||||
(with-code-coverage
|
||||
(lambda ()
|
||||
(do-something-tricky))))
|
||||
(lambda (data result)
|
||||
|
|
|
|||
|
|
@ -716,7 +716,7 @@ a thunk, gives us the following:
|
|||
@lisp
|
||||
scheme@@(guile-user)> (use-modules (system vm vm))
|
||||
scheme@@(guile-user)> (debug-set! stack 10000)
|
||||
scheme@@(guile-user)> (let lp () (call-with-vm (the-vm) lp))
|
||||
scheme@@(guile-user)> (let lp () (call-with-vm lp))
|
||||
ERROR: In procedure call-with-vm:
|
||||
ERROR: Stack overflow
|
||||
@end lisp
|
||||
|
|
@ -1178,7 +1178,7 @@ procedure calls and returns within the thunk.
|
|||
|
||||
@deffn {Scheme Procedure} call-with-trace thunk [#:calls?=#t] @
|
||||
[#:instructions?=#f] @
|
||||
[#:width=80] [#:vm=(the-vm)]
|
||||
[#:width=80]
|
||||
Call @var{thunk}, tracing all execution within its dynamic extent.
|
||||
|
||||
If @var{calls?} is true, Guile will print a brief report at each
|
||||
|
|
|
|||
|
|
@ -830,12 +830,8 @@ scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
|
|||
return vm_engines[vp->engine](vm, program, argv, nargs);
|
||||
}
|
||||
|
||||
/* Scheme interface */
|
||||
|
||||
SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
|
||||
(void),
|
||||
"Return the current thread's VM.")
|
||||
#define FUNC_NAME s_scm_the_vm
|
||||
SCM
|
||||
scm_the_vm (void)
|
||||
{
|
||||
scm_i_thread *t = SCM_I_CURRENT_THREAD;
|
||||
|
||||
|
|
@ -844,17 +840,8 @@ SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
|
|||
|
||||
return t->vm;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_p
|
||||
{
|
||||
return scm_from_bool (SCM_VM_P (obj));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
/* Scheme interface */
|
||||
|
||||
#define VM_DEFINE_HOOK(n) \
|
||||
{ \
|
||||
|
|
|
|||
|
|
@ -59,7 +59,6 @@ SCM_API SCM scm_the_vm_fluid;
|
|||
SCM_API SCM scm_the_vm (void);
|
||||
SCM_API SCM scm_call_with_vm (SCM proc, SCM args);
|
||||
|
||||
SCM_API SCM scm_vm_p (SCM obj);
|
||||
SCM_API SCM scm_vm_apply_hook (void);
|
||||
SCM_API SCM scm_vm_push_continuation_hook (void);
|
||||
SCM_API SCM scm_vm_pop_continuation_hook (void);
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@
|
|||
;;;
|
||||
|
||||
(define-module (ice-9 command-line)
|
||||
#:autoload (system vm vm) (set-default-vm-engine! set-vm-engine! the-vm)
|
||||
#:autoload (system vm vm) (set-default-vm-engine! set-vm-engine!)
|
||||
#:export (compile-shell-switches
|
||||
version-etc
|
||||
*GPLv3+*
|
||||
|
|
|
|||
|
|
@ -50,9 +50,10 @@
|
|||
;;; Gathering coverage data.
|
||||
;;;
|
||||
|
||||
(define (with-code-coverage vm thunk)
|
||||
"Run THUNK, a zero-argument procedure, using VM; instrument VM to collect code
|
||||
coverage data. Return code coverage data and the values returned by THUNK."
|
||||
(define (with-code-coverage thunk)
|
||||
"Run THUNK, a zero-argument procedure, while instrumenting Guile's VM to
|
||||
collect code coverage data. Return code coverage data and the values returned
|
||||
by THUNK."
|
||||
|
||||
(define ip-counts
|
||||
;; A table mapping instruction pointers to the number of times they were
|
||||
|
|
|
|||
|
|
@ -67,52 +67,49 @@
|
|||
(format #f "~v:@y" width val))
|
||||
values))))))
|
||||
|
||||
(define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))
|
||||
(define* (trace-calls-to-procedure proc #:key (width 80)
|
||||
(prefix "trace: ")
|
||||
(max-indent (- width 40)))
|
||||
(define (apply-handler frame depth)
|
||||
(print-application frame depth width prefix max-indent))
|
||||
(define (return-handler frame depth . values)
|
||||
(print-return frame depth width prefix max-indent values))
|
||||
(trap-calls-to-procedure proc apply-handler return-handler
|
||||
#:vm vm))
|
||||
(trap-calls-to-procedure proc apply-handler return-handler))
|
||||
|
||||
(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))
|
||||
(define* (trace-calls-in-procedure proc #:key (width 80)
|
||||
(prefix "trace: ")
|
||||
(max-indent (- width 40)))
|
||||
(define (apply-handler frame depth)
|
||||
(print-application frame depth width prefix max-indent))
|
||||
(define (return-handler frame depth . values)
|
||||
(print-return frame depth width prefix max-indent values))
|
||||
(trap-calls-in-dynamic-extent proc apply-handler return-handler
|
||||
#:vm vm))
|
||||
(trap-calls-in-dynamic-extent proc apply-handler return-handler))
|
||||
|
||||
(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm))
|
||||
(define* (trace-instructions-in-procedure proc #:key (width 80)
|
||||
(max-indent (- width 40)))
|
||||
(define (trace-next frame)
|
||||
;; FIXME: We could disassemble this instruction here.
|
||||
(let ((ip (frame-instruction-pointer frame)))
|
||||
(format #t "0x~x\n" ip)))
|
||||
|
||||
(trap-instructions-in-dynamic-extent proc trace-next
|
||||
#:vm vm))
|
||||
(trap-instructions-in-dynamic-extent proc trace-next))
|
||||
|
||||
;; Note that because this procedure manipulates the VM trace level
|
||||
;; directly, it doesn't compose well with traps at the REPL.
|
||||
;;
|
||||
(define* (call-with-trace thunk #:key (calls? #t) (instructions? #f)
|
||||
(width 80) (vm (the-vm)) (max-indent (- width 40)))
|
||||
(width 80) (max-indent (- width 40)))
|
||||
(let ((call-trap #f)
|
||||
(inst-trap #f))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(if calls?
|
||||
(set! call-trap
|
||||
(trace-calls-in-procedure thunk #:vm vm #:width width
|
||||
(trace-calls-in-procedure thunk #:width width
|
||||
#:max-indent max-indent)))
|
||||
(if instructions?
|
||||
(set! inst-trap
|
||||
(trace-instructions-in-procedure thunk #:vm vm #:width width
|
||||
(trace-instructions-in-procedure thunk #:width width
|
||||
#:max-indent max-indent)))
|
||||
(set-vm-trace-level! (1+ (vm-trace-level))))
|
||||
thunk
|
||||
|
|
|
|||
|
|
@ -146,19 +146,19 @@
|
|||
|
||||
|
||||
;;;
|
||||
;;; VM-local trap states
|
||||
;;; Per-thread trap states
|
||||
;;;
|
||||
|
||||
(define *trap-states* (make-weak-key-hash-table))
|
||||
;; FIXME: This should be thread-local -- not something you can inherit
|
||||
;; from a dynamic state.
|
||||
|
||||
(define (trap-state-for-vm vm)
|
||||
(or (hashq-ref *trap-states* vm)
|
||||
(let ((ts (make-trap-state)))
|
||||
(hashq-set! *trap-states* vm ts)
|
||||
(trap-state-for-vm vm))))
|
||||
(define %trap-state (make-parameter #f))
|
||||
|
||||
(define (the-trap-state)
|
||||
(trap-state-for-vm (the-vm)))
|
||||
(or (%trap-state)
|
||||
(let ((ts (make-trap-state)))
|
||||
(%trap-state ts)
|
||||
ts)))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@
|
|||
(if (not (predicate? arg))
|
||||
(error "bad argument ~a: expected ~a" 'arg 'predicate?)))))
|
||||
|
||||
(define (new-disabled-trap vm enable disable)
|
||||
(define (new-disabled-trap enable disable)
|
||||
(let ((enabled? #f))
|
||||
(define-syntax disabled?
|
||||
(identifier-syntax
|
||||
|
|
@ -104,8 +104,8 @@
|
|||
|
||||
enable-trap))
|
||||
|
||||
(define (new-enabled-trap vm frame enable disable)
|
||||
((new-disabled-trap vm enable disable) frame))
|
||||
(define (new-enabled-trap frame enable disable)
|
||||
((new-disabled-trap enable disable) frame))
|
||||
|
||||
;; Returns an absolute IP.
|
||||
(define (program-last-ip prog)
|
||||
|
|
@ -126,8 +126,7 @@
|
|||
|
||||
;; A basic trap, fires when a procedure is called.
|
||||
;;
|
||||
(define* (trap-at-procedure-call proc handler #:key (vm (the-vm))
|
||||
(closure? #f)
|
||||
(define* (trap-at-procedure-call proc handler #:key (closure? #f)
|
||||
(our-frame? (frame-matcher proc closure?)))
|
||||
(arg-check proc procedure?)
|
||||
(arg-check handler procedure?)
|
||||
|
|
@ -137,7 +136,7 @@
|
|||
(handler frame)))
|
||||
|
||||
(new-enabled-trap
|
||||
vm #f
|
||||
#f
|
||||
(lambda (frame)
|
||||
(add-hook! (vm-apply-hook) apply-hook))
|
||||
(lambda (frame)
|
||||
|
|
@ -158,8 +157,7 @@
|
|||
;; * An abort.
|
||||
;;
|
||||
(define* (trap-in-procedure proc enter-handler exit-handler
|
||||
#:key current-frame (vm (the-vm))
|
||||
(closure? #f)
|
||||
#:key current-frame (closure? #f)
|
||||
(our-frame? (frame-matcher proc closure?)))
|
||||
(arg-check proc procedure?)
|
||||
(arg-check enter-handler procedure?)
|
||||
|
|
@ -208,7 +206,7 @@
|
|||
(enter-proc frame)))
|
||||
|
||||
(new-enabled-trap
|
||||
vm current-frame
|
||||
current-frame
|
||||
(lambda (frame)
|
||||
(add-hook! (vm-apply-hook) apply-hook)
|
||||
(add-hook! (vm-push-continuation-hook) push-cont-hook)
|
||||
|
|
@ -229,8 +227,7 @@
|
|||
;; Building on trap-in-procedure, we have trap-instructions-in-procedure
|
||||
;;
|
||||
(define* (trap-instructions-in-procedure proc next-handler exit-handler
|
||||
#:key current-frame (vm (the-vm))
|
||||
(closure? #f)
|
||||
#:key current-frame (closure? #f)
|
||||
(our-frame?
|
||||
(frame-matcher proc closure?)))
|
||||
(arg-check proc procedure?)
|
||||
|
|
@ -250,7 +247,7 @@
|
|||
(remove-hook! (vm-next-hook) next-hook))
|
||||
|
||||
(trap-in-procedure proc enter exit
|
||||
#:current-frame current-frame #:vm vm
|
||||
#:current-frame current-frame
|
||||
#:our-frame? our-frame?)))
|
||||
|
||||
(define (non-negative-integer? x)
|
||||
|
|
@ -277,8 +274,7 @@
|
|||
;; trap-at-procedure-ip-in-range.
|
||||
;;
|
||||
(define* (trap-at-procedure-ip-in-range proc range handler
|
||||
#:key current-frame (vm (the-vm))
|
||||
(closure? #f)
|
||||
#:key current-frame (closure? #f)
|
||||
(our-frame?
|
||||
(frame-matcher proc closure?)))
|
||||
(arg-check proc procedure?)
|
||||
|
|
@ -311,7 +307,7 @@
|
|||
(set! fp-stack (cdr fp-stack))))
|
||||
|
||||
(trap-instructions-in-procedure proc next-handler exit-handler
|
||||
#:current-frame current-frame #:vm vm
|
||||
#:current-frame current-frame
|
||||
#:our-frame? our-frame?)))
|
||||
|
||||
(define (program-sources-by-line proc file)
|
||||
|
|
@ -375,8 +371,7 @@
|
|||
;; trap-at-source-location. The parameter `user-line' is one-indexed, as
|
||||
;; a user counts lines, instead of zero-indexed, as Guile counts lines.
|
||||
;;
|
||||
(define* (trap-at-source-location file user-line handler
|
||||
#:key current-frame (vm (the-vm)))
|
||||
(define* (trap-at-source-location file user-line handler #:key current-frame)
|
||||
(arg-check file string?)
|
||||
(arg-check user-line positive-integer?)
|
||||
(arg-check handler procedure?)
|
||||
|
|
@ -385,7 +380,7 @@
|
|||
(lambda () (source-closures-or-procedures file (1- user-line)))
|
||||
(lambda (procs closures?)
|
||||
(new-enabled-trap
|
||||
vm current-frame
|
||||
current-frame
|
||||
(lambda (frame)
|
||||
(set! traps
|
||||
(map
|
||||
|
|
@ -393,7 +388,6 @@
|
|||
(let ((range (source->ip-range proc file (1- user-line))))
|
||||
(trap-at-procedure-ip-in-range proc range handler
|
||||
#:current-frame current-frame
|
||||
#:vm vm
|
||||
#:closure? closures?)))
|
||||
procs))
|
||||
(if (null? traps)
|
||||
|
|
@ -408,8 +402,7 @@
|
|||
;; do useful things during the dynamic extent of a procedure's
|
||||
;; application. First, a trap for when a frame returns.
|
||||
;;
|
||||
(define* (trap-frame-finish frame return-handler abort-handler
|
||||
#:key (vm (the-vm)))
|
||||
(define (trap-frame-finish frame return-handler abort-handler)
|
||||
(arg-check frame frame?)
|
||||
(arg-check return-handler procedure?)
|
||||
(arg-check abort-handler procedure?)
|
||||
|
|
@ -427,7 +420,7 @@
|
|||
(apply abort-handler frame values))))
|
||||
|
||||
(new-enabled-trap
|
||||
vm frame
|
||||
frame
|
||||
(lambda (frame)
|
||||
(if (not fp)
|
||||
(error "return-or-abort traps may only be enabled once"))
|
||||
|
|
@ -444,8 +437,7 @@
|
|||
;; based on the above trap-frame-finish?
|
||||
;;
|
||||
(define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler
|
||||
#:key current-frame (vm (the-vm))
|
||||
(closure? #f)
|
||||
#:key current-frame (closure? #f)
|
||||
(our-frame? (frame-matcher proc closure?)))
|
||||
(arg-check proc procedure?)
|
||||
(arg-check enter-handler procedure?)
|
||||
|
|
@ -467,11 +459,10 @@
|
|||
(begin
|
||||
(enter-handler frame)
|
||||
(set! exit-trap
|
||||
(trap-frame-finish frame return-hook abort-hook
|
||||
#:vm vm)))))
|
||||
(trap-frame-finish frame return-hook abort-hook)))))
|
||||
|
||||
(new-enabled-trap
|
||||
vm current-frame
|
||||
current-frame
|
||||
(lambda (frame)
|
||||
(add-hook! (vm-apply-hook) apply-hook))
|
||||
(lambda (frame)
|
||||
|
|
@ -484,8 +475,7 @@
|
|||
;; depth of the call stack relative to the original procedure.
|
||||
;;
|
||||
(define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
|
||||
#:key current-frame (vm (the-vm))
|
||||
(closure? #f)
|
||||
#:key current-frame (closure? #f)
|
||||
(our-frame?
|
||||
(frame-matcher proc closure?)))
|
||||
(arg-check proc procedure?)
|
||||
|
|
@ -521,14 +511,13 @@
|
|||
(leave frame))
|
||||
|
||||
(trap-in-dynamic-extent proc enter return abort
|
||||
#:current-frame current-frame #:vm vm
|
||||
#:current-frame current-frame
|
||||
#:our-frame? our-frame?)))
|
||||
|
||||
;; Trapping all retired intructions within a dynamic extent.
|
||||
;;
|
||||
(define* (trap-instructions-in-dynamic-extent proc next-handler
|
||||
#:key current-frame (vm (the-vm))
|
||||
(closure? #f)
|
||||
#:key current-frame (closure? #f)
|
||||
(our-frame?
|
||||
(frame-matcher proc closure?)))
|
||||
(arg-check proc procedure?)
|
||||
|
|
@ -550,13 +539,12 @@
|
|||
(leave frame))
|
||||
|
||||
(trap-in-dynamic-extent proc enter return abort
|
||||
#:current-frame current-frame #:vm vm
|
||||
#:current-frame current-frame
|
||||
#:our-frame? our-frame?)))
|
||||
|
||||
;; Traps calls and returns for a given procedure, keeping track of the call depth.
|
||||
;;
|
||||
(define* (trap-calls-to-procedure proc apply-handler return-handler
|
||||
#:key (vm (the-vm)))
|
||||
(define (trap-calls-to-procedure proc apply-handler return-handler)
|
||||
(arg-check proc procedure?)
|
||||
(arg-check apply-handler procedure?)
|
||||
(arg-check return-handler procedure?)
|
||||
|
|
@ -584,7 +572,7 @@
|
|||
(frame-finished frame))
|
||||
|
||||
(set! finish-trap
|
||||
(trap-frame-finish frame return-hook abort-hook #:vm vm))
|
||||
(trap-frame-finish frame return-hook abort-hook))
|
||||
(set! pending-finish-traps
|
||||
(cons finish-trap pending-finish-traps))))))
|
||||
|
||||
|
|
@ -613,12 +601,11 @@
|
|||
(with-pending-finish-enablers (trap frame))))
|
||||
|
||||
(with-pending-finish-disablers
|
||||
(trap-at-procedure-call proc apply-hook #:vm vm))))
|
||||
(trap-at-procedure-call proc apply-hook))))
|
||||
|
||||
;; Trap when the source location changes.
|
||||
;;
|
||||
(define* (trap-matching-instructions frame-pred handler
|
||||
#:key (vm (the-vm)))
|
||||
(define (trap-matching-instructions frame-pred handler)
|
||||
(arg-check frame-pred procedure?)
|
||||
(arg-check handler procedure?)
|
||||
(let ()
|
||||
|
|
@ -627,7 +614,7 @@
|
|||
(handler frame)))
|
||||
|
||||
(new-enabled-trap
|
||||
vm #f
|
||||
#f
|
||||
(lambda (frame)
|
||||
(add-hook! (vm-next-hook) next-hook))
|
||||
(lambda (frame)
|
||||
|
|
|
|||
|
|
@ -19,8 +19,7 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (system vm vm)
|
||||
#:export (vm?
|
||||
the-vm call-with-vm
|
||||
#:export (call-with-vm
|
||||
vm-trace-level set-vm-trace-level!
|
||||
vm-engine set-vm-engine! set-default-vm-engine!
|
||||
vm-push-continuation-hook vm-pop-continuation-hook
|
||||
|
|
|
|||
|
|
@ -360,7 +360,7 @@
|
|||
(pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
|
||||
(abort-to-prompt 'does-not-exist)))
|
||||
|
||||
(with-test-prefix/c&e "the-vm"
|
||||
(with-test-prefix/c&e "unwind"
|
||||
|
||||
(pass-if "unwind through call-with-vm"
|
||||
(let ((proc (lambda (x y)
|
||||
|
|
@ -369,10 +369,9 @@
|
|||
(p x y))))
|
||||
(catch 'foo
|
||||
(lambda ()
|
||||
(call-with-vm (lambda () (throw 'foo (the-vm)))))
|
||||
(lambda (key vm)
|
||||
(and (eq? key 'foo)
|
||||
(eq? vm (the-vm))))))))
|
||||
(call-with-vm (lambda () (throw 'foo))))
|
||||
(lambda (key)
|
||||
(eq? key 'foo))))))
|
||||
|
||||
;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
|
||||
;; http://okmij.org/ftp/Scheme/delim-control-n.scm. Public domain.
|
||||
|
|
|
|||
|
|
@ -33,8 +33,6 @@
|
|||
(read-enable 'positions)
|
||||
(compile (read input))))))
|
||||
|
||||
(define %test-vm (the-vm))
|
||||
|
||||
(define test-procedure
|
||||
(compile '(lambda (x)
|
||||
(if (> x 2)
|
||||
|
|
@ -48,7 +46,7 @@
|
|||
(let ((proc (code "foo.scm" "(lambda (x y) ;; 0
|
||||
(+ x y)) ;; 1")))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda () (proc 1 2)))))
|
||||
(and (coverage-data? data)
|
||||
(= 3 result)
|
||||
|
|
@ -63,7 +61,7 @@
|
|||
(display x) ;; 3
|
||||
(+ x y)))) ;; 4")))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda () (proc 1 2)))))
|
||||
(and (coverage-data? data)
|
||||
(let-values (((instr exec)
|
||||
|
|
@ -78,7 +76,7 @@
|
|||
(+ (/ x y) ;; 1
|
||||
(* x y))) ;; 2")))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda () (proc 1 2)))))
|
||||
(let ((counts (line-execution-counts data "bar.scm")))
|
||||
(and (pair? counts)
|
||||
|
|
@ -101,7 +99,7 @@
|
|||
((= x 0) #t) ;; 7
|
||||
((< x 0) 'never))))")))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda () (proc 77)))))
|
||||
(let ((counts (line-execution-counts data "fooz.scm")))
|
||||
(and (pair? counts)
|
||||
|
|
@ -125,7 +123,7 @@
|
|||
(+ x y)) ;; 4
|
||||
(+ x y))) ;; 5")))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda () (proc 1 2)))))
|
||||
(let ((counts (line-execution-counts data "baz.scm")))
|
||||
(and (pair? counts)
|
||||
|
|
@ -148,7 +146,7 @@
|
|||
(not (even? (1- x)))))) ;; 4
|
||||
even?)")))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda () (proc 0)))))
|
||||
(let ((counts (line-execution-counts data "baz.scm")))
|
||||
(and (pair? counts)
|
||||
|
|
@ -166,7 +164,7 @@
|
|||
((x) (+ x 3)) ;; 1
|
||||
((x y) (+ x y))) ;; 2")))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda ()
|
||||
(+ (proc 1) (proc 2 3))))))
|
||||
(let ((counts (line-execution-counts data "cl.scm")))
|
||||
|
|
@ -179,7 +177,7 @@
|
|||
(let ((proc (code "one-liner.scm"
|
||||
"(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda () (proc 451 1884)))))
|
||||
(let ((counts (line-execution-counts data "one-liner.scm")))
|
||||
(equal? counts '((0 . 1))))))))
|
||||
|
|
@ -190,7 +188,7 @@
|
|||
(pass-if "several times"
|
||||
(let ((proc (code "foo.scm" "(lambda (x y) x)")))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda () (+ (proc 1 2) (proc 2 3))))))
|
||||
(and (coverage-data? data)
|
||||
(= 3 result)
|
||||
|
|
@ -199,7 +197,7 @@
|
|||
(pass-if "case-lambda"
|
||||
(let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))")))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda ()
|
||||
(+ (proc 1) (proc 2 3))))))
|
||||
(and (coverage-data? data)
|
||||
|
|
@ -209,7 +207,7 @@
|
|||
(pass-if "never"
|
||||
(let ((proc (code "foo.scm" "(lambda (x y) x)")))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda () (+ 1 2)))))
|
||||
(and (coverage-data? data)
|
||||
(= 3 result)
|
||||
|
|
@ -220,14 +218,14 @@
|
|||
(proc (lambda args (length args)))
|
||||
(b (make-struct <box> 0 proc)))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm b)))
|
||||
(with-code-coverage b)))
|
||||
(and (coverage-data? data)
|
||||
(= 0 result)
|
||||
(= (procedure-execution-count data proc) 1)))))
|
||||
|
||||
(pass-if "called from C"
|
||||
;; The `scm_call_N' functions use the VM returned by `the-vm'. This
|
||||
;; test makes sure that they get to use %TEST-VM.
|
||||
;; test makes sure that their calls are traced.
|
||||
(let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
|
||||
(call (false-if-exception ; can we resolve `scm_call_2'?
|
||||
(pointer->procedure '*
|
||||
|
|
@ -236,7 +234,7 @@
|
|||
'(* * *)))))
|
||||
(if call
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda ()
|
||||
(call (make-pointer (object-address proc))
|
||||
(make-pointer (object-address 1))
|
||||
|
|
@ -248,7 +246,7 @@
|
|||
|
||||
(pass-if "called from eval"
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda ()
|
||||
(eval '(test-procedure 123) (current-module))))))
|
||||
(and (coverage-data? data)
|
||||
|
|
@ -261,7 +259,7 @@
|
|||
(pass-if "source files are listed as expected"
|
||||
(let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
|
||||
(let-values (((data result)
|
||||
(with-code-coverage %test-vm
|
||||
(with-code-coverage
|
||||
(lambda () (proc 1 2)))))
|
||||
|
||||
(let ((files (map basename (instrumented-source-files data))))
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@
|
|||
(define-module (test-suite test-eval)
|
||||
:use-module (test-suite lib)
|
||||
:use-module ((srfi srfi-1) :select (unfold count))
|
||||
:use-module ((system vm vm) :select (the-vm call-with-vm))
|
||||
:use-module ((system vm vm) :select (call-with-vm))
|
||||
:use-module (ice-9 documentation)
|
||||
:use-module (ice-9 local-eval))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue