Hi all,
Please find attached a self contained program, which is supposed to run
a useless thread for 3 seconds, kill it (logging a notice about an
exception being caught), create some garbage (logging a notice before
and afterwards) and exit properly.
To compile:
$ csc -o ttm ttm.scm
Here's the output on my machine:
$ ./ttm
test
Load error in (define aa (with-timeout 3 (lambda () (do () (#f)
#t)))):(timeout) in (define aa (with-timeout 3 (lambda () (do () (#f)
#t))))
let's do some garbage
Segmentation fault
$ ./ttm
test
Load error in (define aa (with-timeout 3 (lambda () (do () (#f)
#t)))):(timeout) in (define aa (with-timeout 3 (lambda () (do () (#f)
#t))))
let's do some garbage
out of memory - heap full while resizing - execution terminated
...more...
ttm.scm: 66 number->string
ttm.scm: 66 string-append
ttm.scm: 66 number->string
ttm.scm: 66 string-append
ttm.scm: 66 number->string
ttm.scm: 66 string-append
ttm.scm: 66 number->string
ttm.scm: 66 string-append <--
$ ./ttm
test
Load error in (define aa (with-timeout 3 (lambda () (do () (#f)
#t)))):(timeout) in (define aa (with-timeout 3 (lambda () (do () (#f)
#t))))
let's do some garbage
Segmentation fault
$ ./ttm
test
Load error in (define aa (with-timeout 3 (lambda () (do () (#f)
#t)))):(timeout) in (define aa (with-timeout 3 (lambda () (do () (#f)
#t))))
let's do some garbage
out of memory - heap full while resizing - execution terminated
...more...
ttm.scm: 66 number->string
ttm.scm: 66 string-append
ttm.scm: 66 number->string
ttm.scm: 66 string-append
ttm.scm: 66 number->string
ttm.scm: 66 string-append
ttm.scm: 66 number->string
ttm.scm: 66 string-append <--
$ ./ttm
test
Load error in (define aa (with-timeout 3 (lambda () (do () (#f)
#t)))):(timeout) in (define aa (with-timeout 3 (lambda () (do () (#f)
#t))))
let's do some garbage
Segmentation fault
Best regards
/Jörg
(declare (uses srfi-18)
(run-time-macros))
(define-macro (guard . form)
(let* ((clause (or (and (pair? form) (car form))
(error "guard: syntax error in" form)))
(body (cdr form))
(condition (gensym))
(handler-k (gensym))
(return (gensym))
(oldh (gensym)))
`((call-with-current-continuation
(lambda (,return)
(let ((,oldh (current-exception-handler)))
(with-exception-handler
(lambda (,condition)
(with-exception-handler
,oldh
(call-with-current-continuation
(lambda (,handler-k)
(,return (lambda ()
((lambda (,(car clause))
,(let loop ((clauses (cdr clause)))
(if (null? clauses)
`(raise ,(car clause))
(let ((c (car clauses)))
(cond
((eq? 'else (car c))
(if (null? (cdr c))
'#f
(if (null? (cddr c))
(cadr c)
`(begin . ,(cdr c)))))
((and (pair? c) (pair? (cdr c)) (eq? '=> (cadr c)))
(let ((v (gensym)))
`(let ((,v ,(car c)))
(if ,v (,(caddr c)) ,(loop (cdr clauses))))))
((and (pair? c) (null? (cdr c)))
(let ((v (gensym)))
`(let ((,v ,(car c)))
(if ,v ,v ,(loop (cdr clauses))))))
((pair? c)
`(if ,(car c)
,(if (null? (cddr c))
(cadr c)
`(begin . ,(cdr c)))
,(loop (cdr clauses))))
(else (error "guard syntax error in ~a" c)))))))
,condition)))))))
(lambda ()
(##sys#call-with-values
(lambda ()
,(if (and (pair? body) (null? (cdr body)))
(car body) `(begin . ,body) ))
(lambda args
(,return (lambda () (##sys#apply ##sys#values args)))) ) ) )) ) ))))
(define (logerr . args)
(apply format (current-error-port) args)
(flush-output (current-error-port))
(format (current-error-port) "let's do some garbage\n")
(flush-output (current-error-port))
(let ((s ""))
(do ((i 0 (+ i 1)))
((eqv? i 20000) #t)
(set! s (string-append s (number->string i)))))
(format (current-error-port) "enough garbage\n")
(flush-output (current-error-port)))
(define *local-timeout-symbol* '(timeout))
(define (timeout-object) *local-timeout-symbol*)
(define (timeout-object? obj)
(eq? *local-timeout-symbol* obj))
(define (with-timeout timeout thunk)
(if timeout
(let ([thread (thread-start! (make-thread thunk
;; (string-append (thread-name (current-thread)) "-worker")
))])
(guard
(condition
((join-timeout-exception? condition)
(thread-terminate! thread)
(raise (timeout-object)))
(else
(raise (if (uncaught-exception? condition)
(uncaught-exception-reason condition)
condition))))
(thread-join! thread timeout)))
(thunk)))
(define (load-or-die str)
(guard
(exception (else (logerr "Fatal load error in ~a:~s ~a\n" file ((condition-property-accessor 'exn 'message #f) exception) ((condition-property-accessor 'exn 'arguments #f) exception))
(exit 0)))
(call-with-input-string str
(lambda (port)
(let loop ((expr (read port))
(last #f))
(if (eof-object? expr)
last
(loop (read port)
(guard
(ex (else (logerr "Load error in ~a:~a in ~a\n"
str ex expr) #f))
(eval expr)))))))))
(print "test")
(load-or-die "(define aa (with-timeout 3 (lambda () (do () (#f) #t))))")
(logerr "done\n")
(exit 0)
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
