scan-package.scm 6.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163
  1. ;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
  2. ;;;
  3. ;;; Port Author: Andrew Whatson
  4. ;;;
  5. ;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
  6. ;;;
  7. ;;; scheme48-1.9.2/scheme/bcomp/scan-package.scm
  8. ;;;
  9. ;;; Scanning structures and processing package clauses.
  10. ;;;
  11. ;;; Utility for compile-structures (link/link.scm) and
  12. ;;; ensure-loaded (env/load-package.scm).
  13. ;;;
  14. ;;; Returns a list of all packages reachable from STRUCTS that answer true to
  15. ;;; INCLUDE-THIS-PACKAGE?.
  16. (define-module (prescheme bcomp scan-package)
  17. #:use-module (prescheme scheme48)
  18. #:use-module (prescheme filename)
  19. #:use-module (prescheme bcomp binding)
  20. #:use-module (prescheme bcomp cenv)
  21. #:use-module (prescheme bcomp mtype)
  22. #:use-module (prescheme bcomp package)
  23. #:use-module (prescheme bcomp read-form)
  24. #:export (collect-packages
  25. package-source))
  26. (define (collect-packages structs include-this-package?)
  27. (let ((package-seen '())
  28. (structure-seen '())
  29. (packages '()))
  30. (letrec ((recur
  31. (lambda (structure visited)
  32. (if (memq (structure-package structure) visited)
  33. (warning 'collect-packages "cycle in structures dependencies"
  34. structure visited))
  35. (if (not (memq structure structure-seen))
  36. (begin
  37. (set! structure-seen (cons structure structure-seen))
  38. (let ((package (structure-package structure)))
  39. (if (not (memq package package-seen))
  40. (begin
  41. (set! package-seen (cons package package-seen))
  42. (if (include-this-package? package)
  43. (let ((visited (cons package visited)))
  44. (for-each (lambda (struct)
  45. (recur struct visited))
  46. (package-opens package))
  47. (for-each (lambda (name+struct)
  48. (recur (cdr name+struct) visited))
  49. (package-accesses package))
  50. (set! packages (cons package packages))))))))))))
  51. (for-each (lambda (struct)
  52. (recur struct '()))
  53. structs)
  54. (reverse packages))))
  55. ; Walk through PACKAGE's clauses to find the source code. The relevant
  56. ; clauses are:
  57. ; (files name ...)
  58. ; (begin form ...)
  59. ; (define-all-operators)
  60. ; (usual-transforms name ...)
  61. ;
  62. ; Returns a list of pairs (file . (node1 node2 ...)), a list of names
  63. ; of standard transforms, and a boolean value which is true if the package
  64. ; is to include definitions of all primitives.
  65. (define (package-source package)
  66. (let* ((config-file (package-file-name package))
  67. (dir (if config-file
  68. (file-name-directory config-file)
  69. #f)))
  70. (call-with-values
  71. (lambda ()
  72. (fold->3 (lambda (clause stuff transforms primitives?)
  73. (case (car clause)
  74. ((files)
  75. (values (read-files (cdr clause) stuff dir package)
  76. transforms
  77. primitives?))
  78. ((begin)
  79. (values (cons (cons config-file (cdr clause))
  80. stuff)
  81. transforms
  82. primitives?))
  83. ((integrate)
  84. (set-package-integrate?! package
  85. (or (null? (cdr clause))
  86. (cadr clause)))
  87. (values stuff transforms primitives?))
  88. ((optimize)
  89. (values stuff transforms primitives?))
  90. ((define-all-operators)
  91. (values stuff transforms #t))
  92. ((usual-transforms)
  93. (values stuff
  94. (append (reverse (cdr clause)) transforms)
  95. primitives?))
  96. ((reader)
  97. (let ((r (force (comp-env-macro-eval (package->environment package)))))
  98. (set-package-reader! package ((car r) (cadr clause) (cdr r))))
  99. (values stuff transforms primitives?))
  100. (else
  101. (assertion-violation 'package-source
  102. "unrecognized define-structure keyword"
  103. clause))))
  104. (package-clauses package)
  105. '() '() #f))
  106. (lambda (stuff transforms primitives?)
  107. (values (reverse stuff)
  108. (reverse transforms)
  109. primitives?)))))
  110. ; Also prints out the filenames (courtesy of READ-FORMS).
  111. (define (read-files all-files stuff dir package)
  112. (force-output (current-output-port)) ; just to be nice
  113. (fold (lambda (filespec stuff)
  114. (let ((file (namestring filespec
  115. dir
  116. *scheme-file-type*)))
  117. (display #\space (current-noise-port))
  118. (cons (cons file (read-forms file package #f))
  119. stuff)))
  120. all-files
  121. stuff))
  122. (define (package-optimizer-names package)
  123. (if (package-integrate? package)
  124. (let ((opts (apply append
  125. (map cdr (filter (lambda (clause)
  126. (eq? (car clause) 'optimize))
  127. (package-clauses package))))))
  128. (reduce (lambda (name opts)
  129. (if (memq name opts)
  130. opts
  131. (cons name opts)))
  132. opts
  133. '()))
  134. '()))
  135. (define (check-structure structure)
  136. (let ((undefined '()))
  137. (for-each-export
  138. (lambda (name want-type binding)
  139. (if (binding? binding)
  140. (let ((have-type (binding-type binding)))
  141. (if (not (compatible-types? have-type want-type))
  142. (warning 'check-structure
  143. "Type in interface doesn't match binding"
  144. name
  145. `(binding: ,(type->sexp have-type #t))
  146. `(interface: ,(type->sexp want-type #t))
  147. structure)))
  148. (set! undefined (cons name undefined))))
  149. structure)
  150. (if (not (null? undefined))
  151. (warning 'check-structure
  152. "Structure has undefined exports"
  153. structure
  154. undefined))))