read-form.scm 1.5 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849
  1. ; Part of Scheme 48 1.9. See file COPYING for notices and license.
  2. ; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
  3. ; The value of $NOTE-FILE-PACKAGE is called whenever a file is loaded into
  4. ; a package. env/debug.scm uses this to associate packages with files so
  5. ; that code stuffed to the REPL will be eval'ed in the correct package.
  6. ;
  7. ; Is there any point in having this be a fluid?
  8. (define $note-file-package
  9. (make-fluid (make-cell (lambda (filename package)
  10. (values)))))
  11. (define (read-forms pathname package script?)
  12. (let* ((filename (namestring pathname #f *scheme-file-type*))
  13. (truename (translate filename))
  14. (port (open-input-file truename))
  15. (reader (package-reader package)))
  16. (dynamic-wind
  17. (lambda ()
  18. (if (not port)
  19. (assertion-violation 'read-forms "attempt to throw back into READ-FORMS")))
  20. (lambda ()
  21. ((fluid-cell-ref $note-file-package) filename package)
  22. (let ((o-port (current-noise-port)))
  23. (display truename o-port)
  24. (force-output o-port)
  25. (really-read-forms port reader script?)))
  26. (lambda ()
  27. (close-input-port port)
  28. (set! port #f)))))
  29. (define (really-read-forms port reader script?)
  30. (if script?
  31. (skip-line port))
  32. (let loop ((forms '()))
  33. (let ((form (reader port)))
  34. (if (eof-object? form)
  35. (reverse forms)
  36. (loop (cons form forms))))))
  37. (define (skip-line port)
  38. (let loop ()
  39. (let ((char (read-char port)))
  40. (if (and (not (eof-object? char))
  41. (not (char=? #\newline char)))
  42. (loop)))))