#| -*-Scheme-*-
-Copyright (C) 2006, 2007, 2008, 2009, 2010 Matthew Birkholz
+Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(define (call-alien* alien-function args)
(let ((old-top calloutback-stack))
- (if-tracing
+ (%if-tracing
(outf-console ";"(tindent)"=> "alien-function" "args"\n")
(set! calloutback-stack (cons (cons* alien-function args) old-top)))
(let ((value (apply (ucode-primitive c-call -1) alien-function args)))
- (if-tracing
- (assert (eq? old-top (cdr calloutback-stack))
- "call-alien: freak stack "calloutback-stack"\n")
+ (%if-tracing
+ (%assert (eq? old-top (cdr calloutback-stack))
+ "call-alien: freak stack "calloutback-stack"\n")
(set! calloutback-stack old-top)
(outf-console ";"(tindent)"<= "value"\n"))
value)))
(error:bad-range-argument id 'apply-callback))
(normalize-aliens! args)
(let ((old-top calloutback-stack))
- (if-tracing
+ (%if-tracing
(outf-console ";"(tindent)"=>> "procedure" "args"\n")
(set! calloutback-stack (cons (cons procedure args) old-top)))
(let ((value (apply-callback-proc procedure args)))
- (if-tracing
- (assert (and (pair? calloutback-stack)
- (eq? old-top (cdr calloutback-stack)))
- "callback-handler: freak stack "calloutback-stack"\n")
+ (%if-tracing
+ (%assert (and (pair? calloutback-stack)
+ (eq? old-top (cdr calloutback-stack)))
+ "callback-handler: freak stack "calloutback-stack"\n")
(set! calloutback-stack old-top)
(outf-console ";"(tindent)"<<= "value"\n"))
value))))
(define calloutback-stack '())
-(define trace? #f)
+(define %trace? #f)
(define (reset-package!)
(reset-alien-functions!)
(reset-malloced-aliens!)
(reset-callbacks!)
(set! %radix (if (fix:fixnum? #x100000000) #x100000000 #x10000))
- (set! trace? #f)
+ (set! %trace? #f)
(set! calloutback-stack '()))
(define (initialize-package!)
(add-gc-daemon! free-malloced-aliens)
unspecific)
-(define-syntax if-tracing
+(define-syntax %if-tracing
(syntax-rules ()
((_ . BODY)
- (if trace? ((lambda () . BODY))))))
+ (if %trace? ((lambda () . BODY))))))
-(define-syntax assert
+(define-syntax %assert
(syntax-rules ()
((_ TEST . MSG)
(if (not TEST) (error "Failed assert:" . MSG)))))
-(define-syntax trace
+(define-syntax %trace
(syntax-rules ()
((_ . MSG)
- (if trace? ((lambda () (outf-console . MSG)))))))
+ (if %trace? ((lambda () (outf-console . MSG)))))))
(define (tindent)
(make-string (* 2 (length calloutback-stack)) #\space))
\ No newline at end of file