home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / cref / forpkg.scm < prev    next >
Text File  |  1999-01-02  |  13KB  |  381 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: forpkg.scm,v 1.9 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Package Model Formatter
  23.  
  24. (declare (usual-integrations)
  25.      (integrate-external "object"))
  26.  
  27. (define (format-packages pmodel)
  28.   (let ((output? (format-packages-unusual pmodel))
  29.     (port (current-output-port))
  30.     (indentation "  ")
  31.     (width 79)
  32.     (packages (pmodel/packages pmodel)))
  33.     (if (not (null? packages))
  34.     (begin
  35.       (if output?
  36.           (output-port/write-string port "\f\n"))
  37.       (format-package port indentation width (car packages))
  38.       (for-each (lambda (package)
  39.               (output-port/write-string port "\f\n")
  40.               (format-package port indentation width package))
  41.             (cdr packages))))))
  42.  
  43. (define (format-packages-unusual pmodel)
  44.   (let ((port (current-output-port))
  45.     (indentation "  ")
  46.     (width 79)
  47.     (packages (pmodel/packages pmodel))
  48.     (output? false))
  49.     (let ((free-references
  50.        (append-map! (lambda (package)
  51.               (list-transform-negative
  52.                   (package/sorted-references package)
  53.                 reference/binding))
  54.             packages)))
  55.       (if (not (null? free-references))
  56.       (begin
  57.         (format-references port indentation width "Free References" false
  58.           (sort free-references reference<?))
  59.         (set! output? true))))
  60.     (with-values (lambda () (get-value-cells/unusual packages))
  61.       (lambda (undefined multiple)
  62.     (if (not (null? undefined))
  63.         (begin
  64.           (if output?
  65.           (output-port/write-string port "\f\n"))
  66.           (format-value-cells port indentation width "Undefined Bindings"
  67.                   undefined)
  68.         (set! output? true)))
  69.     (if (not (null? multiple))
  70.         (begin
  71.           (if output?
  72.           (output-port/write-string port "\f\n"))
  73.           (format-value-cells port indentation width
  74.                   "Bindings with Multiple Definitions"
  75.                   multiple)
  76.           (set! output? true)))))
  77.     output?))
  78.  
  79. (define (format-package port indentation width package)
  80.   (write-package-name "Package" package port)
  81.   (if (package/parent package)
  82.       (write-package-name "Parent" (package/parent package) port))
  83.   (format-package/files port indentation width package)
  84.   (let ((classes
  85.      (classify-bindings-by-package
  86.       (lambda (binding)
  87.         (binding/package (binding/source-binding binding)))
  88.       (package/sorted-bindings package))))
  89.     (let ((class (assq package classes)))
  90.       (if class
  91.       (format-package/bindings port indentation width package (cdr class)))
  92.       (for-each (lambda (class)
  93.           (if (not (eq? package (car class)))
  94.               (format-package/imports port indentation width package
  95.                           (car class)
  96.                           (cdr class))))
  97.         classes)
  98.       (if class
  99.       (for-each
  100.        (lambda (class)
  101.          (if (not (eq? package (car class)))
  102.          (format-package/exports port indentation width (car class)
  103.                      (sort (cdr class) binding<?))))
  104.        (classify-bindings-by-package
  105.         binding/package
  106.         (append-map (lambda (binding)
  107.               (value-cell/bindings (binding/value-cell binding)))
  108.             (cdr class))))))))
  109.  
  110. (define (format-value-cells port indentation width label value-cells)
  111.   (write-label label port)
  112.   (for-each (lambda (binding)
  113.           (format-expressions
  114.            port indentation width false
  115.            (string-append
  116.         (binding/name-string binding)
  117.         " "
  118.         (package/name-string (binding/package binding)))
  119.            (binding/expressions binding)))
  120.         (sort (map value-cell/source-binding value-cells)
  121.           binding<?)))
  122.  
  123. (define (get-value-cells/unusual packages)
  124.   (with-values (lambda () (get-value-cells packages))
  125.     (lambda (unlinked linked)
  126.       (values
  127.        (list-transform-positive linked
  128.      (lambda (value-cell)
  129.        (null? (value-cell/expressions value-cell))))
  130.        (list-transform-positive (append unlinked linked)
  131.      (lambda (value-cell)
  132.        (let ((expressions (value-cell/expressions value-cell)))
  133.          (and (not (null? expressions))
  134.           (not (null? (cdr expressions)))))))))))
  135.  
  136. (define (get-value-cells packages)
  137.   (let ((unlinked '())
  138.     (linked '()))
  139.     (for-each
  140.      (lambda (package)
  141.        (for-each (lambda (binding)
  142.            (let ((value-cell (binding/value-cell binding)))
  143.              (cond ((null? (cdr (value-cell/bindings value-cell)))
  144.                 (set! unlinked (cons value-cell unlinked)))
  145.                ((not (memq value-cell linked))
  146.                 (set! linked (cons value-cell linked))))))
  147.          (package/sorted-bindings package)))
  148.      packages)
  149.     (values unlinked linked)))
  150.  
  151. (define (write-package-name label package port)
  152.   (output-port/write-string port label)
  153.   (output-port/write-string port ": ")
  154.   (output-port/write-string port (package/name-string package))
  155.   (output-port/write-char port #\newline))
  156.  
  157. (define (format-package/files port indentation width package)
  158.   width
  159.   (if (positive? (package/n-files package))
  160.       (begin
  161.     (output-port/write-char port #\newline)
  162.     (write-label "Files" port)
  163.     (for-each (lambda (pathname)
  164.             (output-port/write-string port indentation)
  165.             (output-port/write-char port #\")
  166.             (output-port/write-string port (->namestring pathname))
  167.             (output-port/write-char port #\")
  168.             (output-port/write-char port #\newline))
  169.           (package/files package)))))
  170.  
  171. (define (format-package/bindings port indentation width package bindings)
  172.   (format-bindings
  173.    port indentation width package bindings
  174.    "Bindings"
  175.    (lambda (binding)
  176.      (let* ((name (binding/name-string binding))
  177.         (expressions (binding/expressions binding)))
  178.        (if (or (< (package/n-files package) 2)
  179.            (null? expressions))
  180.        name
  181.        (apply string-append
  182.           name
  183.           " "
  184.           (let loop ((expressions expressions)
  185.                  (p "("))
  186.             (cons p
  187.               (cons (expression/file (car expressions))
  188.                 (if (null? (cdr expressions))
  189.                     (list ")")
  190.                     (loop (cdr expressions) " ")))))))))))
  191.  
  192. (define (format-package/imports port indentation width local-package
  193.                 remote-package bindings)
  194.   (format-exports port indentation width local-package remote-package bindings
  195.           local-map/import "Imports from"))
  196.  
  197. (define (format-package/exports port indentation width remote-package bindings)
  198.   (format-exports port indentation width remote-package remote-package bindings
  199.           local-map/export "Exports to"))
  200.  
  201. (define (format-exports port indentation width local-package remote-package
  202.             bindings local-map label)
  203.   (format-bindings
  204.    port indentation width local-package bindings
  205.    (string-append label " package " (package/name-string remote-package))
  206.    (lambda (destination-binding)
  207.      (with-values
  208.      (lambda ()
  209.        (local-map (binding/source-binding destination-binding)
  210.               destination-binding))
  211.        (lambda (local-binding remote-binding)
  212.      (let ((local-name (binding/name local-binding))
  213.            (remote-name (binding/name remote-binding)))
  214.        (let ((name-string (binding-name->string local-name)))
  215.          (if (eq? local-name remote-name)
  216.          name-string
  217.          (string-append name-string
  218.                 " ["
  219.                 (binding-name->string remote-name)
  220.                 "]")))))))))
  221.  
  222. (define (local-map/export source destination)
  223.   (values source destination))
  224.  
  225. (define (local-map/import source destination)
  226.   (values destination source))
  227.  
  228. (define (format-bindings port indentation width package
  229.              bindings label binding->name)
  230.   (output-port/write-char port #\newline)
  231.   (write-label label port)
  232.   (for-each (lambda (binding)
  233.           (format-expressions
  234.            port indentation width package
  235.            (binding->name binding)
  236.            (append-map reference/expressions
  237.                (binding/references binding))))
  238.         bindings))
  239.  
  240. (define (classify-bindings-by-package binding->package bindings)
  241.   (let ((classes '()))
  242.     (for-each
  243.      (lambda (binding)
  244.        (let ((package (binding->package binding)))
  245.      (let ((entry (assq package classes)))
  246.        (if entry
  247.            (set-cdr! entry (cons binding (cdr entry)))
  248.            (set! classes (cons (list package binding) classes))))))
  249.      bindings)
  250.     (for-each (lambda (class)
  251.         (set-cdr! class (reverse! (cdr class))))
  252.           classes)
  253.     (sort classes
  254.       (lambda (x y)
  255.         (package<? (car x) (car y))))))
  256.  
  257. (define (format-references port indentation width label package references)
  258.   (write-label label port)
  259.   (for-each
  260.    (lambda (reference)
  261.      (format-expressions port indentation width package
  262.              (binding-name->string (reference/name reference))
  263.              (reference/expressions reference)))
  264.    references))
  265.  
  266. (define (format-expressions port indentation width package name expressions)
  267.   (with-values
  268.       (lambda ()
  269.     (classify-expression-names
  270.      (map (lambda (expression)
  271.         (expression->name expression package))
  272.           expressions)))
  273.     (lambda (symbols pairs)
  274.       (output-port/write-string port indentation)
  275.       (output-port/write-string port name)
  276.       (output-port/write-char port #\newline)
  277.       (let ((indentation (new-indentation indentation)))
  278.     (write-strings/compact port indentation width
  279.                    (map symbol-name (sort symbols symbol<?)))
  280.     (write-items/miser port indentation width
  281.       (lambda (item port)
  282.         (output-port/write-char port #\()
  283.         (output-port/write-char port #\")
  284.         (output-port/write-string port (car item))
  285.         (output-port/write-char port #\")
  286.         (if (not (null? (cdr item)))
  287.         (begin
  288.           (output-port/write-char port #\space)
  289.           (output-port/write-string port (symbol-name (cadr item)))))
  290.         (output-port/write-char port #\)))
  291.       (sort pairs
  292.         (lambda (x y)
  293.           (or (string<? (car x) (car y))
  294.           (and (string=? (car x) (car y))
  295.                (or (null? (cdr x))
  296.                (and (not (null? (cdr y)))
  297.                 (symbol<? (cadr x) (cadr y)))))))))))))
  298.  
  299. (define (classify-expression-names names)
  300.   (if (null? names)
  301.       (values '() '())
  302.       (with-values (lambda () (classify-expression-names (cdr names)))
  303.     (lambda (symbols pairs)
  304.       (if (pair? (car names))
  305.           (values symbols (cons (car names) pairs))
  306.           (values (cons (car names) symbols) pairs))))))
  307.  
  308. (define (expression->name expression package)
  309.   (let ((package* (expression/package expression))
  310.     (value-cell (expression/value-cell expression)))
  311.     (let ((binding
  312.        (and value-cell
  313.         (list-search-positive (value-cell/bindings value-cell)
  314.           (lambda (binding)
  315.             (eq? package* (binding/package binding)))))))
  316.       (if binding
  317.       (let ((name (binding/name binding)))
  318.         (if (and package
  319.              (let ((binding* (package/find-binding package name)))
  320.                (and binding*
  321.                 (eq? (binding/value-cell binding)
  322.                  (binding/value-cell binding*)))))
  323.         name
  324.         (list (expression/file expression) name)))
  325.       (list (expression/file expression))))))
  326.  
  327. (define (write-label label port)
  328.   (output-port/write-string port label)
  329.   (output-port/write-string port ":")
  330.   (output-port/write-char port #\newline))
  331.  
  332. (define (write-strings/compact port indentation width strings)
  333.   (if (not (null? strings))
  334.       (begin
  335.     (let loop ((strings strings) (offset 0) (prefix indentation))
  336.       (if (not (null? strings))
  337.           (let ((length (string-length (car strings))))
  338.         (let ((new-offset (+ offset (string-length prefix) length)))
  339.           (if (and (> new-offset width)
  340.                (not (zero? offset)))
  341.               (begin
  342.             (output-port/write-char port #\newline)
  343.             (loop strings 0 indentation))
  344.               (begin
  345.             (output-port/write-string port prefix)
  346.             (output-port/write-string port (car strings))
  347.             (loop (cdr strings) new-offset " ")))))))
  348.     (output-port/write-char port #\newline))))
  349.  
  350. (define (write-items/miser port indentation width write-item items)
  351.   width
  352.   (for-each (lambda (item)
  353.           (output-port/write-string port indentation)
  354.           (write-item item port)
  355.           (output-port/write-char port #\newline))
  356.         items))
  357.  
  358. (define (new-indentation indentation)
  359.   (string-append indentation "    "))
  360.  
  361. (define-integrable (binding/name-string binding)
  362.   (binding-name->string (binding/name binding)))
  363.  
  364. (define (binding-name->string name)
  365.   (if (symbol? name)
  366.       (symbol-name name)
  367.       (write-to-string name)))
  368.  
  369. (define-integrable (package/name-string package)
  370.   (package-name->string (package/name package)))
  371.  
  372. (define (package-name->string name)
  373.   (if (null? name)
  374.       "()"
  375.       (apply string-append
  376.          (let loop ((name name) (p "("))
  377.            (cons p
  378.              (cons (binding-name->string (car name))
  379.                (if (null? (cdr name))
  380.                    (list ")")
  381.                    (loop (cdr name) " "))))))))