From 04f7b636192a6490e9e82db106e680ee80e6b6ec Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Fri, 26 May 1989 16:29:27 +0000 Subject: [PATCH] Initial revision --- v7/src/compiler/etc/comcmp.scm | 149 +++++++++++++++++++++++++++++++++ v7/src/cref/triv.con | 119 ++++++++++++++++++++++++++ v7/src/cref/triv.ldr | 48 +++++++++++ v8/src/compiler/etc/comcmp.scm | 149 +++++++++++++++++++++++++++++++++ 4 files changed, 465 insertions(+) create mode 100644 v7/src/compiler/etc/comcmp.scm create mode 100644 v7/src/cref/triv.con create mode 100644 v7/src/cref/triv.ldr create mode 100644 v8/src/compiler/etc/comcmp.scm diff --git a/v7/src/compiler/etc/comcmp.scm b/v7/src/compiler/etc/comcmp.scm new file mode 100644 index 000000000..eaae45a7e --- /dev/null +++ b/v7/src/compiler/etc/comcmp.scm @@ -0,0 +1,149 @@ +#| -*-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)) + +(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))) + +(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 " ***"))))))) diff --git a/v7/src/cref/triv.con b/v7/src/cref/triv.con new file mode 100644 index 000000000..836d14f57 --- /dev/null +++ b/v7/src/cref/triv.con @@ -0,0 +1,119 @@ +#| -*-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)) + +(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 diff --git a/v7/src/cref/triv.ldr b/v7/src/cref/triv.ldr new file mode 100644 index 000000000..c1e5e3f72 --- /dev/null +++ b/v7/src/cref/triv.ldr @@ -0,0 +1,48 @@ +#| -*-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)) + +(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 diff --git a/v8/src/compiler/etc/comcmp.scm b/v8/src/compiler/etc/comcmp.scm new file mode 100644 index 000000000..bec635820 --- /dev/null +++ b/v8/src/compiler/etc/comcmp.scm @@ -0,0 +1,149 @@ +#| -*-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)) + +(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))) + +(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 " ***"))))))) -- 2.25.1