(declare (unit userpass))

(define (read-info-hook class data val)
  (when (and (eq? 'list-info class) (symbol? (car data)))
    (##sys#hash-table-set!
     ##sys#line-number-database
     (car data)
     (alist-cons 
      data (conc ##sys#current-source-filename ":" val)
      (or (##sys#hash-table-ref ##sys#line-number-database (car data))
	  '() ) ) ) )
  (if (symbol? data)
	(cond
		((eq? '__LINE__ data) val)
		((eq? '__FILE__ data) ##sys#current-source-filename)
		(else data))
	data))

(define (read/source-info in)
  (##sys#read in read-info-hook) )

(define (check-and-open-input-file fname . line)
  (cond [(string=? fname "-") (current-input-port)]
	[(file-exists? fname) (open-input-file fname)]
	[(or (null? line) (not (car line))) (quit "Can not open file ~s" fname)]
	[else (quit "(~a) can not open file ~s" (car line) fname)] ) )

(define (close-checked-input-file port fname)
  (unless (string=? fname "-") (close-input-port port)) )

(define string->expr
  (let ([exn? (condition-predicate 'exn)]
	[exn-msg (condition-property-accessor 'exn 'message)] )
    (lambda (str)
      (handle-exceptions ex
	  (quit "cannot parse expression: ~s [~a]~%" 
		str
		(if (exn? ex) 
		    (exn-msg ex)
		    (->string ex) ) ) 
	(let ([xs (with-input-from-string
		      str
		    (lambda () (unfold eof-object? values (lambda (x) (read)) (read))))])
	  (cond [(null? xs) '(##core#undefined)]
		[(null? (cdr xs)) (car xs)]
		[else `(begin ,@xs)] ) ) ) ) ) )

(define (read-pass prelude files postlude)
	(define forms '())
	(do ((files files (cdr files)))
			  ((null? files)
			   (set! forms
			     (append (map string->expr prelude)
				     (reverse forms)
				     (map string->expr postlude) ) ) )
			(let* ((f (car files))
			       (in (check-and-open-input-file f)) )
			  (fluid-let ((##sys#current-source-filename f))
			    (let loop ()
			      (let ((x (read/source-info in)))
				(cond ((eof-object? x) 
				       (close-checked-input-file in f) )
				      (else
				       (set! forms (cons x forms))
				       (loop))))))))
	forms)

(let ([old (user-read-pass)])
	(user-read-pass read-pass))