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 / redpkg.scm < prev    next >
Text File  |  2000-01-18  |  19KB  |  563 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: redpkg.scm,v 1.12 2000/01/18 20:38:41 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 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 Reader
  23.  
  24. (declare (usual-integrations)
  25.      (integrate-external "object"))
  26.  
  27. (define (read-package-model filename)
  28.   (let ((model-pathname (merge-pathnames filename)))
  29.     (with-values
  30.     (lambda ()
  31.       (sort-descriptions (read-and-parse-model model-pathname)))
  32.       (lambda (packages extensions globals)
  33.     (descriptions->pmodel
  34.      packages
  35.      extensions
  36.      (map (lambda (pathname)
  37.         (cons
  38.          (->namestring pathname)
  39.          (let ((pathname
  40.             (pathname-new-type (merge-pathnames pathname
  41.                                 model-pathname)
  42.                        "glo")))
  43.            (if (file-exists? pathname)
  44.                (let ((contents (fasload pathname)))
  45.              (cond ((and (pair? contents)
  46.                      (pair? (car contents))
  47.                      (eq? 'VERSION (caar contents))
  48.                      (exact-nonnegative-integer?
  49.                       (cdar contents)))
  50.                 (if (not (= 2 (cdar contents)))
  51.                     (error "Unknown globals-file version:"
  52.                        (cdar contents)))
  53.                 (cdr contents))
  54.                    ((check-list contents symbol?)
  55.                 (list (vector '() '() contents)))
  56.                    ((check-list contents
  57.                   (lambda (element)
  58.                     (and (pair? element)
  59.                      (check-list (car element) symbol?)
  60.                      (check-list (cdr element) symbol?))))
  61.                 (map (lambda (element)
  62.                        (vector (car element)
  63.                            '()
  64.                            (cdr element)))
  65.                      contents))
  66.                    (else
  67.                 (warn "Malformed globals file:" pathname)
  68.                 '())))
  69.                (begin
  70.              (warn "Can't find globals file:" pathname)
  71.              '())))))
  72.           globals)
  73.      model-pathname)))))
  74.  
  75. (define (sort-descriptions descriptions)
  76.   (let ((packages '())
  77.     (extensions '())
  78.     (globals '()))
  79.     (let loop ((descriptions descriptions))
  80.       (for-each (lambda (description)
  81.           (case (car description)
  82.             ((DEFINE-PACKAGE)
  83.              (set! packages (cons (cdr description) packages)))
  84.             ((EXTEND-PACKAGE)
  85.              (set! extensions (cons (cdr description) extensions)))
  86.             ((GLOBAL-DEFINITIONS)
  87.              (set! globals
  88.                (append! globals (list-copy (cdr description)))))
  89.             ((NESTED-DESCRIPTIONS)
  90.              (loop (cdr description)))
  91.             (else
  92.              (error "Unknown description keyword:"
  93.                 (car description)))))
  94.         descriptions))
  95.     (values (reverse! packages)
  96.         (reverse! extensions)
  97.         globals)))
  98.  
  99. (define (read-file-analyses! pmodel)
  100.   (call-with-values (lambda () (cache-file-analyses! pmodel))
  101.     (lambda (analyses changes?)
  102.       (for-each (lambda (p&c)
  103.           (record-file-analysis! pmodel
  104.                      (car p&c)
  105.                      (analysis-cache/pathname (cdr p&c))
  106.                      (analysis-cache/data (cdr p&c))))
  107.         analyses)
  108.       changes?)))
  109.  
  110. (define-structure (analysis-cache
  111.            (type vector)
  112.            (constructor make-analysis-cache (pathname time data))
  113.            (conc-name analysis-cache/))
  114.   (pathname false read-only true)
  115.   (time false)
  116.   (data false))
  117.  
  118. (define (cache-file-analyses! pmodel)
  119.   (let ((pathname (pathname-new-type (pmodel/pathname pmodel) "fre"))
  120.     (changes? (list #f)))
  121.     (let ((result
  122.        (let ((caches (if (file-exists? pathname) (fasload pathname) '())))
  123.          (append-map! (lambda (package)
  124.                 (map (lambda (pathname)
  125.                    (cons package
  126.                      (cache-file-analysis! pmodel
  127.                                    caches
  128.                                    pathname
  129.                                    changes?)))
  130.                  (package/files package)))
  131.               (pmodel/packages pmodel)))))
  132.       (if (car changes?)
  133.       (fasdump (map cdr result) pathname))
  134.       (values result (car changes?)))))
  135.  
  136. (define (cache-file-analysis! pmodel caches pathname changes?)
  137.   (let ((cache (analysis-cache/lookup caches pathname))
  138.     (full-pathname
  139.      (merge-pathnames (pathname-new-type pathname "bin")
  140.               (pmodel/pathname pmodel))))
  141.     (let ((time (file-modification-time full-pathname)))
  142.       (if (not time)
  143.       (error "unable to open file" full-pathname))
  144.       (if cache
  145.       (begin
  146.         (if (> time (analysis-cache/time cache))
  147.         (begin
  148.           (set-analysis-cache/data! cache (analyze-file full-pathname))
  149.           (set-analysis-cache/time! cache time)
  150.           (set-car! changes? #t)))
  151.         cache)
  152.       (begin
  153.         (set-car! changes? #t)
  154.         (make-analysis-cache pathname
  155.                  time
  156.                  (analyze-file full-pathname)))))))
  157.  
  158. (define (analysis-cache/lookup caches pathname)
  159.   (let loop ((caches caches))
  160.     (and (not (null? caches))
  161.      (if (pathname=? pathname (analysis-cache/pathname (car caches)))
  162.          (car caches)
  163.          (loop (cdr caches))))))
  164.  
  165. (define (record-file-analysis! pmodel package pathname entries)
  166.   (for-each
  167.    (let ((filename (->namestring pathname))
  168.      (root-package (pmodel/root-package pmodel))
  169.      (primitive-package (pmodel/primitive-package pmodel)))
  170.      (lambda (entry)
  171.        (let ((name (vector-ref entry 0))
  172.          (expression
  173.           (make-expression package filename (vector-ref entry 1))))
  174.      (for-each-vector-element (vector-ref entry 2)
  175.        (lambda (name)
  176.          (cond ((symbol? name)
  177.             (make-reference package name expression))
  178.            ((primitive-procedure? name)
  179.             (make-reference primitive-package
  180.                     (primitive-procedure-name name)
  181.                     expression))
  182.            ((access? name)
  183.             (if (eq? (access-environment name)
  184.                  system-global-environment)
  185.             (make-reference root-package
  186.                     (access-name name)
  187.                     expression)
  188.             (warn "Non-root access" (unsyntax name))))
  189.            (else
  190.             (error "Illegal reference name" name)))))
  191.      (if name
  192.          (bind! package name expression)))))
  193.    entries))
  194.  
  195. (define (resolve-references! pmodel)
  196.   (for-each (lambda (package)
  197.           (for-each resolve-reference!
  198.             (package/sorted-references package)))
  199.         (pmodel/packages pmodel)))
  200.  
  201. (define (resolve-reference! reference)
  202.   (let ((binding
  203.      (package-lookup (reference/package reference)
  204.              (reference/name reference))))
  205.     (if binding
  206.     (begin
  207.       (set-reference/binding! reference binding)
  208.       (set-binding/references! binding
  209.                    (cons reference
  210.                      (binding/references binding)))))))
  211.  
  212. ;;;; Package Descriptions
  213.  
  214. (define (read-and-parse-model pathname)
  215.   (parse-package-expressions
  216.    (read-file (pathname-default-type pathname "pkg"))
  217.    pathname))
  218.  
  219. (define (parse-package-expressions expressions pathname)
  220.   (map (lambda (expression)
  221.      (parse-package-expression expression pathname))
  222.        expressions))
  223.  
  224. (define (parse-package-expression expression pathname)
  225.   (let ((lose
  226.      (lambda ()
  227.        (error "Ill-formed package expression:" expression))))
  228.     (if (not (and (pair? expression)
  229.           (symbol? (car expression))
  230.           (list? (cdr expression))))
  231.     (lose))
  232.     (case (car expression)
  233.       ((DEFINE-PACKAGE)
  234.        (cons 'DEFINE-PACKAGE
  235.          (parse-package-definition (parse-name (cadr expression))
  236.                        (cddr expression))))
  237.       ((EXTEND-PACKAGE)
  238.        (cons 'EXTEND-PACKAGE
  239.          (parse-package-extension (parse-name (cadr expression))
  240.                       (cddr expression))))
  241.       ((GLOBAL-DEFINITIONS)
  242.        (let ((filenames (cdr expression)))
  243.      (if (not (for-all? filenames string?))
  244.          (lose))
  245.      (cons 'GLOBAL-DEFINITIONS (map parse-filename filenames))))
  246.       ((OS-TYPE-CASE)
  247.        (if (not (and (list? (cdr expression))
  248.              (for-all? (cdr expression)
  249.                (lambda (clause)
  250.              (and (or (eq? 'ELSE (car clause))
  251.                   (and (list? (car clause))
  252.                        (for-all? (car clause) symbol?)))
  253.                   (list? (cdr clause)))))))
  254.        (lose))
  255.        (cons 'NESTED-DESCRIPTIONS
  256.          (let loop ((clauses (cdr expression)))
  257.            (cond ((null? clauses)
  258.               '())
  259.              ((or (eq? 'ELSE (caar clauses))
  260.               (memq microcode-id/operating-system (caar clauses)))
  261.               (parse-package-expressions (cdar clauses) pathname))
  262.              (else
  263.               (loop (cdr clauses)))))))
  264.       ((INCLUDE)
  265.        (cons 'NESTED-DESCRIPTIONS
  266.          (let ((filenames (cdr expression)))
  267.            (if (not (for-all? filenames string?))
  268.            (lose))
  269.            (append-map (lambda (filename)
  270.                  (read-and-parse-model
  271.                   (merge-pathnames filename pathname)))
  272.                filenames))))
  273.       (else
  274.        (lose)))))
  275.  
  276. (define (parse-package-definition name options)
  277.   (check-package-options options)
  278.   (call-with-values
  279.       (lambda ()
  280.     (let ((option (assq 'PARENT options)))
  281.       (if option
  282.           (let ((options (delq option options)))
  283.         (if (not (and (pair? (cdr option))
  284.                   (null? (cddr option))))
  285.             (error "Ill-formed PARENT option:" option))
  286.         (if (assq 'PARENT options)
  287.             (error "Multiple PARENT options."))
  288.         (values (parse-name (cadr option)) options))
  289.           (values 'NONE options))))
  290.     (lambda (parent options)
  291.       (let ((package (make-package-description name parent)))
  292.     (process-package-options package options)
  293.     package))))
  294.  
  295. (define (parse-package-extension name options)
  296.   (check-package-options options)
  297.   (let ((option (assq 'PARENT options)))
  298.     (if option
  299.     (error "PARENT option illegal in package extension:" option)))
  300.   (let ((package (make-package-description name 'NONE)))
  301.     (process-package-options package options)
  302.     package))
  303.  
  304. (define (check-package-options options)
  305.   (if (not (list? options))
  306.       (error "Package options must be a list:" options))
  307.   (for-each (lambda (option)
  308.           (if (not (and (pair? option)
  309.                 (symbol? (car option))
  310.                 (list? (cdr option))))
  311.           (error "Ill-formed package option:" option)))
  312.         options))
  313.  
  314. (define (process-package-options package options)
  315.   (for-each (lambda (option)
  316.           (case (car option)
  317.         ((FILES)
  318.          (set-package-description/file-cases!
  319.           package
  320.           (append (package-description/file-cases package)
  321.               (list (parse-filenames (cdr option))))))
  322.         ((FILE-CASE)
  323.          (set-package-description/file-cases!
  324.           package
  325.           (append (package-description/file-cases package)
  326.               (list (parse-file-case (cdr option))))))
  327.         ((EXPORT)
  328.          (set-package-description/exports!
  329.           package
  330.           (append (package-description/exports package)
  331.               (list (parse-export (cdr option))))))
  332.         ((IMPORT)
  333.          (set-package-description/imports!
  334.           package
  335.           (append (package-description/imports package)
  336.               (list (parse-import (cdr option))))))
  337.         ((INITIALIZATION)
  338.          (if (package-description/initialization package)
  339.              (error "Multiple INITIALIZATION options:" option))
  340.          (set-package-description/initialization!
  341.           package
  342.           (parse-initialization (cdr option))))
  343.         (else
  344.          (error "Unrecognized option keyword:" (car option)))))
  345.         options))
  346.  
  347. (define (parse-name name)
  348.   (if (not (check-list name symbol?))
  349.       (error "illegal name" name))
  350.   name)
  351.  
  352. (define (parse-filenames filenames)
  353.   (if (not (check-list filenames string?))
  354.       (error "illegal filenames" filenames))
  355.   (list #F (cons 'ELSE (map parse-filename filenames))))
  356.  
  357. (define (parse-file-case file-case)
  358.   (if (not (and (pair? file-case)
  359.         (symbol? (car file-case))
  360.         (check-list (cdr file-case)
  361.           (lambda (clause)
  362.             (and (pair? clause)
  363.              (or (eq? 'ELSE (car clause))
  364.                  (check-list (car clause) symbol?))
  365.              (check-list (cdr clause) string?))))))
  366.       (error "Illegal file-case" file-case))
  367.   (cons (car file-case)
  368.     (map (lambda (clause)
  369.            (cons (car clause)
  370.              (map parse-filename (cdr clause))))
  371.          (cdr file-case))))
  372.  
  373. (define-integrable (parse-filename filename)
  374.   (->pathname filename))
  375.  
  376. (define (parse-initialization initialization)
  377.   (if (not (and (pair? initialization) (null? (cdr initialization))))
  378.       (error "illegal initialization" initialization))
  379.   (car initialization))
  380.  
  381. (define (parse-import import)
  382.   (if (not (and (pair? import) (check-list (cdr import) symbol?)))
  383.       (error "illegal import" import))
  384.   (cons (parse-name (car import)) (cdr import)))
  385.  
  386. (define (parse-export export)
  387.   (if (not (and (pair? export) (check-list (cdr export) symbol?)))
  388.       (error "illegal export" export))
  389.   (cons (parse-name (car export)) (cdr export)))
  390.  
  391. (define (check-list items predicate)
  392.   (and (list? items)
  393.        (for-all? items predicate)))
  394.  
  395. ;;;; Packages
  396.  
  397. (define (descriptions->pmodel descriptions extensions globals pathname)
  398.   (let ((packages
  399.      (map (lambda (description)
  400.         (make-package (package-description/name description) 'UNKNOWN))
  401.           descriptions))
  402.     (extra-packages '()))
  403.     (let ((root-package
  404.        (or (name->package packages '())
  405.            (make-package '() #f))))
  406.       (let ((get-package
  407.          (lambda (name intern?)
  408.            (if (null? name)
  409.            root-package
  410.            (or (name->package packages name)
  411.                (name->package extra-packages name)
  412.                (if intern?
  413.                (let ((package (make-package name 'UNKNOWN)))
  414.                  (set! extra-packages
  415.                    (cons package extra-packages))
  416.                  package)
  417.                (error "Unknown package name:" name)))))))
  418.     ;; GLOBALS is a list of the bindings supplied externally.
  419.     (for-each
  420.      (lambda (global)
  421.        (for-each
  422.         (let ((namestring (->namestring (car global))))
  423.           (lambda (entry)
  424.         (for-each
  425.          (let ((package (get-package (vector-ref entry 0) #t)))
  426.            (let loop
  427.                ((package package)
  428.             (ancestors (vector-ref entry 1)))
  429.              (if (eq? 'UNKNOWN (package/parent package))
  430.              (if (pair? ancestors)
  431.                  (let ((parent (get-package (car ancestors) #t)))
  432.                    (set-package/parent! package parent)
  433.                    (loop parent (cdr ancestors)))
  434.                  (set-package/parent! package #f))))
  435.            (lambda (name)
  436.              (bind! package
  437.                 name
  438.                 (make-expression package namestring #f))))
  439.          (vector-ref entry 2))))
  440.         (cdr global)))
  441.      globals)
  442.     (for-each
  443.      (lambda (package description)
  444.        (let ((parent
  445.           (let ((parent-name (package-description/parent description)))
  446.             (and (not (eq? parent-name 'NONE))
  447.              (get-package parent-name #t)))))
  448.          (set-package/parent! package parent)
  449.          (if parent
  450.          (set-package/children!
  451.           parent
  452.           (cons package (package/children parent)))))
  453.        (process-package-description package description get-package))
  454.      packages
  455.      descriptions)
  456.     (for-each
  457.      (lambda (extension)
  458.        (process-package-description
  459.         (get-package (package-description/name extension) #f)
  460.         extension
  461.         get-package))
  462.      extensions))
  463.       (make-pmodel root-package
  464.            (make-package primitive-package-name #f)
  465.            packages
  466.            extra-packages
  467.            pathname))))
  468.  
  469. (define (package-lookup package name)
  470.   (let package-loop ((package package))
  471.     (or (package/find-binding package name)
  472.     (and (package/parent package)
  473.          (package-loop (package/parent package))))))
  474.  
  475. (define (name->package packages name)
  476.   (list-search-positive packages
  477.     (lambda (package)
  478.       (symbol-list=? name (package/name package)))))
  479.  
  480. (define (process-package-description package description get-package)
  481.   (let ((file-cases (package-description/file-cases description)))
  482.     (set-package/file-cases! package
  483.                  (append! (package/file-cases package)
  484.                       (list-copy file-cases)))
  485.     (set-package/files!
  486.      package
  487.      (append! (package/files package)
  488.           (append-map! (lambda (file-case)
  489.                  (append-map cdr (cdr file-case)))
  490.                file-cases))))
  491.   (let ((initialization (package-description/initialization description)))
  492.     (if (and initialization
  493.          (package/initialization package))
  494.     (error "Multiple package initializations:" initialization))
  495.     (set-package/initialization! package initialization))
  496.   (for-each (lambda (export)
  497.           (let ((destination (get-package (car export) #t)))
  498.         (for-each (lambda (name)
  499.                 (link! package name destination name))
  500.               (cdr export))))
  501.         (package-description/exports description))
  502.   (for-each (lambda (import)
  503.           (let ((source (get-package (car import) #t)))
  504.         (for-each (lambda (name)
  505.                 (link! source name package name))
  506.               (cdr import))))
  507.         (package-description/imports description)))
  508.  
  509. (define primitive-package-name
  510.   (list (string->symbol "#[(cross-reference reader)primitives]")))
  511.  
  512. ;;;; Binding and Reference
  513.  
  514. (define (bind! package name expression)
  515.   (let ((value-cell (binding/value-cell (intern-binding! package name))))
  516.     (set-expression/value-cell! expression value-cell)
  517.     (set-value-cell/expressions!
  518.      value-cell
  519.      (cons expression (value-cell/expressions value-cell)))))
  520.  
  521. (define (link! source-package source-name destination-package destination-name)
  522.   (if (package/find-binding destination-package destination-name)
  523.       (error "Attempt to reinsert binding" destination-name))
  524.   (let ((source-binding (intern-binding! source-package source-name)))
  525.     (let ((destination-binding
  526.        (make-binding destination-package
  527.              destination-name
  528.              (binding/value-cell source-binding))))
  529.       (rb-tree/insert! (package/bindings destination-package)
  530.                destination-name
  531.                destination-binding)
  532.       (make-link source-binding destination-binding))))
  533.  
  534. (define (intern-binding! package name)
  535.   (or (package/find-binding package name)
  536.       (let ((binding
  537.          (let ((value-cell (make-value-cell)))
  538.            (let ((binding (make-binding package name value-cell)))
  539.          (set-value-cell/source-binding! value-cell binding)
  540.          binding))))
  541.     (rb-tree/insert! (package/bindings package) name binding)
  542.     binding)))
  543.  
  544. (define (make-reference package name expression)
  545.   (let ((references (package/references package))
  546.     (add-reference!
  547.      (lambda (reference)
  548.        (set-reference/expressions!
  549.         reference
  550.         (cons expression (reference/expressions reference)))
  551.        (set-expression/references!
  552.         expression
  553.         (cons reference (expression/references expression))))))
  554.     (let ((reference (rb-tree/lookup references name #f)))
  555.       (if reference
  556.       (begin
  557.         (if (not (memq expression (reference/expressions reference)))
  558.         (add-reference! reference))
  559.         reference)
  560.       (let ((reference (%make-reference package name)))
  561.         (rb-tree/insert! references name reference)
  562.         (add-reference! reference)
  563.         reference)))))