source: project/release/4/dissector/chicken_compat.scm @ 12396

Last change on this file since 12396 was 12286, checked in by felix winkelmann, 12 years ago

ported to chicken-4

File size: 1.7 KB
Line 
1;;;;;; Compatibility module for Chicken
2
3;;; Copyright (C) 2004, Taylor Campbell
4;;; All rights reserved.
5;;; See the LICENCE file for details.
6
7
8(define unspecific void)
9
10(define (carefully-read port)
11  (handle-exceptions c (values #f #!eof)
12    (values #t (read port))))
13
14(define (with-exceptions-printed-to-port port thunk)
15  (handle-exceptions c (print-error-message c port) (thunk)))
16
17(define (call-with-limited-output-port base-port width receiver)
18  (let ((so-far 0)
19        (real-width (- width 4)))       ; Deal with the extra " ---".
20    (letrec ((my-write-string
21              (lambda (output)
22                (cond ((> real-width (+ so-far (string-length output)))
23                       (write-string output #f base-port)
24                       (set! so-far (+ so-far (string-length output))))
25                      (else
26                       (write-string (substring output 0
27                                                (- real-width
28                                                   so-far))
29                                     #f
30                                     base-port)
31                       (write-string " ---" #f base-port)
32                       (set! my-write-string
33                             (lambda (output) (void))))))))
34      (receiver
35       (make-output-port (lambda (output)
36                           (my-write-string output))
37                         (lambda ()
38                           (close-output-port base-port))
39                         (lambda ()
40                           (flush-output base-port)))))))
41
42(define (byte-block? x) (##core#inline "C_byteblockp" x))
43(define (d-tagged-pointer? x) (##core#inline "C_taggedpointerp" x))
44
45(define dissector-sort sort)
Note: See TracBrowser for help on using the repository browser.