58 lines
1.9 KiB
Scheme
58 lines
1.9 KiB
Scheme
|
;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
|
||
|
;;;
|
||
|
;;; Port Author: Andrew Whatson
|
||
|
;;;
|
||
|
;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
|
||
|
;;;
|
||
|
;;; scheme48-1.9.2/scheme/bcomp/read-form.scm
|
||
|
|
||
|
(define-module (prescheme bcomp read-form)
|
||
|
#:use-module (prescheme scheme48)
|
||
|
#:use-module (prescheme bcomp package)
|
||
|
#:export (read-forms $note-file-package))
|
||
|
|
||
|
;; The value of $NOTE-FILE-PACKAGE is called whenever a file is loaded into
|
||
|
;; a package. env/debug.scm uses this to associate packages with files so
|
||
|
;; that code stuffed to the REPL will be eval'ed in the correct package.
|
||
|
;;
|
||
|
;; Is there any point in having this be a fluid?
|
||
|
|
||
|
(define $note-file-package
|
||
|
(make-fluid (make-cell (lambda (filename package)
|
||
|
(values)))))
|
||
|
|
||
|
(define (read-forms pathname package script?)
|
||
|
(let* ((filename (namestring pathname #f *scheme-file-type*))
|
||
|
(truename (translate filename))
|
||
|
(port (open-input-file truename))
|
||
|
(reader (package-reader package)))
|
||
|
(dynamic-wind
|
||
|
(lambda ()
|
||
|
(if (not port)
|
||
|
(assertion-violation 'read-forms "attempt to throw back into READ-FORMS")))
|
||
|
(lambda ()
|
||
|
((fluid-cell-ref $note-file-package) filename package)
|
||
|
(let ((o-port (current-noise-port)))
|
||
|
(display truename o-port)
|
||
|
(force-output o-port)
|
||
|
(really-read-forms port reader script?)))
|
||
|
(lambda ()
|
||
|
(close-input-port port)
|
||
|
(set! port #f)))))
|
||
|
|
||
|
(define (really-read-forms port reader script?)
|
||
|
(if script?
|
||
|
(skip-line port))
|
||
|
(let loop ((forms '()))
|
||
|
(let ((form (reader port)))
|
||
|
(if (eof-object? form)
|
||
|
(reverse forms)
|
||
|
(loop (cons form forms))))))
|
||
|
|
||
|
(define (skip-line port)
|
||
|
(let loop ()
|
||
|
(let ((char (read-char port)))
|
||
|
(if (and (not (eof-object? char))
|
||
|
(not (char=? #\newline char)))
|
||
|
(loop)))))
|