--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/anfile.scm,v 1.1 1988/06/13 12:38:14 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Free/Bound Variable Analysis
+
+(declare (usual-integrations))
+\f
+(define (analyze/directory filename)
+ (for-each
+ (lambda (input-pathname)
+ (let ((output-pathname (pathname-new-type input-pathname "free")))
+ (if (not (compare-file-modification-times input-pathname
+ output-pathname))
+ (analyze/file input-pathname output-pathname))))
+ (directory-read
+ (merge-pathnames (pathname-as-directory (->pathname filename))
+ (string->pathname "*.bin")))))
+
+(define (read-analyzed-file input-pathname)
+ (let ((output-pathname (pathname-new-type input-pathname "free")))
+ (if (compare-file-modification-times input-pathname output-pathname)
+ (fasload output-pathname)
+ (analyze/file input-pathname output-pathname))))
+
+(define (analyze/file input-pathname output-pathname)
+ (fasdump (analyze/top-level (fasload input-pathname)) output-pathname))
+(define (compare-file-modification-times x y)
+ (let ((x (file-modification-time x)))
+ (and x
+ (let ((y (file-modification-time y)))
+ (and y
+ (< x y))))))
+\f
+(define (analyze/top-level expression)
+ (with-values (lambda () (sort-expressions (process-top-level expression)))
+ (lambda (definitions others)
+ (let ((definition-analysis
+ (map analyze/top-level/definition definitions)))
+ (if (not (null? others))
+ (cons (with-values (lambda ()
+ (analyze/expression (make-sequence others)))
+ (lambda (references assignments executions)
+ (vector false references assignments executions
+ 'EXPRESSION)))
+ definition-analysis)
+ definition-analysis)))))
+
+(define (sort-expressions expressions)
+ (if (null? expressions)
+ (values '() '())
+ (let ((rest (lambda () (sort-expressions (cdr expressions)))))
+ (if (block-declaration? (car expressions))
+ (rest)
+ (with-values rest
+ (lambda (definitions others)
+ (if (definition? (car expressions))
+ (values (cons (car expressions) definitions) others)
+ (values definitions (cons (car expressions) others)))))))))
+
+(define (process-top-level expression)
+ (cond ((comment? expression)
+ (process-top-level (comment-expression expression)))
+ ((sequence? expression)
+ (mapcan process-top-level (sequence-actions expression)))
+ (else
+ (list expression))))
+
+(define (analyze/top-level/definition definition)
+ (let ((name (definition-name definition))
+ (expression (definition-value definition)))
+ (cond ((unassigned-reference-trap? expression)
+ (vector name '() '() '() 'UNASSIGNED))
+ ((scode-constant? expression)
+ (vector name '() '() '() 'CONSTANT))
+ (else
+ (with-values (lambda () (analyze/expression expression))
+ (lambda (references assignments executions)
+ (vector name references assignments executions
+ (cond ((lambda? expression) 'LAMBDA)
+ ((delay? expression) 'DELAY)
+ (else 'EXPRESSION)))))))))
+\f
+(define (analyze/expression expression)
+ ((scode-walk analyze/dispatch expression) expression))
+
+(define (analyze/expressions expressions)
+ (if (null? expressions)
+ (values '() '() '())
+ (result-sum (lambda () (analyze/expression (car expressions)))
+ (lambda () (analyze/expressions (cdr expressions))))))
+
+(define (analyze/uninteresting expression)
+ (values (if (primitive-procedure? expression) (list expression) '())
+ '() '()))
+
+(define (analyze/error expression)
+ (error "Illegal expression" expression))
+
+(define (analyze/access expression)
+ (if (access-environment expression)
+ (warn "Access to non-global environment:" (unsyntax expression)))
+ (values (list expression) '() '()))
+
+(define (analyze/variable expression)
+ (values (list (variable-name expression)) '() '()))
+
+(define (analyze/assignment expression)
+ (with-values (lambda () (analyze/expression (assignment-value expression)))
+ (lambda (references assignments executions)
+ (values references
+ (cons (assignment-name expression) assignments)
+ executions))))
+
+(define (analyze/combination expression)
+ (result-sum (lambda ()
+ (let ((operator (combination-operator expression)))
+ (cond ((variable? operator)
+ (values '() '() (list (variable-name operator))))
+ ((or (primitive-procedure? operator)
+ (and (access? operator)
+ (not (access-environment operator))))
+ (values '() '() (list operator)))
+ (else
+ (analyze/expression operator)))))
+ (lambda ()
+ (analyze/expressions (combination-operands expression)))))
+
+(define (analyze/lambda expression)
+ (lambda-components expression
+ (lambda (name required optional rest auxiliary declarations body)
+ name declarations
+ (with-values (lambda () (analyze/expression body))
+ (lambda (references assignments executions)
+ (let ((bound
+ (append required
+ optional
+ (if rest (list rest) '())
+ auxiliary)))
+ (values (multiset-difference references bound)
+ (multiset-difference assignments bound)
+ (multiset-difference executions bound))))))))
+\f
+(define (analyze/error-combination expression)
+ (combination-components expression
+ (lambda (operator operands)
+ (analyze/expressions (list operator (car operands) (cadr operands))))))
+
+(define (analyze/delay expression)
+ (analyze/expression (delay-expression expression)))
+
+(define (analyze/sequence expression)
+ (analyze/expressions (sequence-actions expression)))
+
+(define (analyze/conditional expression)
+ (analyze/expressions (conditional-components expression list)))
+
+(define (analyze/disjunction expression)
+ (analyze/expressions (disjunction-components expression list)))
+
+(define (analyze/comment expression)
+ (analyze/expression (comment-expression expression)))
+
+(define analyze/dispatch
+ (make-scode-walker
+ analyze/uninteresting
+ `((ACCESS ,analyze/access)
+ (ASSIGNMENT ,analyze/assignment)
+ (COMBINATION ,analyze/combination)
+ (COMMENT ,analyze/comment)
+ (CONDITIONAL ,analyze/conditional)
+ (DEFINITION ,analyze/error)
+ (DELAY ,analyze/delay)
+ (DISJUNCTION ,analyze/disjunction)
+ (ERROR-COMBINATION ,analyze/error-combination)
+ (IN-PACKAGE ,analyze/error)
+ (LAMBDA ,analyze/lambda)
+ (SEQUENCE ,analyze/sequence)
+ (VARIABLE ,analyze/variable))))
+
+(define (result-sum first rest)
+ (with-values first
+ (lambda (references assignments executions)
+ (with-values rest
+ (lambda (references* assignments* executions*)
+ (values (append! references references*)
+ (append! assignments assignments*)
+ (append! executions executions*)))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/conpkg.scm,v 1.1 1988/06/13 12:38:19 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Generate construction program from package model
+
+(declare (usual-integrations)
+ (integrate-external "object"))
+\f
+;;; Construct expressions to construct the package structure.
+
+(define (construct-constructor pmodel)
+ (let ((packages (pmodel/packages pmodel)))
+ `((DECLARE (USUAL-INTEGRATIONS))
+ ,@(mapcan*
+ `((LET ()
+ (DECLARE (INTEGRATE-PRIMITIVE-PROCEDURES ENVIRONMENT-LINK-NAME))
+ ,@(mapcan* (mapcan construct-links (pmodel/extra-packages pmodel))
+ construct-links packages)))
+ construct-definitions
+ (sort packages package-structure<?)))))
+
+(define (construct-definitions package)
+ (cond ((package/root? package)
+ `((IN-PACKAGE #F
+ ,@(map (lambda (binding) `(DEFINE ,(binding/name binding)))
+ (package/source-bindings package)))))
+ ((equal? (package/name package) '(PACKAGE))
+ ;; This environment is hand built by the cold-load.
+ '())
+ (else
+ (package-definition
+ (package/name package)
+ `(IN-PACKAGE ,(package-reference (package/parent package))
+ (LET (,@(map (lambda (binding) `(,(binding/name binding)))
+ (package/source-bindings package)))
+ (THE-ENVIRONMENT)))))))
+
+(define (construct-links package)
+ (if (equal? (package/name package) '(PACKAGE))
+ '()
+ (mapcan (lambda (binding)
+ (map (lambda (link)
+ (let ((source (link/source link))
+ (destination (link/destination link)))
+ `(ENVIRONMENT-LINK-NAME
+ ,(package-reference (binding/package destination))
+ ,(package-reference (binding/package source))
+ ',(binding/name source))))
+ (binding/links binding)))
+ (btree-fringe (package/bindings package)))))
+
+(define (package/source-bindings package)
+ (list-transform-positive (btree-fringe (package/bindings package))
+ (lambda (binding)
+ (eq? (binding/source-binding binding) binding))))
+
+(define (package-structure<? x y)
+ (cond ((package/topological<? x y) true)
+ ((package/topological<? y x) false)
+ (else (package<? x y))))
+
+(define (package/topological<? x y)
+ (and (not (eq? x y))
+ (let loop ((y (package/parent y)))
+ (and y
+ (if (eq? x y)
+ true
+ (loop (package/parent y)))))))
+\f
+;;; Construct a procedure which will load the files into the package
+;;; structure.
+
+(define (construct-loader pmodel)
+ `((DECLARE (USUAL-INTEGRATIONS))
+ (LAMBDA (LOAD KEY-ALIST)
+ (LET ((LOOKUP-KEY
+ (LAMBDA (KEY)
+ (LET LOOP ((ALIST KEY-ALIST))
+ (IF (NULL? ALIST)
+ (ERROR "Missing key" KEY))
+ (IF (EQ? KEY (CAR (CAR ALIST)))
+ (CDR (CAR ALIST))
+ (LOOP (CDR ALIST)))))))
+ LOOKUP-KEY ;ignore if not referenced
+ ,@(mapcan (lambda (package)
+ (let ((reference (package-reference package)))
+ (if (> (package/n-files package) 1)
+ `((LET ((ENVIRONMENT ,reference))
+ ,@(load-package package 'ENVIRONMENT)))
+ (load-package package reference))))
+ (pmodel/packages pmodel))))))
+
+(define (load-package package environment)
+ (mapcan (lambda (file-case)
+ (let ((type (file-case/type file-case)))
+ (if type
+ `((CASE (LOOKUP-KEY ',type)
+ ,@(map (lambda (clause)
+ `(,(file-case-clause/keys clause)
+ ,@(clause-loader clause environment)))
+ (file-case/clauses file-case))))
+ (clause-loader (car (file-case/clauses file-case))
+ environment))))
+ (package/file-cases package)))
+
+(define (clause-loader clause environment)
+ (let ((files (file-case-clause/files clause)))
+ (if (null? files)
+ `(FALSE)
+ (map (lambda (file)
+ `(LOAD ,(pathname->string file) ,environment))
+ files))))
+
+(define (package-definition name value)
+ (let ((path (reverse name)))
+ `((PACKAGE/ADD-CHILD! (FIND-PACKAGE ',(reverse (cdr path)))
+ ',(car path)
+ ,value))))
+
+(define (package-reference package)
+ `(PACKAGE/ENVIRONMENT (FIND-PACKAGE ',(package/name package))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.pkg,v 1.1 1988/06/13 12:38:35 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; CREF Packaging
+\f
+(global-definitions "../runtime/runtim")
+
+(define-package (cross-reference)
+ (files "mset"
+ "btree"
+ "object"
+ "toplev")
+ (parent ())
+ (export ()
+ cref/generate-all
+ cref/generate-constructors
+ cref/generate-cref
+ cref/generate-trivial-constructor))
+
+(define-package (cross-reference analyze-file)
+ (files "anfile")
+ (parent (cross-reference))
+ (export (cross-reference)
+ analyze/directory
+ read-analyzed-file))
+
+(define-package (cross-reference constructor)
+ (files "conpkg")
+ (parent (cross-reference))
+ (export (cross-reference)
+ construct-constructor
+ construct-loader))
+
+(define-package (cross-reference formatter)
+ (files "forpkg")
+ (parent (cross-reference))
+ (export (cross-reference)
+ format-packages))
+
+(define-package (cross-reference reader)
+ (files "redpkg")
+ (parent (cross-reference))
+ (export (cross-reference)
+ read-file-analyses!
+ read-package-model
+ resolve-references!))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.sf,v 1.1 1988/06/13 12:38:37 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+(sf/set-default-syntax-table! system-global-syntax-table)
+(sf-conditionally "object")
+(sf-directory ".")
+(cref/generate-all "cref")(sf "cref.con" "cref.bcon")
+(sf "cref.ldr" "cref.bldr")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/forpkg.scm,v 1.1 1988/06/13 12:38:22 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Package Model Formatter
+
+(declare (usual-integrations)
+ (integrate-external "object"))
+\f
+(define (format-packages pmodel)
+ (let ((indentation " ")
+ (width 79)
+ (root-package (pmodel/root-package pmodel)) (packages (pmodel/packages pmodel)))
+ (let ((free-references
+ (mapcan (lambda (package)
+ (list-transform-negative
+ (btree-fringe (package/references package))
+ reference/binding))
+ packages)))
+ (if (not (null? free-references))
+ (begin
+ (format-references indentation width "Free References" false
+ (sort free-references reference<?))
+ (write-string "\f\n"))))
+ (with-values (lambda () (get-value-cells/unusual packages))
+ (lambda (undefined multiple)
+ (if (not (null? undefined))
+ (begin
+ (format-value-cells indentation width "Undefined Bindings"
+ undefined)
+ (write-string "\f\n")))
+ (if (not (null? multiple))
+ (begin
+ (format-value-cells indentation width
+ "Bindings with Multiple Definitions"
+ multiple)
+ (write-string "\f\n")))))
+ (if (not (memq root-package packages))
+ (begin
+ (write-label "Global References")
+ (for-each
+ (lambda (binding)
+ (let ((references (binding/references binding)))
+ (if (not (null? references))
+ (format-expressions
+ indentation width root-package
+ (write-to-string (binding/name binding))
+ (mapcan (lambda (reference)
+ (list-copy (reference/expressions reference)))
+ references)))))
+ (btree-fringe (package/bindings root-package)))
+ (write-string "\f\n")))
+ (format-references
+ indentation width "Primitives" root-package
+ (btree-fringe (package/references (pmodel/primitive-package pmodel))))
+ (for-each (lambda (package)
+ (write-string "\f\n")
+ (format-package indentation width package))
+ packages)))
+\f
+(define (format-package indentation width package)
+ (write-package-name "Package" package)
+ (if (package/parent package)
+ (write-package-name "Parent" (package/parent package)))
+ (format-package/files indentation width package)
+ (let ((classes
+ (classify-bindings-by-package
+ (lambda (binding)
+ (binding/package (binding/source-binding binding)))
+ (btree-fringe (package/bindings package)))))
+ (let ((class (assq package classes)))
+ (if class
+ (format-package/bindings indentation width package (cdr class)))
+ (for-each (lambda (class)
+ (if (not (eq? package (car class)))
+ (format-package/imports indentation width package
+ (car class)
+ (cdr class))))
+ classes)
+ (if class
+ (for-each
+ (lambda (class)
+ (if (not (eq? package (car class)))
+ (format-package/exports indentation width (car class)
+ (sort (cdr class) binding<?))))
+ (classify-bindings-by-package
+ binding/package
+ (mapcan (lambda (binding)
+ (list-copy
+ (value-cell/bindings (binding/value-cell binding))))
+ (cdr class))))))))
+
+(define (format-value-cells indentation width label value-cells)
+ (write-label label)
+ (for-each (lambda (binding)
+ (format-expressions
+ indentation width false
+ (string-append
+ (write-to-string (binding/name binding))
+ " "
+ (write-to-string (package/name (binding/package binding))))
+ (binding/expressions binding)))
+ (sort (map value-cell/source-binding value-cells)
+ binding<?)))
+
+(define (get-value-cells/unusual packages)
+ (with-values (lambda () (get-value-cells packages))
+ (lambda (unlinked linked)
+ (values
+ (list-transform-positive linked
+ (lambda (value-cell)
+ (null? (value-cell/expressions value-cell))))
+ (list-transform-positive (append unlinked linked)
+ (lambda (value-cell)
+ (let ((expressions (value-cell/expressions value-cell)))
+ (and (not (null? expressions))
+ (not (null? (cdr expressions)))))))))))
+
+(define (get-value-cells packages)
+ (let ((unlinked '())
+ (linked '()))
+ (for-each
+ (lambda (package)
+ (for-each (lambda (binding)
+ (let ((value-cell (binding/value-cell binding)))
+ (cond ((null? (cdr (value-cell/bindings value-cell)))
+ (set! unlinked (cons value-cell unlinked)))
+ ((not (memq value-cell linked))
+ (set! linked (cons value-cell linked))))))
+ (btree-fringe (package/bindings package))))
+ packages)
+ (values unlinked linked)))
+\f
+(define (write-package-name label package)
+ (write-string label)
+ (write-string ": ")
+ (write (package/name package))
+ (newline))
+
+(define (format-package/files indentation width package)
+ width
+ (if (positive? (package/n-files package))
+ (begin
+ (newline)
+ (write-label "Files")
+ (newline)
+ (for-each (lambda (pathname)
+ (write-string indentation)
+ (write-string (pathname->string pathname))
+ (newline))
+ (package/files package)))))
+
+(define (format-package/bindings indentation width package bindings)
+ (format-bindings
+ indentation width package bindings
+ "Bindings"
+ (lambda (binding)
+ (let ((name (write-to-string (binding/name binding))))
+ (if (< (package/n-files package) 2)
+ name
+ (string-append
+ name
+ " "
+ (write-to-string
+ (map expression/file (binding/expressions binding)))))))))
+
+(define (format-package/imports indentation width local-package remote-package
+ bindings)
+ (format-exports indentation width local-package remote-package bindings
+ local-map/import "Imports from"))
+
+(define (format-package/exports indentation width remote-package bindings)
+ (format-exports indentation width remote-package remote-package bindings
+ local-map/export "Exports to"))
+\f
+(define (format-exports indentation width local-package remote-package
+ bindings local-map label)
+ (format-bindings
+ indentation width local-package bindings
+ (string-append label
+ " package "
+ (write-to-string (package/name remote-package)))
+ (lambda (destination-binding)
+ (with-values
+ (lambda ()
+ (local-map (binding/source-binding destination-binding)
+ destination-binding))
+ (lambda (local-binding remote-binding)
+ (let ((local-name (binding/name local-binding))
+ (remote-name (binding/name remote-binding)))
+ (let ((name-string (write-to-string local-name)))
+ (if (eq? local-name remote-name)
+ name-string
+ (string-append name-string
+ " ["
+ (write-to-string remote-name)
+ "]")))))))))
+
+(define (local-map/export source destination)
+ (values source destination))
+
+(define (local-map/import source destination)
+ (values destination source))
+
+(define (format-bindings indentation width package
+ bindings label binding->name)
+ (newline)
+ (write-label label)
+ (for-each (lambda (binding)
+ (format-expressions
+ indentation width package
+ (binding->name binding)
+ (mapcan (lambda (reference)
+ (list-copy (reference/expressions reference)))
+ (binding/references binding))))
+ bindings))
+
+(define (classify-bindings-by-package binding->package bindings)
+ (let ((classes '()))
+ (for-each
+ (lambda (binding)
+ (let ((package (binding->package binding)))
+ (let ((entry (assq package classes)))
+ (if entry
+ (set-cdr! entry (cons binding (cdr entry)))
+ (set! classes (cons (list package binding) classes))))))
+ bindings)
+ (for-each (lambda (class)
+ (set-cdr! class (reverse! (cdr class))))
+ classes)
+ (sort classes
+ (lambda (x y)
+ (package<? (car x) (car y))))))
+\f
+(define (format-references indentation width label package references)
+ (write-label label)
+ (for-each (lambda (reference)
+ (format-expressions indentation width package
+ (write-to-string (reference/name reference))
+ (reference/expressions reference)))
+ references))
+
+(define (format-expressions indentation width package name expressions)
+ (with-values (lambda ()
+ (classify-expression-names
+ (map (lambda (expression)
+ (expression->name expression package))
+ expressions)))
+ (lambda (symbols pairs)
+ (write-string indentation)
+ (write-string name)
+ (newline)
+ (let ((indentation (new-indentation indentation)))
+ (write-strings/compact indentation width
+ (map write-to-string (sort symbols symbol<?)))
+ (write-items/miser indentation width write
+ (sort pairs
+ (lambda (x y)
+ (or (string<? (car x) (car y))
+ (and (string=? (car x) (car y))
+ (or (null? (cdr x))
+ (and (not (null? (cdr y)))
+ (symbol<? (cadr x) (cadr y)))))))))))))
+
+(define (classify-expression-names names)
+ (if (null? names)
+ (values '() '())
+ (with-values (lambda () (classify-expression-names (cdr names)))
+ (lambda (symbols pairs)
+ (if (pair? (car names))
+ (values symbols (cons (car names) pairs))
+ (values (cons (car names) symbols) pairs))))))
+
+(define (expression->name expression package)
+ (let ((package* (expression/package expression))
+ (value-cell (expression/value-cell expression)))
+ (let ((binding
+ (and value-cell
+ (list-search-positive (value-cell/bindings value-cell)
+ (lambda (binding)
+ (eq? package* (binding/package binding)))))))
+ (if binding
+ (let ((name (binding/name binding)))
+ (if (and package
+ (let ((binding* (package/find-binding package name)))
+ (and binding*
+ (eq? (binding/value-cell binding)
+ (binding/value-cell binding*)))))
+ name
+ (list (expression/file expression) name)))
+ (list (expression/file expression))))))
+\f
+(define (write-label label)
+ (write-string label)
+ (write-string ":")
+ (newline))
+
+(define (write-strings/compact indentation width strings)
+ (if (not (null? strings))
+ (begin
+ (let loop ((strings strings) (offset 0) (prefix indentation))
+ (if (not (null? strings))
+ (let ((length (string-length (car strings))))
+ (let ((new-offset (+ offset (string-length prefix) length)))
+ (if (and (> new-offset width)
+ (not (zero? offset)))
+ (begin (newline)
+ (loop strings 0 indentation))
+ (begin (write-string prefix)
+ (write-string (car strings))
+ (loop (cdr strings) new-offset " ")))))))
+ (newline))))
+
+(define (write-items/miser indentation width write-item items)
+ width
+ (for-each (lambda (item)
+ (write-string indentation)
+ (write-item item)
+ (newline))
+ items))
+
+(define (new-indentation indentation)
+ (string-append indentation " "))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.1 1988/06/13 12:38:24 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Package Model: System Construction
+
+(declare (usual-integrations))
+
+(package/system-loader "cref" '() 'QUERY)
+(add-system! (make-system "CREF" 0 0 '()))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/mset.scm,v 1.1 1988/06/13 12:38:26 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Multiset Operations
+
+(declare (usual-integrations))
+
+(define (multiset->set multiset)
+ (if (null? multiset)
+ '()
+ (let ((set (multiset->set (cdr multiset))))
+ (if (memq (car multiset) set)
+ set
+ (cons (car multiset) set)))))
+
+(define (multiset-difference x y)
+ (if (null? y)
+ x
+ (let loop ((x x))
+ (cond ((null? x) '())
+ ((memq (car x) y) (loop (cdr x)))
+ (else (cons (car x) (loop (cdr x))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/object.scm,v 1.1 1988/06/13 12:38:28 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Package Model Data Structures
+
+(declare (usual-integrations))
+\f
+(define-structure (package-description (constructor make-package-description)
+ (conc-name package-description/))
+ (name false read-only true)
+ (file-cases false read-only true)
+ (parent false read-only true)
+ (initialization false read-only true)
+ (exports false read-only true)
+ (imports false read-only true))
+
+(define-structure (pmodel (conc-name pmodel/))
+ (root-package false read-only true)
+ (primitive-package false read-only true)
+ (packages false read-only true)
+ (extra-packages false read-only true)
+ (default-pathname false read-only true))
+
+(define-structure (package
+ (constructor %make-package
+ (name file-cases files initialization parent))
+ (conc-name package/))
+ (name false read-only true)
+ (file-cases false read-only true)
+ (files false read-only true)
+ (initialization false read-only true)
+ parent
+ (children '())
+ (bindings (make-btree symbol<? binding/name) read-only true)
+ (references (make-btree symbol<? reference/name) read-only true))
+
+(define (make-package name file-cases initialization parent)
+ (let ((files
+ (mapcan (lambda (file-case)
+ (mapcan (lambda (clause) (list-copy (cdr clause)))
+ (cdr file-case)))
+ file-cases)))
+ (%make-package name
+ file-cases
+ files
+ initialization
+ parent)))
+
+(define-integrable (package/n-files package)
+ (length (package/files package)))
+
+(define-integrable (package/root? package)
+ (null? (package/name package)))
+
+(define (package/find-binding package name)
+ (btree-lookup (package/bindings package) name
+ identity-procedure
+ (lambda (name) name false)))
+
+(define-integrable (file-case/type file-case)
+ (car file-case))
+
+(define-integrable (file-case/clauses file-case)
+ (cdr file-case))
+
+(define-integrable (file-case-clause/keys clause)
+ (car clause))
+
+(define-integrable (file-case-clause/files clause)
+ (cdr clause))
+\f
+(define-structure (binding (constructor %make-binding
+ (package name value-cell))
+ (conc-name binding/))
+ (package false read-only true)
+ (name false read-only true)
+ (value-cell false read-only true)
+ (references '())
+ (links '()))
+
+(define (make-binding package name value-cell)
+ (let ((binding (%make-binding package name value-cell)))
+ (set-value-cell/bindings!
+ value-cell
+ (cons binding (value-cell/bindings value-cell)))
+ binding))
+
+(define-integrable (binding/expressions binding)
+ (value-cell/expressions (binding/value-cell binding)))
+
+(define-integrable (binding/source-binding binding)
+ (value-cell/source-binding (binding/value-cell binding)))
+
+(define (binding/internal? binding)
+ (eq? binding (binding/source-binding binding)))
+
+(define-structure (value-cell (constructor make-value-cell ())
+ (conc-name value-cell/))
+ (bindings '())
+ (expressions '())
+ (source-binding false))
+
+(define-structure (link (constructor %make-link)
+ (conc-name link/))
+ (source false read-only true)
+ (destination false read-only true))
+
+(define (make-link source-binding destination-binding)
+ (let ((link (%make-link source-binding destination-binding)))
+ (set-binding/links! source-binding
+ (cons link (binding/links source-binding)))
+ link))
+
+(define-structure (expression (constructor make-expression (package file type))
+ (conc-name expression/))
+ (package false read-only true)
+ (file false read-only true)
+ (type false read-only true)
+ (references '())
+ (value-cell false))
+
+(define-structure (reference (constructor %make-reference (package name))
+ (conc-name reference/))
+ (package false read-only true)
+ (name false read-only true)
+ (expressions '())
+ (binding false))
+\f
+(define-integrable (symbol<? x y)
+ (string<? (symbol->string x) (symbol->string y)))
+
+(define (symbol-list=? x y)
+ (if (null? x)
+ (null? y)
+ (and (not (null? y))
+ (eq? (car x) (car y))
+ (symbol-list=? (cdr x) (cdr y)))))
+
+(define (symbol-list<? x y)
+ (and (not (null? y))
+ (if (or (null? x)
+ (symbol<? (car x) (car y)))
+ true
+ (and (eq? (car x) (car y))
+ (symbol-list<? (cdr x) (cdr y))))))
+
+(define (package<? x y)
+ (symbol-list<? (package/name x) (package/name y)))
+
+(define (binding<? x y)
+ (symbol<? (binding/name x) (binding/name y)))
+
+(define (reference<? x y)
+ (symbol<? (reference/name x) (reference/name y)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/redpkg.scm,v 1.1 1988/06/13 12:38:30 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Package Model Reader
+
+(declare (usual-integrations)
+ (integrate-external "object"))
+\f
+(define (read-package-model filename)
+ (let* ((pathname (pathname->absolute-pathname (->pathname filename)))
+ (default-pathname (pathname-directory-path pathname)))
+ (with-values
+ (lambda ()
+ (sort-descriptions
+ (map (lambda (expression)
+ (parse-package-expression expression))
+ (read-package-description-file pathname))))
+ (lambda (packages globals)
+ (let ((pmodel (descriptions->pmodel packages default-pathname)))
+ (for-each
+ (let ((root-package (pmodel/root-package pmodel)))
+ (lambda (pathname)
+ (for-each (let ((expression
+ (make-expression root-package
+ (pathname->string pathname)
+ false)))
+ (lambda (name)
+ (bind! root-package name expression)))
+ (fasload
+ (merge-pathnames (pathname-new-type pathname "glob")
+ default-pathname)))))
+ globals)
+ pmodel)))))
+
+(define (sort-descriptions descriptions)
+ (let loop
+ ((descriptions descriptions)
+ (packages '())
+ (globals '()))
+ (cond ((null? descriptions)
+ (values (reverse! packages) globals))
+ ((package-description? (car descriptions))
+ (loop (cdr descriptions)
+ (cons (car descriptions) packages)
+ globals))
+ ((and (pair? (car descriptions))
+ (eq? (car (car descriptions)) 'GLOBAL-DEFINITIONS))
+ (loop (cdr descriptions)
+ packages
+ (append globals (cdr (car descriptions)))))
+ (else
+ (error "Illegal description" (car descriptions))))))
+
+(define (read-package-description-file pathname)
+ (read-file (pathname-default-type pathname "pkg")))
+\f
+(define (read-file-analyses! pmodel)
+ (for-each (lambda (package)
+ (for-each (lambda (pathname)
+ (read-file-analysis! pmodel package pathname))
+ (package/files package)))
+ (pmodel/packages pmodel)))
+
+(define (read-file-analysis! pmodel package pathname)
+ (let ((filename (pathname->string pathname))
+ (root-package (pmodel/root-package pmodel))
+ (primitive-package (pmodel/primitive-package pmodel)))
+ (for-each (lambda (entry)
+ (let ((name (vector-ref entry 0))
+ (expression
+ (make-expression package
+ filename
+ (vector-ref entry 4))))
+ (let ((intern!
+ (lambda (name)
+ (cond ((symbol? name)
+ (make-reference package name expression))
+ ((primitive-procedure? name)
+ (make-reference
+ primitive-package
+ (primitive-procedure-name name)
+ expression))
+ ((access? name)
+ (if (access-environment name)
+ (error "Non-root access" name))
+ (make-reference root-package
+ (access-name name)
+ expression))
+ (else
+ (error "Illegal reference name" name))))))
+ (for-each intern! (vector-ref entry 1))
+ (for-each intern! (vector-ref entry 2))
+ (for-each intern! (vector-ref entry 3)))
+ (if name
+ (bind! package name expression))))
+ (read-analyzed-file
+ (merge-pathnames (pathname-new-type pathname "bin")
+ (pmodel/default-pathname pmodel))))))
+
+(define (resolve-references! pmodel)
+ (for-each (lambda (package)
+ (for-each resolve-reference!
+ (btree-fringe (package/references package))))
+ (pmodel/packages pmodel)))
+
+(define (resolve-reference! reference)
+ (let ((binding
+ (package-lookup (reference/package reference)
+ (reference/name reference))))
+ (if binding
+ (begin
+ (set-reference/binding! reference binding)
+ (set-binding/references! binding
+ (cons reference
+ (binding/references binding)))))))
+\f
+;;;; Package Descriptions
+
+(define (parse-package-expression expression)
+ (if (not (pair? expression))
+ (error "package expression not a pair" expression))
+ (case (car expression)
+ ((DEFINE-PACKAGE)
+ (parse-package-description (parse-name (cadr expression))
+ (cddr expression)))
+ ((GLOBAL-DEFINITIONS)
+ (let ((filenames (cdr expression)))
+ (if (not (check-list filenames string?))
+ (error "illegal filenames" filenames))
+ (cons 'GLOBAL-DEFINITIONS (map parse-filename filenames))))
+ (else
+ (error "unrecognized expression keyword" (car expression)))))
+
+(define (parse-package-description name options)
+ (let ((none "none"))
+ (let ((file-cases '())
+ (parent none)
+ (initialization none)
+ (exports '())
+ (imports '()))
+ (if (not (list? options))
+ (error "options not list" options))
+ (for-each (lambda (option)
+ (if (not (pair? option))
+ (error "Illegal option" option))
+ (case (car option)
+ ((FILES)
+ (set! file-cases
+ (cons (parse-filenames (cdr option)) file-cases)))
+ ((FILE-CASE)
+ (set! file-cases
+ (cons (parse-file-case (cdr option)) file-cases)))
+ ((PARENT)
+ (if (not (eq? parent none))
+ (error "option reoccurs" option))
+ (if (not (and (pair? (cdr option)) (null? (cddr option))))
+ (error "illegal option" option))
+ (set! parent (parse-name (cadr option))))
+ ((EXPORT)
+ (set! exports (cons (parse-export (cdr option)) exports)))
+ ((IMPORT)
+ (set! imports (cons (parse-import (cdr option)) imports)))
+ ((INITIALIZATION)
+ (if (not (eq? initialization none))
+ (error "option reoccurs" option))
+ (set! initialization (parse-initialization (cdr option))))
+ (else
+ (error "unrecognized option keyword" (car option)))))
+ options)
+ (make-package-description
+ name
+ file-cases
+ (if (eq? parent none) 'NONE parent)
+ (if (eq? initialization none) '#F initialization)
+ (reverse! exports)
+ (reverse! imports)))))
+\f
+(define (parse-name name)
+ (if (not (check-list name symbol?))
+ (error "illegal name" name))
+ name)
+
+(define (parse-filenames filenames)
+ (if (not (check-list filenames string?))
+ (error "illegal filenames" filenames))
+ (list #F (cons 'ELSE (map parse-filename filenames))))
+
+(define (parse-file-case file-case)
+ (if (not (and (pair? file-case)
+ (symbol? (car file-case))
+ (check-list (cdr file-case)
+ (lambda (clause)
+ (and (pair? clause)
+ (or (eq? 'ELSE (car clause))
+ (check-list (car clause) symbol?))
+ (check-list (cdr clause) string?))))))
+ (error "Illegal file-case" file-case))
+ (cons (car file-case)
+ (map (lambda (clause)
+ (cons (car clause)
+ (map parse-filename (cdr clause))))
+ (cdr file-case))))
+
+(define-integrable (parse-filename filename)
+ (string->pathname filename))
+
+(define (parse-initialization initialization)
+ (if (not (and (pair? initialization) (null? (cdr initialization))))
+ (error "illegal initialization" initialization))
+ (car initialization))
+
+(define (parse-import import)
+ (if (not (and (pair? import) (check-list (cdr import) symbol?)))
+ (error "illegal import" import))
+ (cons (parse-name (car import)) (cdr import)))
+
+(define (parse-export export)
+ (if (not (and (pair? export) (check-list (cdr export) symbol?)))
+ (error "illegal export" export))
+ (cons (parse-name (car export)) (cdr export)))
+
+(define (check-list items predicate)
+ (let loop ((items items))
+ (if (pair? items)
+ (if (predicate (car items))
+ (loop (cdr items))
+ false)
+ (null? items))))
+\f
+;;;; Packages
+
+(define (package-lookup package name)
+ (let package-loop ((package package))
+ (or (package/find-binding package name)
+ (and (package/parent package)
+ (package-loop (package/parent package))))))
+
+(define (name->package packages name)
+ (list-search-positive packages
+ (lambda (package)
+ (symbol-list=? name (package/name package)))))
+
+(define (descriptions->pmodel descriptions default-pathname)
+ (let ((packages
+ (map (lambda (description)
+ (make-package
+ (package-description/name description)
+ (package-description/file-cases description)
+ (package-description/initialization description)
+ 'UNKNOWN))
+ descriptions))
+ (extra-packages '()))
+ (let ((root-package
+ (or (name->package packages '())
+ (make-package '() '() '#F false))))
+ (let ((get-package
+ (lambda (name)
+ (if (null? name)
+ root-package
+ (or (name->package packages name)
+ (let ((package (make-package name '() #F 'UNKNOWN)))
+ (set! extra-packages (cons package extra-packages))
+ package))))))
+ (for-each (lambda (package description)
+ (let ((parent
+ (let ((parent-name
+ (package-description/parent description)))
+ (and (not (eq? parent-name 'NONE))
+ (get-package parent-name)))))
+ (set-package/parent! package parent)
+ (if parent
+ (set-package/children!
+ parent
+ (cons package (package/children parent)))))
+ (for-each (lambda (export)
+ (let ((destination (get-package (car export))))
+ (for-each (lambda (name)
+ (link! package name
+ destination name))
+ (cdr export))))
+ (package-description/exports description))
+ (for-each (lambda (import)
+ (let ((source (get-package (car import))))
+ (for-each (lambda (name)
+ (link! source name package name))
+ (cdr import))))
+ (package-description/imports description)))
+ packages
+ descriptions))
+ (make-pmodel root-package
+ (make-package primitive-package-name '() '() false)
+ packages
+ extra-packages
+ default-pathname))))
+
+(define primitive-package-name
+ (list (string->uninterned-symbol "primitives")))
+\f
+;;;; Binding and Reference
+
+(define (bind! package name expression)
+ (let ((value-cell (binding/value-cell (intern-binding! package name))))
+ (set-expression/value-cell! expression value-cell)
+ (set-value-cell/expressions!
+ value-cell
+ (cons expression (value-cell/expressions value-cell)))))
+
+(define (link! source-package source-name destination-package destination-name)
+ (let ((source-binding (intern-binding! source-package source-name)))
+ (make-link source-binding
+ (btree-insert! (package/bindings destination-package)
+ destination-name
+ (lambda (destination-name)
+ (make-binding destination-package
+ destination-name
+ (binding/value-cell source-binding)))
+ (lambda (binding)
+ binding
+ (error "Attempt to reinsert binding" destination-name))
+ identity-procedure))))
+
+(define (intern-binding! package name)
+ (btree-insert! (package/bindings package) name
+ (lambda (name)
+ (let ((value-cell (make-value-cell)))
+ (let ((binding (make-binding package name value-cell)))
+ (set-value-cell/source-binding! value-cell binding)
+ binding)))
+ identity-procedure
+ identity-procedure))
+
+(define (make-reference package name expression)
+ (let ((add-reference!
+ (lambda (reference)
+ (set-reference/expressions!
+ reference
+ (cons expression (reference/expressions reference)))
+ (set-expression/references!
+ expression
+ (cons reference (expression/references expression))))))
+ (btree-insert! (package/references package) name
+ (lambda (name)
+ (%make-reference package name))
+ (lambda (reference)
+ (if (not (memq expression (reference/expressions reference)))
+ (add-reference! reference))
+ reference)
+ (lambda (reference)
+ (add-reference! reference)
+ reference))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/toplev.scm,v 1.1 1988/06/13 12:38:33 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Package Model: Top Level
+
+(declare (usual-integrations))
+\f
+(define (generate/common kernel)
+ (lambda (filename)
+ (let ((pathname (pathname->absolute-pathname (->pathname filename))))
+ (let ((pmodel (read-package-model pathname)))
+ (read-file-analyses! pmodel)
+ (resolve-references! pmodel)
+ (kernel pathname pmodel)))))
+
+(define (cref/generate-trivial-constructor filename)
+ (let ((pathname (pathname->absolute-pathname (->pathname filename))))
+ (write-constructor pathname (read-package-model pathname))))
+
+(define cref/generate-cref
+ (generate/common
+ (lambda (pathname pmodel)
+ (write-cref pathname pmodel))))
+
+(define cref/generate-constructors
+ (generate/common
+ (lambda (pathname pmodel) (write-constructor pathname pmodel)
+ (write-loader pathname pmodel))))
+
+(define cref/generate-all
+ (generate/common
+ (lambda (pathname pmodel)
+ (write-cref pathname pmodel)
+ (write-globals pathname pmodel)
+ (write-constructor pathname pmodel)
+ (write-loader pathname pmodel))))
+
+(define (write-constructor pathname pmodel)
+ (let ((constructor (construct-constructor pmodel)))
+ (with-output-to-file (pathname-new-type pathname "con")
+ (lambda ()
+ (write-string ";;; -*-Scheme-*-")
+ (newline)
+ (write-string ";;; program to make package structure")
+ (for-each (lambda (expression)
+ (pp expression 'AS-CODE))
+ constructor)))))
+
+(define (write-loader pathname pmodel)
+ (let ((loader (construct-loader pmodel)))
+ (with-output-to-file (pathname-new-type pathname "ldr")
+ (lambda ()
+ (write-string ";;; -*-Scheme-*-")
+ (newline)
+ (write-string ";;; program to load package contents")
+ (for-each (lambda (expression)
+ (pp expression 'AS-CODE))
+ loader)))))
+
+(define (write-cref pathname pmodel)
+ (with-output-to-file (pathname-new-type pathname "cref")
+ (lambda ()
+ (format-packages pmodel))))
+
+(define (write-globals pathname pmodel)
+ (fasdump (map binding/name
+ (list-transform-positive
+ (btree-fringe
+ (package/bindings (pmodel/root-package pmodel)))
+ binding/source-binding))
+ (pathname-new-type pathname "glob")))
\ No newline at end of file
projects / mit-scheme.git / commitdiff