Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

printing debug output on OOM

Browse source
This commit is contained in:
Alex Shinn 2012-06-24 14:07:59 -07:00
parent d11ededc50
commit bad54b143c
4 changed files with 70 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
gc.c
View file

@ -535,8 +535,10 @@ void* sexp_alloc (sexp ctx, size_t size) {
&& ((!h->max_size) || (total_size < h->max_size)))
sexp_grow_heap(ctx, size);
res = sexp_try_alloc(ctx, size);
if (! res)
if (! res) {
res = sexp_global(ctx, SEXP_G_OOM_ERROR);
sexp_debug_printf("ran out of memory allocating %lu bytes => %p", size, res);
}
}
return res;
}

4
lib/chibi/term/edit-line.sld
View file

@ -3,6 +3,8 @@
(export make-line-editor edit-line edit-line-repl
make-history history-insert!
history-commit! history->list list->history buffer->string
make-buffer buffer-make-completer buffer-row buffer-col)
make-buffer buffer-make-completer
buffer-clear buffer-refresh buffer-draw
buffer-row buffer-col)
(import (scheme) (chibi stty) (srfi 9))
(include "edit-line.scm"))

82
lib/chibi/test.scm
View file

@ -1,4 +1,4 @@
;; Copyright (c) 2010-2011 Alex Shinn. All rights reserved.
;; Copyright (c) 2010-2012 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;> Simple testing framework adapted from the Chicken @scheme{test}
@ -51,16 +51,27 @@
(define-syntax test
(syntax-rules ()
((test expect expr)
(test #f expect expr))
(let ((x 'expr))
(write x (current-error-port))
(display " => " (current-error-port))
(write (cond ((pair? x) (pair-source x))
((syntactic-closure? x)
(if (pair? (syntactic-closure-expr x))
(pair-source (syntactic-closure-expr x))
'N/A-sc))
(else 'N/A))
(current-error-port))
(newline (current-error-port))
(test #f expect expr)))
((test name expect (expr ...))
(test-info name expect (expr ...) ()))
(test-propagate-info name expect (expr ...) ()))
((test name (expect ...) expr)
(test-syntax-error
'test
"the test expression should come last "
(test name (expect ...) expr)))
((test name expect expr)
(test-info name expect expr ()))
(test-propagate-info name expect expr ()))
((test a ...)
(test-syntax-error 'test "2 or 3 arguments required"
(test a ...)))))
@ -74,7 +85,7 @@
((_ expr)
(test-assert #f expr))
((_ name expr)
(test-info name #f expr ((assertion . #t))))
(test-propagate-info name #f expr ((assertion . #t))))
((test a ...)
(test-syntax-error 'test-assert "1 or 2 arguments required"
(test a ...)))))
@ -111,11 +122,29 @@
((_ expr)
(test-error #f expr))
((_ name expr)
(test-info name #f expr ((expect-error . #t))))
(test-propagate-info name #f expr ((expect-error . #t))))
((test a ...)
(test-syntax-error 'test-error "1 or 2 arguments required"
(test a ...)))))
;; TODO: Extract interesting variables so we can show their values on
;; failure.
(define-syntax test-propagate-info
(syntax-rules ()
((test-propagate-info name expect expr info)
(test-vars () name expect expr info))))
(define-syntax test-vars
(syntax-rules ()
((_ (vars ...) n expect expr ((key . val) ...))
(test-run (lambda () expect)
(lambda () expr)
(cons (cons 'name n)
'((source . expr)
;;(var-names . (vars ...))
;;(var-values . ,(list vars))
(key . val) ...))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; group interface
@ -148,22 +177,6 @@
(syntax-rules ()
((_) (syntax-error "invalid use of test-syntax-error"))))
(define-syntax test-info
(syntax-rules ()
((test-info name expect expr info)
(test-vars () name expect expr ((source . expr) . info)))))
(define-syntax test-vars
(syntax-rules ()
((_ (vars ...) n expect expr ((key . val) ...))
(test-run (lambda () expect)
(lambda () expr)
(cons (cons 'name n)
'((source . expr)
;;(var-names . (vars ...))
;;(var-values . ,(list vars))
(key . val) ...))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; test-group representation
@ -269,6 +282,9 @@
(truncate-source src (- (current-column-width) 12))))
((current-test-group)
=> (lambda (g)
(display "no source in: " (current-error-port))
(write info (current-error-port))
(display "\n" (current-error-port))
(string-append
"test-"
(number->string (test-group-ref g 'count 0)))))
@ -312,13 +328,31 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test-expand-info info)
(let ((expr (assq-ref info 'source)))
(display "test-expand-info: " (current-error-port))
(write info (current-error-port))
(display " => " (current-error-port))
(write expr (current-error-port))
(display " => " (current-error-port))
(write (if (pair? expr) (pair-source expr) 'N/A) (current-error-port))
(display "\n" (current-error-port))
(if (and (pair? expr)
(pair-source expr)
(not (assq-ref info 'line-number)))
`((file-name . ,(car (pair-source expr)))
(line-number . ,(cdr (pair-source expr)))
,@info)
info)))
(define (test-run expect expr info)
(let ((info (test-expand-info info)))
(if (and (cond ((current-test-group)
=> (lambda (g) (not (test-group-ref g 'skip-group?))))
(else #t))
(every (lambda (f) (f info)) (current-test-filters)))
((current-test-applier) expect expr info)
((current-test-skipper) expect expr info)))
((current-test-skipper) expect expr info))))
(define (test-default-applier expect expr info)
(let* ((group (current-test-group))
@ -423,7 +457,7 @@
(cond
((assq-ref info 'line-number)
=> (lambda (line)
(display " in line ")
(display " on line ")
(write line)
(cond ((assq-ref info 'file-name)
=> (lambda (file) (display " of file ") (write file))))

2
lib/chibi/test.sld
View file

@ -3,7 +3,7 @@
(export
test test-error test-assert test-not test-values
test-group current-test-group
test-begin test-end ;; test-syntax-error ;; test-info
test-begin test-end ;; test-syntax-error ;; test-propagate-info
;; test-vars test-run ;; test-exit
current-test-verbosity current-test-epsilon current-test-comparator
current-test-applier current-test-handler current-test-skipper