ikarus/lib/libchezio.ss

(let ()
  (define-syntax message-case
    (syntax-rules  (else)
      [(_ msg args 
          [(msg-name msg-arg* ...) b b* ...] ... 
          [else else1 else2 ...])
       (let ([tmsg msg] [targs args])
         (define-syntax match-and-bind
           (syntax-rules ()
             [(__ y () body)
              (if (null? y) 
                  body
                  (error 'message-case "unmatched ~s" (cons tmsg targs)))]
             [(__ y (a a* (... ...)) body)
              (if (pair? y)
                  (let ([a (car y)] [d (cdr y)])
                    (match-and-bind d (a* (... ...)) body))
                  (error 'message-case "unmatched ~s" (cons tmsg targs)))]))
         (case tmsg
           [(msg-name) 
            (match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
           [else else1 else2 ...]))]))
  
  (let () ;;; GENERIC PORTS: BASIC PRIMITIVES
    ;;;
    ;;; Exports: 
    ;;; * Constructors:
    ;;;   (make-input-port handler input-buffer)
    ;;;   (make-output-port handler output-buffer)
    ;;;   (make-input/output-port handler input-buffer output-buffer)
    ;;;
    ;;; * Predicates:
    ;;;   (port? x)
    ;;;   (input-port? x)
    ;;;   (output-port? x)
    ;;;
    ;;; * Accessors:
    ;;;   (port-handler port)
    ;;;   (port-input-buffer port)
    ;;;   (port-input-index port)
    ;;;   (port-input-size port)
    ;;;   (port-output-buffer port)
    ;;;   (port-output-index port)
    ;;;   (port-output-size port)
    ;;;
    ;;; * Mutators:
    ;;;   (set-port-handler! port proc)
    ;;;   (set-port-input-buffer! port string)
    ;;;   (set-port-input-index! port fixnum)
    ;;;   (set-port-input-size! port fixnum)
    ;;;   (set-port-output-buffer! port string)
    ;;;   (set-port-output-index! port fixnum)
    ;;;   (set-port-output-size! port fixnum)
    ;;;
    (primitive-set! 'port?
      (lambda (x) (port? x)))
    ;;;
    (primitive-set! 'input-port?
      (lambda (x) (input-port? x)))
    ;;;
    (primitive-set! 'output-port?
      (lambda (x) (output-port? x)))
    ;;;
    (primitive-set! '$make-input-port
      (lambda (handler buffer)
        ($make-port/input handler buffer 0 ($string-length buffer) #f 0 0)))
    ;;;
    (primitive-set! 'make-input-port
      (lambda (handler buffer)
        (if (procedure? handler)
            (if (string? buffer)
                ($make-input-port handler buffer)
                (error 'make-input-port "~s is not a string" buffer))
            (error 'make-input-port "~s is not a procedure" handler))))
    ;;;
    (primitive-set! '$make-output-port
      (lambda (handler buffer)
        ($make-port/output handler #f 0 0 buffer 0 ($string-length buffer))))
    ;;;
    (primitive-set! 'make-output-port
      (lambda (handler buffer)
        (if (procedure? handler)
            (if (string? buffer)
                ($make-output-port handler buffer)
                (error 'make-output-port "~s is not a string" buffer))
            (error 'make-output-port "~s is not a procedure" handler))))
    ;;;
    (primitive-set! '$make-input/output-port
      (lambda (handler input-buffer output-buffer)
         ($make-port/both handler
                    input-buffer 0 ($string-length input-buffer)
                    output-buffer 0 ($string-length output-buffer))))
    (primitive-set! 'make-input/output-port
      (lambda (handler input-buffer output-buffer)
        (if (procedure? handler)
            (if (string? input-buffer)
                (if (string? output-buffer)
                    ($make-input/output-port handler input-buffer output-buffer) 
                    (error 'make-input/output-port 
                           "~s is not a string"
                           output-buffer))
                (error 'make-input/output-port "~s is not a string" input-buffer))
            (error 'make-input/output-port "~s is not a procedure" handler))))
    ;;;
    (primitive-set! '$port-handler
      (lambda (x) ($port-handler x)))
    ;;;
    (primitive-set! 'port-handler
      (lambda (x)
        (if (port? x)
            ($port-handler x)
            (error 'port-handler "~s is not a port" x))))
    ;;;
    (primitive-set! '$port-input-buffer
      (lambda (x) ($port-input-buffer x)))
    ;;;
    (primitive-set! 'port-input-buffer
      (lambda (x)
        (if (input-port? x)
            ($port-input-buffer x)
            (error 'port-input-buffer "~s is not an input-port" x))))
    ;;;
    (primitive-set! '$port-input-index
      (lambda (x) ($port-input-index x)))
    ;;;
    (primitive-set! 'port-input-index
      (lambda (x)
        (if (input-port? x)
            ($port-input-index x)
            (error 'port-input-index "~s is not an input-port" x))))
    ;;;
    (primitive-set! '$port-input-size
      (lambda (x) ($port-input-size x)))
    ;;;
    (primitive-set! 'port-input-size
      (lambda (x)
        (if (input-port? x)
            ($port-input-size x)
            (error 'port-input-size "~s is not an input-port" x))))
    ;;;
    (primitive-set! '$port-output-buffer
      (lambda (x) ($port-output-buffer x)))
    ;;;
    (primitive-set! 'port-output-buffer
      (lambda (x)
        (if (output-port? x)
            ($port-output-buffer x)
            (error 'port-output-buffer "~s is not an output-port" x))))
    ;;;
    (primitive-set! '$port-output-index
      (lambda (x) ($port-output-index x)))
    ;;;
    (primitive-set! 'port-output-index
      (lambda (x)
        (if (output-port? x)
            ($port-output-index x)
            (error 'port-output-index "~s is not an output-port" x))))
    ;;;
    (primitive-set! '$port-output-size
      (lambda (x) ($port-output-size x)))
    ;;;
    (primitive-set! 'port-output-size
      (lambda (x)
        (if (output-port? x)
            ($port-output-size x)
            (error 'port-output-size "~s is not an output-port" x))))
    ;;;
    (primitive-set! '$set-port-input-index!
      (lambda (p i) ($set-port-input-index! p i)))
    ;;;
    (primitive-set! 'set-port-input-index!
      (lambda (p i)
        (if (input-port? p)
            (if (fixnum? i)
                (if ($fx>= i 0)
                    (if ($fx<= i ($port-input-size p))
                        ($set-port-input-index! p i)
                        (error 'set-port-input-index! "index ~s is too big" i))
                    (error 'set-port-input-index! "index ~s is negative" i))
                (error 'set-port-input-index! "~s is not a valid index" i))
            (error 'set-port-input-index! "~s is not an input-port" p))))
    ;;;
    (primitive-set! '$set-port-input-size!
      (lambda (p i) 
        ($set-port-input-index! p 0)
        ($set-port-input-size! p i)))
    ;;;
    (primitive-set! 'set-port-input-size!
      (lambda (p i)
        (if (input-port? p)
            (if (fixnum? i)
                (if ($fx>= i 0)
                    (if ($fx<= i ($string-length ($port-input-buffer p)))
                        (begin
                          ($set-port-input-index! p 0)
                          ($set-port-input-size! p i))
                        (error 'set-port-input-size! "size ~s is too big" i))
                    (error 'set-port-input-size! "size ~s is negative" i))
                (error 'set-port-input-size! "~s is not a valid size" i))
            (error 'set-port-input-size! "~s is not an input-port" p))))
    ;;;
    (primitive-set! '$set-port-output-index!
      (lambda (p i) ($set-port-output-index! p i)))
    ;;;
    (primitive-set! 'set-port-output-index!
      (lambda (p i)
        (if (output-port? p)
            (if (fixnum? i)
                (if ($fx>= i 0)
                    (if ($fx<= i ($port-output-size p))
                        ($set-port-output-index! p i)
                        (error 'set-port-output-index! "index ~s is too big" i))
                    (error 'set-port-output-index! "index ~s is negative" i))
                (error 'set-port-output-index! "~s is not a valid index" i))
            (error 'set-port-output-index! "~s is not an output-port" p))))
    ;;;
    (primitive-set! '$set-port-output-size!
      (lambda (p i) 
        ($set-port-output-index! p 0)
        ($set-port-output-size! p i)))
    ;;;
    (primitive-set! 'set-port-output-size!
      (lambda (p i)
        (if (output-port? p)
            (if (fixnum? i)
                (if ($fx>= i 0)
                    (if ($fx<= i ($string-length ($port-output-buffer p)))
                        (begin
                          ($set-port-output-index! p 0)
                          ($set-port-output-size! p i))
                        (error 'set-port-output-size! "size ~s is too big" i))
                    (error 'set-port-output-size! "size ~s is negative" i))
                (error 'set-port-output-size! "~s is not a valid size" i))
            (error 'set-port-output-size! "~s is not an output-port" p)))))
  
  (let () ;;; IO PRIMITIVES
    ;;;
    (primitive-set! '$write-char
      (lambda (c p)
        (let ([idx (port-output-index p)])
          (if ($fx< idx ($port-output-size p))
              (begin
                ($string-set! ($port-output-buffer p) idx c)
                ($set-port-output-index! p ($fxadd1 idx)))
              (($port-handler p) 'write-char c p)))))
    ;;;
    (primitive-set! 'write-char
      (case-lambda
        [(c)
         (if (char? c)
             ($write-char c (current-output-port))
             (error 'write-char "~s is not a character" c))]
        [(c p)
         (if (char? c)
             (if (output-port? p)
                 ($write-char c p)
                 (error 'write-char "~s is not an output-port" p))
             (error 'write-char "~s is not a character" c))]))
    ;;;
    (primitive-set! 'newline
      (case-lambda
        [() 
         ($write-char #\newline (current-output-port))
         ($flush-output-port (current-output-port))]
        [(p) 
         (if (output-port? p)
             (begin
               ($write-char #\newline p)
               ($flush-output-port p))
             (error 'newline "~s is not an output port" p))]))
    ;;;
    (primitive-set! 'port-name
      (lambda (p)
        (if (port? p) 
            (($port-handler p) 'port-name p)
            (error 'port-name "~s is not a port" p))))
    (primitive-set! 'input-port-name port-name)
    (primitive-set! 'output-port-name port-name)
    (primitive-set! '$read-char
      (lambda (p)
        (let ([idx ($port-input-index p)])
          (if ($fx< idx ($port-input-size p))
              (begin
                ($set-port-input-index! p ($fxadd1 idx))
                ($string-ref ($port-input-buffer p) idx))
              (begin
                (($port-handler p) 'read-char p))))))
    ;;;
    (primitive-set! 'read-char
      (case-lambda
        [() ($read-char *current-input-port*)]
        [(p)
         (if (input-port? p)
             ($read-char p)
             (error 'read-char "~s is not an input-port" p))]))
    ;;;
    (primitive-set! '$unread-char
      (lambda (c p)
        (let ([idx ($fxsub1 ($port-input-index p))])
          (if (and ($fx>= idx 0)
                   ($fx< idx ($port-input-size p)))
              (begin
                ($set-port-input-index! p idx)
                ($string-set! ($port-input-buffer p) idx c))
              (($port-handler p) 'unread-char c p)))))
    ;;;
    (primitive-set! 'unread-char
      (case-lambda
        [(c) (if (char? c)
                 ($unread-char c (current-input-port))
                 (error 'unread-char "~s is not a character" c))]
        [(c p)
         (if (input-port? p)
             (if (char? c)
                 ($unread-char c p)
                 (error 'unread-char "~s is not a character" c))
             (error 'unread-char "~s is not an input-port" p))]))
    ;;;
    (primitive-set! '$peek-char
      (lambda (p)
        (let ([idx ($port-input-index p)])
          (if ($fx< idx ($port-input-size p))
              ($string-ref ($port-input-buffer p) idx)
              (($port-handler p) 'peek-char p)))))
    ;;;
    (primitive-set! 'peek-char
      (case-lambda
        [() ($peek-char (current-input-port))]
        [(p)
         (if (input-port? p)
             ($peek-char p)
             (error 'peek-char "~s is not an input-port" p))]))
    ;;;
    (primitive-set! '$unread-char
      (lambda (c p)
        (let ([idx ($fxsub1 ($port-input-index p))])
          (if (and ($fx>= idx 0)
                   ($fx< idx ($port-input-size p)))
              (begin
                ($set-port-input-index! p idx)
                ($string-set! ($port-input-buffer p) idx c))
              (($port-handler p) 'unread-char c p)))))
    ;;;
    (primitive-set! '$reset-input-port!
      (lambda (p)
        ($set-port-input-size! p 0)))
    ;;;
    (primitive-set! 'reset-input-port!
      (case-lambda
        [() ($reset-input-port! (current-input-port))]
        [(p)
         (if (input-port? p)
             ($reset-input-port! p)
             (error 'reset-input-port! "~s is not an input-port" p))]))
    ;;;
    (primitive-set! '$close-input-port
      (lambda (p)
        (($port-handler p) 'close-port p)))
    ;;;
    (primitive-set! 'close-input-port
      (case-lambda
        [() ($close-input-port (current-input-port))]
        [(p)
         (if (input-port? p)
             ($close-input-port p)
             (error 'close-input-port! "~s is not an input-port" p))]))
    ;;;
    (primitive-set! '$close-output-port
      (lambda (p)
        (($port-handler p) 'close-port p)))
    ;;;
    (primitive-set! 'close-output-port
      (case-lambda
        [() ($close-output-port (current-output-port))]
        [(p)
         (if (output-port? p)
             ($close-output-port p)
             (error 'close-output-port "~s is not an output-port" p))]))
    ;;;
    (primitive-set! '$flush-output-port
      (lambda (p)
        (($port-handler p) 'flush-output-port p)))
    ;;;
    (primitive-set! 'flush-output-port
      (case-lambda
        [() ($flush-output-port (current-output-port))]
        [(p)
         (if (output-port? p)
             ($flush-output-port p)
             (error 'flush-output-port "~s is not an output-port" p))])))
  
  (let () ;;; INPUT FILES
    ;;;
    (define make-input-file-handler
      (lambda (fd port-name)
        (let ((open? #t))
          (lambda (msg . args)
            (message-case msg args
              [(read-char p)
               (unless (input-port? p)
                 (error 'read-char "~s is not an input port" p))
               (let ([idx ($port-input-index p)])
                 (if ($fx< idx ($port-input-size p))
                     (begin
                       ($set-port-input-index! p ($fxadd1 idx))
                       ($string-ref ($port-input-buffer p) idx))
                     (if open?
                         (let ([bytes
                                (foreign-call "ikrt_read" fd
                                              ($port-input-buffer p))])
                           (cond
                             [(not bytes)
                              (error 'read-char "Cannot read from ~s" port-name)]
                             [($fx= bytes 0)
                              (eof-object)]
                             [else
                              ($set-port-input-size! p bytes)
                              ($read-char p)]))
                         (error 'read-char "port ~s is closed" p))))]
              [(peek-char p)
               (unless (input-port? p)
                 (error 'peek-char "~s is not an input port" p))
               (let ([idx ($port-input-index p)])
                 (if ($fx< idx ($port-input-size p))
                     ($string-ref ($port-input-buffer p) idx)
                     (if open?
                         (let ([bytes
                                (foreign-call "ikrt_read" fd
                                              (port-input-buffer p))])
                           (cond
                             [(not bytes)
                              (error 'peek-char
                                     "Cannot read from ~s" port-name)]
                             [($fx= bytes 0)
                              (eof-object)]
                             [else
                              ($set-port-input-size! p bytes)
                              ($peek-char p)]))
                         (error 'peek-char "port ~s is closed" p))))]
              [(unread-char c p)
               (unless (input-port? p)
                 (error 'unread-char "~s is not an input port" p))
               (let ([idx ($fxsub1 ($port-input-index p))])
                 (if (and ($fx>= idx 0)
                          ($fx< idx ($port-input-size p)))
                     (begin
                       ($set-port-input-index! p idx)
                       ($string-set! ($port-input-buffer p) idx c))
                     (if open?
                         (error 'unread-char "port ~s is closed" p)
                         (error 'unread-char "too many unread-chars"))))]
              [(port-name p) port-name]
              [(close-port p)
               (unless (input-port? p)
                 (error 'close-input-port "~s is not an input port" p))
               (when open?
                 ($set-port-input-size! p 0)
                 (set! open? #f)
                 (unless (foreign-call "ikrt_close_file" fd)
                    (error 'close-input-port "cannot close ~s" port-name)))]
              [else 
               (error 'input-file-handler
                      "message not handled ~s" (cons msg args))])))))
    (define open-input-file
      (lambda (filename)
        (let ([fd/error (foreign-call "ikrt_open_input_file" filename)])
          (if (fixnum? fd/error)
              (let ([port (make-input-port 
                            (make-input-file-handler fd/error filename)
                            (make-string 4096))])
                (set-port-input-size! port 0)
                port)
              (error 'open-input-file "cannot open ~s: ~a" filename fd/error)))))
    (primitive-set! '*standard-input-port* 
      (let ([p (make-input-port 
                 (make-input-file-handler 0 '*stdin*)
                 (make-string 4096))])
        (set-port-input-size! p 0)
        p))
    (primitive-set! 'console-input-port (lambda () *standard-input-port*))
    (primitive-set! '*current-input-port* *standard-input-port*)
    (primitive-set! 'current-input-port 
      (case-lambda
        [() *current-input-port*]
        [(p) 
         (if (input-port? p)
             (primitive-set! '*current-input-port* p)
             (error 'current-input-port "~s is not an input-port" p))]))
    (primitive-set! 'open-input-file
      (lambda (filename)
         (if (string? filename)
             (open-input-file filename)
             (error 'open-input-file "~s is not a string" filename)))))
  
  (let () ;;; OUTPUT FILES
    ;;;
    (define do-write-buffer
      (lambda (fd port-name p caller)
        (let ([bytes (foreign-call "ikrt_write_file" 
                                   fd
                                   (port-output-buffer p)
                                   (port-output-index p))])
          (if (fixnum? bytes)
              (set-port-output-index! p 0)
              (error caller "cannot write to file ~s: ~a" port-name bytes)))))
    (define make-output-file-handler
      (lambda (fd port-name)
        (define open? #t)
        (define output-file-handler
          (lambda (msg . args)
            (message-case msg args
              [(write-char c p)
               (if (char? c)
                   (if (output-port? p)
                       (let ([idx ($port-output-index p)])
                          (if ($fx< idx ($port-output-size p))
                              (begin
                                ($string-set! ($port-output-buffer p) idx c)
                                ($set-port-output-index! p ($fxadd1 idx)))
                              (if open?
                                (begin
                                  (do-write-buffer fd port-name p 'write-char)
                                  ($write-char c p))
                                (error 'write-char "port ~s is closed" p))))
                       (error 'write-char "~s is not an output-port" p))
                   (error 'write-char "~s is not a character" c))]
              [(flush-output-port p)
               (if (output-port? p)
                   (if open?
                       (do-write-buffer fd port-name p 'flush-output-port)
                       (error 'flush-output-port "port ~s is closed" p))
                   (error 'flush-output-port "~s is not an output-port" p))]
              [(close-port p)
               (when open?
                 (flush-output-port p)
                 ($set-port-output-size! p 0)
                 (set! open? #f)
                 (unless (foreign-call "ikrt_close_file" fd)
                   (error 'close-output-port "cannot close ~s" port-name)))]
              [(port-name p) port-name]
              [else (error 'output-file-handler 
                           "unhandled message ~s" (cons msg args))])))
        output-file-handler))
    (define (option-id x)
      (case x
        [(error)    0]
        [(replace)  1]
        [(truncate) 2]
        [(append)   3]
        [else (error 'open-output-file "~s is not a valid mode" x)]))
    (define open-output-file
      (lambda (filename options)
        (let ([fd/error 
               (foreign-call "ikrt_open_output_file" 
                             filename 
                             (option-id options))])
          (if (fixnum? fd/error)
              (make-output-port
                (make-output-file-handler fd/error filename)
                (make-string 4096))
              (error 'open-output-file "cannot open ~s: ~a" filename fd/error)))))
    (primitive-set! '*standard-output-port* 
      (make-output-port
        (make-output-file-handler 1 '*stdout*)
        (make-string 4096)))
    (primitive-set! '*current-output-port* *standard-output-port*)
    (primitive-set! '*standard-error-port* 
      (make-output-port
        (make-output-file-handler 2 '*stderr*)
        (make-string 4096)))
    (primitive-set! 'standard-output-port 
       (lambda () *standard-output-port*))
    (primitive-set! 'standard-error-port
       (lambda () *standard-error-port*))
    (primitive-set! 'console-output-port 
       (lambda () *standard-output-port*))
    (primitive-set! 'current-output-port 
       (case-lambda
         [() *current-output-port*]
         [(p)
          (if (output-port? p)
              (primitive-set! '*current-output-port* p)
              (error 'current-output-port "~s is not an output port" p))]))
    (primitive-set! 'open-output-file 
      (case-lambda
        [(filename)
         (if (string? filename)
             (open-output-file filename 'error)
             (error 'open-output-file "~s is not a string" filename))]
        [(filename options)
         (if (string? filename)
             (open-output-file filename options)
             (error 'open-output-file "~s is not a string" filename))])))
  
  (let () ;;; OUTPUT STRINGS
    ;;;
    (define string-copy 
      (lambda (s)
        (substring s 0 (string-length s))))
    (define concat 
      (lambda (str i ls)
        (let ([n (sum i ls)])
          (let ([outstr ($make-string n)])
            (let f ([n (copy outstr str i n)] [ls ls])
              (if (null? ls)
                  outstr
                  (let ([a ($car ls)])
                    (f (copy outstr a ($string-length a) n) ($cdr ls)))))))))
    (define sum 
      (lambda (ac ls)
        (cond
          [(null? ls) ac]
          [else (sum ($fx+ ac ($string-length ($car ls))) ($cdr ls))])))
    (define copy
      (lambda (dst src n end)
        (let f ([di end]
                [si n])
          (cond
            [($fx= si 0) di]
            [else
             (let ([di ($fxsub1 di)] [si ($fxsub1 si)])
               ($string-set! dst di ($string-ref src si))
               (f di si))]))))
    (define make-output-string-handler
      (lambda ()
        (define buffer-list '())
        (define open? #t)
        (define output-handler
          (lambda (msg . args)
            (message-case msg args
              [(write-char c p)
               (if (char? c)
                   (if (output-port? p)
                       (let ([idx ($port-output-index p)])
                          (if ($fx< idx ($port-output-size p))
                              (begin
                                ($string-set! ($port-output-buffer p) idx c)
                                ($set-port-output-index! p ($fxadd1 idx)))
                              (if open?
                                (begin
                                  (set! buffer-list
                                    (cons (string-copy (port-output-buffer p))
                                          buffer-list))
                                  ($set-port-output-size! p 
                                    ($string-length ($port-output-buffer p)))
                                  ($write-char c p))
                                (error 'write-char "port ~s is closed" p))))
                       (error 'write-char "~s is not an output-port" p))
                   (error 'write-char "~s is not a character" c))]
              [(flush-output-port p)
               (void)]
              [(close-port p)
               (set! open? #f)]
              [(port-name p) 'string-port]
              [(get-output-string p) 
               (concat ($port-output-buffer p)
                       ($port-output-index p)
                       buffer-list)]
              [else (error 'output-handler 
                           "unhandled message ~s" (cons msg args))])))
        output-handler))
    (primitive-set! 'open-output-string 
      (lambda ()
        (make-output-port 
          (make-output-string-handler)
          (make-string 10))))
    (primitive-set! 'get-output-string
      (lambda (p)
        (if (output-port? p)
            (($port-handler p) 'get-output-string p)
            (error 'get-output-string "~s is not an output port" p))))
  )
  
  (primitive-set! 'with-output-to-file
     (lambda (name proc . args)
       (unless (string? name) 
         (error 'with-output-to-file "~s is not a string" name))
       (unless (procedure? proc)
         (error 'with-output-to-file "~s is not a procedure" proc))
       (let ([p (apply open-output-file name args)]
             [shot #f])
         (parameterize ([current-output-port p])
           (dynamic-wind 
             (lambda () 
               (when shot
                 (error 'with-output-to-file 
                        "cannot reenter")))
             proc
             (lambda () 
               (close-output-port p)
               (set! shot #t)))))))
  
  (primitive-set! 'call-with-output-file
     (lambda (name proc . args)
       (unless (string? name) 
         (error 'call-with-output-file "~s is not a string" name))
       (unless (procedure? proc)
         (error 'call-with-output-file "~s is not a procedure" proc))
       (let ([p (apply open-output-file name args)]
             [shot #f])
         (dynamic-wind 
           (lambda () 
             (when shot
               (error 'call-with-output-file "cannot reenter")))
           (lambda () (proc p))
           (lambda () 
             (close-output-port p)
             (set! shot #t))))))
  
  (primitive-set! 'with-input-from-file
     (lambda (name proc)
       (unless (string? name) 
         (error 'with-input-from-file "~s is not a string" name))
       (unless (procedure? proc)
         (error 'with-input-from-file "~s is not a procedure" proc))
       (let ([p (open-input-file name)]
             [shot #f])
         (parameterize ([current-input-port p])
           (dynamic-wind 
             (lambda () 
               (when shot
                 (error 'with-input-from-file 
                        "cannot reenter")))
             proc
             (lambda () 
               (close-input-port p)
               (set! shot #t)))))))
  
  (primitive-set! 'call-with-input-file
     (lambda (name proc)
       (unless (string? name) 
         (error 'call-with-input-file "~s is not a string" name))
       (unless (procedure? proc)
         (error 'call-with-input-file "~s is not a procedure" proc))
       (let ([p (open-input-file name)]
             [shot #f])
         (dynamic-wind 
           (lambda () 
             (when shot
               (error 'call-with-input-file "cannot reenter")))
           (lambda () (proc p))
           (lambda () 
             (close-input-port p)
             (set! shot #t))))))
)