--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/etc/comcmp.scm,v 1.1 1989/05/26 16:25:32 jinx Rel $
+
+Copyright (c) 1989 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. |#
+
+;;;; Compiled code binary comparison program
+
+(declare (usual-integrations))
+\f
+(if (unassigned? compiled-code-block/bytes-per-object)
+ (set! compiled-code-block/bytes-per-object 4))
+
+(define comcmp:addressing-granularity 8)
+
+(define comcmp:ignore-debugging-info? true)
+
+(define compare-com-files
+ (let ()
+
+(define (compare-blocks b1 b2)
+ (let ((l1 (system-vector-length b1))
+ (l2 (system-vector-length b2)))
+ (if (not (fix:= l1 l2))
+ `(length ,l1 ,l2)
+ (or (compare-code-sections b1 b2)
+ (compare-constant-sections b1 b2)))))
+
+(define (read-code b s e)
+ (let ((bs (bit-string-allocate (* comcmp:addressing-granularity (- e s)))))
+ (read-bits! b (* comcmp:addressing-granularity s) bs)
+ bs))
+
+(define (compare-code-sections b1 b2)
+ (let ((s1 (compiled-code-block/code-start b1))
+ (s2 (compiled-code-block/code-start b2))
+ (e1 (compiled-code-block/code-end b1))
+ (e2 (compiled-code-block/code-end b2)))
+ (cond ((not (fix:= s1 s2))
+ `(code-start ,s1 ,s2))
+ ((not (fix:= e1 e2))
+ `(code-end ,e1 ,e2))
+ ((not (bit-string=? (read-code b1 s1 e1)
+ (read-code b2 s2 e2)))
+ `(code))
+ (else
+ false))))
+
+(define (constant-equal? c1 c2)
+ (if (and (scode-constant? c1)
+ (scode-constant? c2))
+ (equal? (unsyntax c1) (unsyntax c2))
+ (equal? c1 c2)))
+\f
+(define (compare-constant-sections b1 b2)
+ (define (loop s e diff)
+ (cond ((fix:> s e)
+ (if (null? diff)
+ false
+ (cons 'CONSTANTS (reverse! diff))))
+ ((not (constant-equal? (system-vector-ref b1 s)
+ (system-vector-ref b2 s)))
+ (loop (fix:1+ s)
+ e
+ `((,s ,(system-vector-ref b1 s)
+ ,(system-vector-ref b2 s))
+ ,@diff)))
+ (else
+ (loop (fix:1+ s) e diff))))
+
+ ;; Kludge!
+ (if comcmp:ignore-debugging-info?
+ (begin
+ (set-compiled-code-block/debugging-info! b1 '())
+ (set-compiled-code-block/debugging-info! b2 '())))
+
+ (let ((s1 (compiled-code-block/constants-start b1))
+ (s2 (compiled-code-block/constants-start b2))
+ (e1 (compiled-code-block/constants-end b1))
+ (e2 (compiled-code-block/constants-end b2)))
+ (cond ((not (fix:= s1 s2))
+ `(constant-start ,s1 ,s2))
+ ((not (fix:= e1 e2))
+ `(constant-end ,e1 ,e2))
+ (else
+ (loop s1 e1 '())))))
+
+(lambda (f1 f2)
+ (compare-blocks (compiled-code-address->block (fasload f1))
+ (compiled-code-address->block (fasload f2))))
+
+))
+
+(define (show-differences f1 f2)
+ (define (->name f)
+ (pathname->string (->pathname f)))
+
+ (let ((result (compare-com-files f1 f2)))
+ (if (pair? result)
+ (begin
+ (newline)
+ (for-each display
+ (list "*** Files " (->name f1)
+ " and " (->name f2)
+ " differ : "))
+ (if (and (eq? 'CONSTANTS (car result))
+ (> (length result) 2))
+ (begin
+ (display "***")
+ (newline)
+ (display "(CONSTANTS")
+ (for-each (lambda (c)
+ (newline)
+ (display " ")
+ (write c))
+ (cdr result))
+ (newline)
+ (display ")"))
+ (begin
+ (write result)
+ (display " ***")))))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/Attic/triv.con,v 1.1 1989/05/26 16:28:55 jinx Rel $
+
+Copyright (c) 1989 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. |#
+
+;;;; "Trivial" constructor needed to bootstrap cref.
+
+(declare (usual-integrations))
+\f
+(package/add-child!
+ (find-package '())
+ 'cross-reference
+ (in-package (package/environment (find-package '()))
+ (let ((cref/generate-all)
+ (cref/generate-constructors)
+ (cref/generate-cref)
+ (cref/generate-trivial-constructor))
+ (the-environment))))
+(let ((source (package/environment (find-package '( cross-reference))))
+ (destination (package/environment (find-package '()))))
+ (environment-link-name destination source 'cref/generate-all)
+ (environment-link-name destination source 'cref/generate-constructors)
+ (environment-link-name destination source 'cref/generate-cref)
+ (environment-link-name destination source 'cref/generate-trivial-constructor))
+
+(package/add-child!
+ (find-package '(cross-reference))
+ 'balanced-binary-tree
+ (in-package (package/environment (find-package '(cross-reference)))
+ (let ((btree-delete!)
+ (btree-fringe)
+ (btree-insert!)
+ (btree-lookup)
+ (make-btree))
+ (the-environment))))
+(let ((source (package/environment (find-package '(cross-reference balanced-binary-tree))))
+ (destination (package/environment (find-package '(cross-reference)))))
+ (environment-link-name destination source 'btree-delete!)
+ (environment-link-name destination source 'btree-fringe)
+ (environment-link-name destination source 'btree-insert!)
+ (environment-link-name destination source 'btree-lookup)
+ (environment-link-name destination source 'make-btree))
+
+(package/add-child!
+ (find-package '(cross-reference))
+ 'analyze-file
+ (in-package (package/environment (find-package '(cross-reference)))
+ (let ((analyze/directory)
+ (read-analyzed-file))
+ (the-environment))))
+(let ((source (package/environment (find-package '(cross-reference analyze-file))))
+ (destination (package/environment (find-package '(cross-reference)))))
+ (environment-link-name destination source 'analyze/directory)
+ (environment-link-name destination source 'read-analyzed-file))
+
+(package/add-child!
+ (find-package '(cross-reference))
+ 'constructor
+ (in-package (package/environment (find-package '(cross-reference)))
+ (let ((construct-constructor)
+ (construct-loader))
+ (the-environment))))
+(let ((source (package/environment (find-package '(cross-reference constructor))))
+ (destination (package/environment (find-package '(cross-reference)))))
+ (environment-link-name destination source 'construct-constructor)
+ (environment-link-name destination source 'construct-loader))
+
+(package/add-child!
+ (find-package '(cross-reference))
+ 'formatter
+ (in-package (package/environment (find-package '(cross-reference)))
+ (let ((format-packages))
+ (the-environment))))
+(let ((source (package/environment (find-package '(cross-reference formatter))))
+ (destination (package/environment (find-package '(cross-reference)))))
+ (environment-link-name destination source 'format-packages))
+
+(package/add-child!
+ (find-package '(cross-reference))
+ 'reader
+ (in-package (package/environment (find-package '(cross-reference)))
+ (let ((read-file-analyses!)
+ (read-package-model)
+ (resolve-references!))
+ (the-environment))))
+(let ((source (package/environment (find-package '(cross-reference reader))))
+ (destination (package/environment (find-package '(cross-reference)))))
+ (environment-link-name destination source 'read-file-analyses!)
+ (environment-link-name destination source 'read-package-model)
+ (environment-link-name destination source 'resolve-references!))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/Attic/triv.ldr,v 1.1 1989/05/26 16:29:27 jinx Rel $
+
+Copyright (c) 1989 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. |#
+
+;;;; "Trivial" loader needed to bootstrap cref.
+
+(declare (usual-integrations))
+\f
+(lambda (load alist)
+ alist
+ (load "mset" (package/environment (find-package '(cross-reference))))
+ (load '("object" "toplev") (package/environment (find-package '(cross-reference))))
+ (load '("mset" "object" "toplev") (package/environment (find-package '(cross-reference))))
+ (load "btree" (package/environment (find-package '(cross-reference balanced-binary-tree))))
+ (load "anfile" (package/environment (find-package '(cross-reference analyze-file))))
+ (load "conpkg" (package/environment (find-package '(cross-reference constructor))))
+ (load "forpkg" (package/environment (find-package '(cross-reference formatter))))
+ (load "redpkg" (package/environment (find-package '(cross-reference reader)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/etc/comcmp.scm,v 1.1 1989/05/26 16:25:32 jinx Rel $
+
+Copyright (c) 1989 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. |#
+
+;;;; Compiled code binary comparison program
+
+(declare (usual-integrations))
+\f
+(if (unassigned? compiled-code-block/bytes-per-object)
+ (set! compiled-code-block/bytes-per-object 4))
+
+(define comcmp:addressing-granularity 8)
+
+(define comcmp:ignore-debugging-info? true)
+
+(define compare-com-files
+ (let ()
+
+(define (compare-blocks b1 b2)
+ (let ((l1 (system-vector-length b1))
+ (l2 (system-vector-length b2)))
+ (if (not (fix:= l1 l2))
+ `(length ,l1 ,l2)
+ (or (compare-code-sections b1 b2)
+ (compare-constant-sections b1 b2)))))
+
+(define (read-code b s e)
+ (let ((bs (bit-string-allocate (* comcmp:addressing-granularity (- e s)))))
+ (read-bits! b (* comcmp:addressing-granularity s) bs)
+ bs))
+
+(define (compare-code-sections b1 b2)
+ (let ((s1 (compiled-code-block/code-start b1))
+ (s2 (compiled-code-block/code-start b2))
+ (e1 (compiled-code-block/code-end b1))
+ (e2 (compiled-code-block/code-end b2)))
+ (cond ((not (fix:= s1 s2))
+ `(code-start ,s1 ,s2))
+ ((not (fix:= e1 e2))
+ `(code-end ,e1 ,e2))
+ ((not (bit-string=? (read-code b1 s1 e1)
+ (read-code b2 s2 e2)))
+ `(code))
+ (else
+ false))))
+
+(define (constant-equal? c1 c2)
+ (if (and (scode-constant? c1)
+ (scode-constant? c2))
+ (equal? (unsyntax c1) (unsyntax c2))
+ (equal? c1 c2)))
+\f
+(define (compare-constant-sections b1 b2)
+ (define (loop s e diff)
+ (cond ((fix:> s e)
+ (if (null? diff)
+ false
+ (cons 'CONSTANTS (reverse! diff))))
+ ((not (constant-equal? (system-vector-ref b1 s)
+ (system-vector-ref b2 s)))
+ (loop (fix:1+ s)
+ e
+ `((,s ,(system-vector-ref b1 s)
+ ,(system-vector-ref b2 s))
+ ,@diff)))
+ (else
+ (loop (fix:1+ s) e diff))))
+
+ ;; Kludge!
+ (if comcmp:ignore-debugging-info?
+ (begin
+ (set-compiled-code-block/debugging-info! b1 '())
+ (set-compiled-code-block/debugging-info! b2 '())))
+
+ (let ((s1 (compiled-code-block/constants-start b1))
+ (s2 (compiled-code-block/constants-start b2))
+ (e1 (compiled-code-block/constants-end b1))
+ (e2 (compiled-code-block/constants-end b2)))
+ (cond ((not (fix:= s1 s2))
+ `(constant-start ,s1 ,s2))
+ ((not (fix:= e1 e2))
+ `(constant-end ,e1 ,e2))
+ (else
+ (loop s1 e1 '())))))
+
+(lambda (f1 f2)
+ (compare-blocks (compiled-code-address->block (fasload f1))
+ (compiled-code-address->block (fasload f2))))
+
+))
+
+(define (show-differences f1 f2)
+ (define (->name f)
+ (pathname->string (->pathname f)))
+
+ (let ((result (compare-com-files f1 f2)))
+ (if (pair? result)
+ (begin
+ (newline)
+ (for-each display
+ (list "*** Files " (->name f1)
+ " and " (->name f2)
+ " differ : "))
+ (if (and (eq? 'CONSTANTS (car result))
+ (> (length result) 2))
+ (begin
+ (display "***")
+ (newline)
+ (display "(CONSTANTS")
+ (for-each (lambda (c)
+ (newline)
+ (display " ")
+ (write c))
+ (cdr result))
+ (newline)
+ (display ")"))
+ (begin
+ (write result)
+ (display " ***")))))))
projects / mit-scheme.git / commitdiff