mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 16:50:21 +02:00
Code Activity

No more VM objects visible to Scheme

Browse source 
* 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 2013-11-21 16:45:03 +01:00
parent 972275eee5
commit a222cbc9d1
13 changed files with 82 additions and 115 deletions
Download patch file Download diff file Expand all files Collapse all files

12
doc/ref/api-coverage.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*- @c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @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. @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 coverage)} module provides tools to gather code coverage data and to present
them, as detailed below. them, as detailed below.
@deffn {Scheme Procedure} with-code-coverage vm thunk @deffn {Scheme Procedure} with-code-coverage thunk
Run @var{thunk}, a zero-argument procedure, using @var{vm}; instrument @var{vm} Run @var{thunk}, a zero-argument procedure, while instrumenting Guile's
to collect code coverage data. Return code coverage data and the values virtual machine to collect code coverage data. Return code coverage
returned by @var{thunk}. data and the values returned by @var{thunk}.
@end deffn @end deffn
@deffn {Scheme Procedure} coverage-data? obj @deffn {Scheme Procedure} coverage-data? obj
@ -43,7 +43,7 @@ Here's an example use:
(system vm vm)) (system vm vm))
(call-with-values (lambda () (call-with-values (lambda ()
(with-code-coverage (the-vm) (with-code-coverage
(lambda () (lambda ()
(do-something-tricky)))) (do-something-tricky))))
(lambda (data result) (lambda (data result)

4
doc/ref/api-debug.texi
View file

@ -716,7 +716,7 @@ a thunk, gives us the following:
@lisp @lisp
scheme@@(guile-user)> (use-modules (system vm vm)) scheme@@(guile-user)> (use-modules (system vm vm))
scheme@@(guile-user)> (debug-set! stack 10000) 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: In procedure call-with-vm:
ERROR: Stack overflow ERROR: Stack overflow
@end lisp @end lisp
@ -1178,7 +1178,7 @@ procedure calls and returns within the thunk.
@deffn {Scheme Procedure} call-with-trace thunk [#:calls?=#t] @ @deffn {Scheme Procedure} call-with-trace thunk [#:calls?=#t] @
[#:instructions?=#f] @ [#:instructions?=#f] @
[#:width=80] [#:vm=(the-vm)] [#:width=80]
Call @var{thunk}, tracing all execution within its dynamic extent. Call @var{thunk}, tracing all execution within its dynamic extent.
If @var{calls?} is true, Guile will print a brief report at each If @var{calls?} is true, Guile will print a brief report at each

19
libguile/vm.c
View file

@ -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); return vm_engines[vp->engine](vm, program, argv, nargs);
} }
/* Scheme interface */ SCM
scm_the_vm (void)
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_i_thread *t = SCM_I_CURRENT_THREAD; 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; return t->vm;
} }
#undef FUNC_NAME
/* Scheme interface */
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
#define VM_DEFINE_HOOK(n) \ #define VM_DEFINE_HOOK(n) \
{ \ { \

1
libguile/vm.h
View file

@ -59,7 +59,6 @@ SCM_API SCM scm_the_vm_fluid;
SCM_API SCM scm_the_vm (void); SCM_API SCM scm_the_vm (void);
SCM_API SCM scm_call_with_vm (SCM proc, SCM args); 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_apply_hook (void);
SCM_API SCM scm_vm_push_continuation_hook (void); SCM_API SCM scm_vm_push_continuation_hook (void);
SCM_API SCM scm_vm_pop_continuation_hook (void); SCM_API SCM scm_vm_pop_continuation_hook (void);

2
module/ice-9/command-line.scm
View file

@ -32,7 +32,7 @@
;;; ;;;
(define-module (ice-9 command-line) (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 #:export (compile-shell-switches
version-etc version-etc
*GPLv3+* *GPLv3+*

7
module/system/vm/coverage.scm
View file

@ -50,9 +50,10 @@
;;; Gathering coverage data. ;;; Gathering coverage data.
;;; ;;;
(define (with-code-coverage vm thunk) (define (with-code-coverage thunk)
"Run THUNK, a zero-argument procedure, using VM; instrument VM to collect code "Run THUNK, a zero-argument procedure, while instrumenting Guile's VM to
coverage data. Return code coverage data and the values returned by THUNK." collect code coverage data. Return code coverage data and the values returned
by THUNK."
(define ip-counts (define ip-counts
;; A table mapping instruction pointers to the number of times they were ;; A table mapping instruction pointers to the number of times they were

21
module/system/vm/trace.scm
View file

@ -67,52 +67,49 @@
(format #f "~v:@y" width val)) (format #f "~v:@y" width val))
values)))))) values))))))
(define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm)) (define* (trace-calls-to-procedure proc #:key (width 80)
(prefix "trace: ") (prefix "trace: ")
(max-indent (- width 40))) (max-indent (- width 40)))
(define (apply-handler frame depth) (define (apply-handler frame depth)
(print-application frame depth width prefix max-indent)) (print-application frame depth width prefix max-indent))
(define (return-handler frame depth . values) (define (return-handler frame depth . values)
(print-return frame depth width prefix max-indent values)) (print-return frame depth width prefix max-indent values))
(trap-calls-to-procedure proc apply-handler return-handler (trap-calls-to-procedure proc apply-handler return-handler))
#:vm vm))
(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm)) (define* (trace-calls-in-procedure proc #:key (width 80)
(prefix "trace: ") (prefix "trace: ")
(max-indent (- width 40))) (max-indent (- width 40)))
(define (apply-handler frame depth) (define (apply-handler frame depth)
(print-application frame depth width prefix max-indent)) (print-application frame depth width prefix max-indent))
(define (return-handler frame depth . values) (define (return-handler frame depth . values)
(print-return frame depth width prefix max-indent values)) (print-return frame depth width prefix max-indent values))
(trap-calls-in-dynamic-extent proc apply-handler return-handler (trap-calls-in-dynamic-extent proc apply-handler return-handler))
#:vm vm))
(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))) (max-indent (- width 40)))
(define (trace-next frame) (define (trace-next frame)
;; FIXME: We could disassemble this instruction here. ;; FIXME: We could disassemble this instruction here.
(let ((ip (frame-instruction-pointer frame))) (let ((ip (frame-instruction-pointer frame)))
(format #t "0x~x\n" ip))) (format #t "0x~x\n" ip)))
(trap-instructions-in-dynamic-extent proc trace-next (trap-instructions-in-dynamic-extent proc trace-next))
#:vm vm))
;; Note that because this procedure manipulates the VM trace level ;; Note that because this procedure manipulates the VM trace level
;; directly, it doesn't compose well with traps at the REPL. ;; directly, it doesn't compose well with traps at the REPL.
;; ;;
(define* (call-with-trace thunk #:key (calls? #t) (instructions? #f) (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) (let ((call-trap #f)
(inst-trap #f)) (inst-trap #f))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(if calls? (if calls?
(set! call-trap (set! call-trap
(trace-calls-in-procedure thunk #:vm vm #:width width (trace-calls-in-procedure thunk #:width width
#:max-indent max-indent))) #:max-indent max-indent)))
(if instructions? (if instructions?
(set! inst-trap (set! inst-trap
(trace-instructions-in-procedure thunk #:vm vm #:width width (trace-instructions-in-procedure thunk #:width width
#:max-indent max-indent))) #:max-indent max-indent)))
(set-vm-trace-level! (1+ (vm-trace-level)))) (set-vm-trace-level! (1+ (vm-trace-level))))
thunk thunk

16
module/system/vm/trap-state.scm
View file

@ -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) (define %trap-state (make-parameter #f))
(or (hashq-ref *trap-states* vm)
(let ((ts (make-trap-state)))
(hashq-set! *trap-states* vm ts)
(trap-state-for-vm vm))))
(define (the-trap-state) (define (the-trap-state)
(trap-state-for-vm (the-vm))) (or (%trap-state)
(let ((ts (make-trap-state)))
(%trap-state ts)
ts)))

67
module/system/vm/traps.scm
View file

@ -83,7 +83,7 @@
(if (not (predicate? arg)) (if (not (predicate? arg))
(error "bad argument ~a: expected ~a" 'arg 'predicate?))))) (error "bad argument ~a: expected ~a" 'arg 'predicate?)))))
(define (new-disabled-trap vm enable disable) (define (new-disabled-trap enable disable)
(let ((enabled? #f)) (let ((enabled? #f))
(define-syntax disabled? (define-syntax disabled?
(identifier-syntax (identifier-syntax
@ -104,8 +104,8 @@
enable-trap)) enable-trap))
(define (new-enabled-trap vm frame enable disable) (define (new-enabled-trap frame enable disable)
((new-disabled-trap vm enable disable) frame)) ((new-disabled-trap enable disable) frame))
;; Returns an absolute IP. ;; Returns an absolute IP.
(define (program-last-ip prog) (define (program-last-ip prog)
@ -126,8 +126,7 @@
;; A basic trap, fires when a procedure is called. ;; A basic trap, fires when a procedure is called.
;; ;;
(define* (trap-at-procedure-call proc handler #:key (vm (the-vm)) (define* (trap-at-procedure-call proc handler #:key (closure? #f)
(closure? #f)
(our-frame? (frame-matcher proc closure?))) (our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?) (arg-check proc procedure?)
(arg-check handler procedure?) (arg-check handler procedure?)
@ -137,7 +136,7 @@
(handler frame))) (handler frame)))
(new-enabled-trap (new-enabled-trap
vm #f #f
(lambda (frame) (lambda (frame)
(add-hook! (vm-apply-hook) apply-hook)) (add-hook! (vm-apply-hook) apply-hook))
(lambda (frame) (lambda (frame)
@ -158,8 +157,7 @@
;; * An abort. ;; * An abort.
;; ;;
(define* (trap-in-procedure proc enter-handler exit-handler (define* (trap-in-procedure proc enter-handler exit-handler
#:key current-frame (vm (the-vm)) #:key current-frame (closure? #f)
(closure? #f)
(our-frame? (frame-matcher proc closure?))) (our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?) (arg-check proc procedure?)
(arg-check enter-handler procedure?) (arg-check enter-handler procedure?)
@ -208,7 +206,7 @@
(enter-proc frame))) (enter-proc frame)))
(new-enabled-trap (new-enabled-trap
vm current-frame current-frame
(lambda (frame) (lambda (frame)
(add-hook! (vm-apply-hook) apply-hook) (add-hook! (vm-apply-hook) apply-hook)
(add-hook! (vm-push-continuation-hook) push-cont-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 ;; Building on trap-in-procedure, we have trap-instructions-in-procedure
;; ;;
(define* (trap-instructions-in-procedure proc next-handler exit-handler (define* (trap-instructions-in-procedure proc next-handler exit-handler
#:key current-frame (vm (the-vm)) #:key current-frame (closure? #f)
(closure? #f)
(our-frame? (our-frame?
(frame-matcher proc closure?))) (frame-matcher proc closure?)))
(arg-check proc procedure?) (arg-check proc procedure?)
@ -250,7 +247,7 @@
(remove-hook! (vm-next-hook) next-hook)) (remove-hook! (vm-next-hook) next-hook))
(trap-in-procedure proc enter exit (trap-in-procedure proc enter exit
#:current-frame current-frame #:vm vm #:current-frame current-frame
#:our-frame? our-frame?))) #:our-frame? our-frame?)))
(define (non-negative-integer? x) (define (non-negative-integer? x)
@ -277,8 +274,7 @@
;; trap-at-procedure-ip-in-range. ;; trap-at-procedure-ip-in-range.
;; ;;
(define* (trap-at-procedure-ip-in-range proc range handler (define* (trap-at-procedure-ip-in-range proc range handler
#:key current-frame (vm (the-vm)) #:key current-frame (closure? #f)
(closure? #f)
(our-frame? (our-frame?
(frame-matcher proc closure?))) (frame-matcher proc closure?)))
(arg-check proc procedure?) (arg-check proc procedure?)
@ -311,7 +307,7 @@
(set! fp-stack (cdr fp-stack)))) (set! fp-stack (cdr fp-stack))))
(trap-instructions-in-procedure proc next-handler exit-handler (trap-instructions-in-procedure proc next-handler exit-handler
#:current-frame current-frame #:vm vm #:current-frame current-frame
#:our-frame? our-frame?))) #:our-frame? our-frame?)))
(define (program-sources-by-line proc file) (define (program-sources-by-line proc file)
@ -375,8 +371,7 @@
;; trap-at-source-location. The parameter `user-line' is one-indexed, as ;; trap-at-source-location. The parameter `user-line' is one-indexed, as
;; a user counts lines, instead of zero-indexed, as Guile counts lines. ;; a user counts lines, instead of zero-indexed, as Guile counts lines.
;; ;;
(define* (trap-at-source-location file user-line handler (define* (trap-at-source-location file user-line handler #:key current-frame)
#:key current-frame (vm (the-vm)))
(arg-check file string?) (arg-check file string?)
(arg-check user-line positive-integer?) (arg-check user-line positive-integer?)
(arg-check handler procedure?) (arg-check handler procedure?)
@ -385,7 +380,7 @@
(lambda () (source-closures-or-procedures file (1- user-line))) (lambda () (source-closures-or-procedures file (1- user-line)))
(lambda (procs closures?) (lambda (procs closures?)
(new-enabled-trap (new-enabled-trap
vm current-frame current-frame
(lambda (frame) (lambda (frame)
(set! traps (set! traps
(map (map
@ -393,7 +388,6 @@
(let ((range (source->ip-range proc file (1- user-line)))) (let ((range (source->ip-range proc file (1- user-line))))
(trap-at-procedure-ip-in-range proc range handler (trap-at-procedure-ip-in-range proc range handler
#:current-frame current-frame #:current-frame current-frame
#:vm vm
#:closure? closures?))) #:closure? closures?)))
procs)) procs))
(if (null? traps) (if (null? traps)
@ -408,8 +402,7 @@
;; do useful things during the dynamic extent of a procedure's ;; do useful things during the dynamic extent of a procedure's
;; application. First, a trap for when a frame returns. ;; application. First, a trap for when a frame returns.
;; ;;
(define* (trap-frame-finish frame return-handler abort-handler (define (trap-frame-finish frame return-handler abort-handler)
#:key (vm (the-vm)))
(arg-check frame frame?) (arg-check frame frame?)
(arg-check return-handler procedure?) (arg-check return-handler procedure?)
(arg-check abort-handler procedure?) (arg-check abort-handler procedure?)
@ -427,7 +420,7 @@
(apply abort-handler frame values)))) (apply abort-handler frame values))))
(new-enabled-trap (new-enabled-trap
vm frame frame
(lambda (frame) (lambda (frame)
(if (not fp) (if (not fp)
(error "return-or-abort traps may only be enabled once")) (error "return-or-abort traps may only be enabled once"))
@ -444,8 +437,7 @@
;; based on the above trap-frame-finish? ;; based on the above trap-frame-finish?
;; ;;
(define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler (define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler
#:key current-frame (vm (the-vm)) #:key current-frame (closure? #f)
(closure? #f)
(our-frame? (frame-matcher proc closure?))) (our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?) (arg-check proc procedure?)
(arg-check enter-handler procedure?) (arg-check enter-handler procedure?)
@ -467,11 +459,10 @@
(begin (begin
(enter-handler frame) (enter-handler frame)
(set! exit-trap (set! exit-trap
(trap-frame-finish frame return-hook abort-hook (trap-frame-finish frame return-hook abort-hook)))))
#:vm vm)))))
(new-enabled-trap (new-enabled-trap
vm current-frame current-frame
(lambda (frame) (lambda (frame)
(add-hook! (vm-apply-hook) apply-hook)) (add-hook! (vm-apply-hook) apply-hook))
(lambda (frame) (lambda (frame)
@ -484,8 +475,7 @@
;; depth of the call stack relative to the original procedure. ;; depth of the call stack relative to the original procedure.
;; ;;
(define* (trap-calls-in-dynamic-extent proc apply-handler return-handler (define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
#:key current-frame (vm (the-vm)) #:key current-frame (closure? #f)
(closure? #f)
(our-frame? (our-frame?
(frame-matcher proc closure?))) (frame-matcher proc closure?)))
(arg-check proc procedure?) (arg-check proc procedure?)
@ -521,14 +511,13 @@
(leave frame)) (leave frame))
(trap-in-dynamic-extent proc enter return abort (trap-in-dynamic-extent proc enter return abort
#:current-frame current-frame #:vm vm #:current-frame current-frame
#:our-frame? our-frame?))) #:our-frame? our-frame?)))
;; Trapping all retired intructions within a dynamic extent. ;; Trapping all retired intructions within a dynamic extent.
;; ;;
(define* (trap-instructions-in-dynamic-extent proc next-handler (define* (trap-instructions-in-dynamic-extent proc next-handler
#:key current-frame (vm (the-vm)) #:key current-frame (closure? #f)
(closure? #f)
(our-frame? (our-frame?
(frame-matcher proc closure?))) (frame-matcher proc closure?)))
(arg-check proc procedure?) (arg-check proc procedure?)
@ -550,13 +539,12 @@
(leave frame)) (leave frame))
(trap-in-dynamic-extent proc enter return abort (trap-in-dynamic-extent proc enter return abort
#:current-frame current-frame #:vm vm #:current-frame current-frame
#:our-frame? our-frame?))) #:our-frame? our-frame?)))
;; Traps calls and returns for a given procedure, keeping track of the call depth. ;; Traps calls and returns for a given procedure, keeping track of the call depth.
;; ;;
(define* (trap-calls-to-procedure proc apply-handler return-handler (define (trap-calls-to-procedure proc apply-handler return-handler)
#:key (vm (the-vm)))
(arg-check proc procedure?) (arg-check proc procedure?)
(arg-check apply-handler procedure?) (arg-check apply-handler procedure?)
(arg-check return-handler procedure?) (arg-check return-handler procedure?)
@ -584,7 +572,7 @@
(frame-finished frame)) (frame-finished frame))
(set! finish-trap (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 (set! pending-finish-traps
(cons finish-trap pending-finish-traps)))))) (cons finish-trap pending-finish-traps))))))
@ -613,12 +601,11 @@
(with-pending-finish-enablers (trap frame)))) (with-pending-finish-enablers (trap frame))))
(with-pending-finish-disablers (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. ;; Trap when the source location changes.
;; ;;
(define* (trap-matching-instructions frame-pred handler (define (trap-matching-instructions frame-pred handler)
#:key (vm (the-vm)))
(arg-check frame-pred procedure?) (arg-check frame-pred procedure?)
(arg-check handler procedure?) (arg-check handler procedure?)
(let () (let ()
@ -627,7 +614,7 @@
(handler frame))) (handler frame)))
(new-enabled-trap (new-enabled-trap
vm #f #f
(lambda (frame) (lambda (frame)
(add-hook! (vm-next-hook) next-hook)) (add-hook! (vm-next-hook) next-hook))
(lambda (frame) (lambda (frame)

3
module/system/vm/vm.scm
View file

@ -19,8 +19,7 @@
;;; Code: ;;; Code:
(define-module (system vm vm) (define-module (system vm vm)
#:export (vm? #:export (call-with-vm
the-vm call-with-vm
vm-trace-level set-vm-trace-level! vm-trace-level set-vm-trace-level!
vm-engine set-vm-engine! set-default-vm-engine! vm-engine set-vm-engine! set-default-vm-engine!
vm-push-continuation-hook vm-pop-continuation-hook vm-push-continuation-hook vm-pop-continuation-hook

9
test-suite/tests/control.test
View file

@ -360,7 +360,7 @@
(pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt") (pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
(abort-to-prompt 'does-not-exist))) (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" (pass-if "unwind through call-with-vm"
(let ((proc (lambda (x y) (let ((proc (lambda (x y)
@ -369,10 +369,9 @@
(p x y)))) (p x y))))
(catch 'foo (catch 'foo
(lambda () (lambda ()
(call-with-vm (lambda () (throw 'foo (the-vm))))) (call-with-vm (lambda () (throw 'foo))))
(lambda (key vm) (lambda (key)
(and (eq? key 'foo) (eq? key 'foo))))))
(eq? vm (the-vm))))))))
;; These tests from Oleg Kiselyov's delim-control-n.scm, available at ;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
;; http://okmij.org/ftp/Scheme/delim-control-n.scm. Public domain. ;; http://okmij.org/ftp/Scheme/delim-control-n.scm. Public domain.

34
test-suite/tests/coverage.test
View file

@ -33,8 +33,6 @@
(read-enable 'positions) (read-enable 'positions)
(compile (read input)))))) (compile (read input))))))
(define %test-vm (the-vm))
(define test-procedure (define test-procedure
(compile '(lambda (x) (compile '(lambda (x)
(if (> x 2) (if (> x 2)
@ -48,7 +46,7 @@
(let ((proc (code "foo.scm" "(lambda (x y) ;; 0 (let ((proc (code "foo.scm" "(lambda (x y) ;; 0
(+ x y)) ;; 1"))) (+ x y)) ;; 1")))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (proc 1 2))))) (lambda () (proc 1 2)))))
(and (coverage-data? data) (and (coverage-data? data)
(= 3 result) (= 3 result)
@ -63,7 +61,7 @@
(display x) ;; 3 (display x) ;; 3
(+ x y)))) ;; 4"))) (+ x y)))) ;; 4")))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (proc 1 2))))) (lambda () (proc 1 2)))))
(and (coverage-data? data) (and (coverage-data? data)
(let-values (((instr exec) (let-values (((instr exec)
@ -78,7 +76,7 @@
(+ (/ x y) ;; 1 (+ (/ x y) ;; 1
(* x y))) ;; 2"))) (* x y))) ;; 2")))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (proc 1 2))))) (lambda () (proc 1 2)))))
(let ((counts (line-execution-counts data "bar.scm"))) (let ((counts (line-execution-counts data "bar.scm")))
(and (pair? counts) (and (pair? counts)
@ -101,7 +99,7 @@
((= x 0) #t) ;; 7 ((= x 0) #t) ;; 7
((< x 0) 'never))))"))) ((< x 0) 'never))))")))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (proc 77))))) (lambda () (proc 77)))))
(let ((counts (line-execution-counts data "fooz.scm"))) (let ((counts (line-execution-counts data "fooz.scm")))
(and (pair? counts) (and (pair? counts)
@ -125,7 +123,7 @@
(+ x y)) ;; 4 (+ x y)) ;; 4
(+ x y))) ;; 5"))) (+ x y))) ;; 5")))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (proc 1 2))))) (lambda () (proc 1 2)))))
(let ((counts (line-execution-counts data "baz.scm"))) (let ((counts (line-execution-counts data "baz.scm")))
(and (pair? counts) (and (pair? counts)
@ -148,7 +146,7 @@
(not (even? (1- x)))))) ;; 4 (not (even? (1- x)))))) ;; 4
even?)"))) even?)")))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (proc 0))))) (lambda () (proc 0)))))
(let ((counts (line-execution-counts data "baz.scm"))) (let ((counts (line-execution-counts data "baz.scm")))
(and (pair? counts) (and (pair? counts)
@ -166,7 +164,7 @@
((x) (+ x 3)) ;; 1 ((x) (+ x 3)) ;; 1
((x y) (+ x y))) ;; 2"))) ((x y) (+ x y))) ;; 2")))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (lambda ()
(+ (proc 1) (proc 2 3)))))) (+ (proc 1) (proc 2 3))))))
(let ((counts (line-execution-counts data "cl.scm"))) (let ((counts (line-execution-counts data "cl.scm")))
@ -179,7 +177,7 @@
(let ((proc (code "one-liner.scm" (let ((proc (code "one-liner.scm"
"(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))"))) "(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (proc 451 1884))))) (lambda () (proc 451 1884)))))
(let ((counts (line-execution-counts data "one-liner.scm"))) (let ((counts (line-execution-counts data "one-liner.scm")))
(equal? counts '((0 . 1)))))))) (equal? counts '((0 . 1))))))))
@ -190,7 +188,7 @@
(pass-if "several times" (pass-if "several times"
(let ((proc (code "foo.scm" "(lambda (x y) x)"))) (let ((proc (code "foo.scm" "(lambda (x y) x)")))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (+ (proc 1 2) (proc 2 3)))))) (lambda () (+ (proc 1 2) (proc 2 3))))))
(and (coverage-data? data) (and (coverage-data? data)
(= 3 result) (= 3 result)
@ -199,7 +197,7 @@
(pass-if "case-lambda" (pass-if "case-lambda"
(let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))"))) (let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))")))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (lambda ()
(+ (proc 1) (proc 2 3)))))) (+ (proc 1) (proc 2 3))))))
(and (coverage-data? data) (and (coverage-data? data)
@ -209,7 +207,7 @@
(pass-if "never" (pass-if "never"
(let ((proc (code "foo.scm" "(lambda (x y) x)"))) (let ((proc (code "foo.scm" "(lambda (x y) x)")))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (+ 1 2))))) (lambda () (+ 1 2)))))
(and (coverage-data? data) (and (coverage-data? data)
(= 3 result) (= 3 result)
@ -220,14 +218,14 @@
(proc (lambda args (length args))) (proc (lambda args (length args)))
(b (make-struct <box> 0 proc))) (b (make-struct <box> 0 proc)))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm b))) (with-code-coverage b)))
(and (coverage-data? data) (and (coverage-data? data)
(= 0 result) (= 0 result)
(= (procedure-execution-count data proc) 1))))) (= (procedure-execution-count data proc) 1)))))
(pass-if "called from C" (pass-if "called from C"
;; The `scm_call_N' functions use the VM returned by `the-vm'. This ;; 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))")) (let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
(call (false-if-exception ; can we resolve `scm_call_2'? (call (false-if-exception ; can we resolve `scm_call_2'?
(pointer->procedure '* (pointer->procedure '*
@ -236,7 +234,7 @@
'(* * *))))) '(* * *)))))
(if call (if call
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (lambda ()
(call (make-pointer (object-address proc)) (call (make-pointer (object-address proc))
(make-pointer (object-address 1)) (make-pointer (object-address 1))
@ -248,7 +246,7 @@
(pass-if "called from eval" (pass-if "called from eval"
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (lambda ()
(eval '(test-procedure 123) (current-module)))))) (eval '(test-procedure 123) (current-module))))))
(and (coverage-data? data) (and (coverage-data? data)
@ -261,7 +259,7 @@
(pass-if "source files are listed as expected" (pass-if "source files are listed as expected"
(let ((proc (code "chbouib.scm" "(lambda (x y) x)"))) (let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
(let-values (((data result) (let-values (((data result)
(with-code-coverage %test-vm (with-code-coverage
(lambda () (proc 1 2))))) (lambda () (proc 1 2)))))
(let ((files (map basename (instrumented-source-files data)))) (let ((files (map basename (instrumented-source-files data))))

2
test-suite/tests/eval.test
View file

@ -18,7 +18,7 @@
(define-module (test-suite test-eval) (define-module (test-suite test-eval)
:use-module (test-suite lib) :use-module (test-suite lib)
:use-module ((srfi srfi-1) :select (unfold count)) :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 documentation)
:use-module (ice-9 local-eval)) :use-module (ice-9 local-eval))