comparison.
#| -*-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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/etc/comcmp.scm,v 1.2 1989/09/21 01:55:35 cph Rel $
Copyright (c) 1989 Massachusetts Institute of Technology
(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 (compare-com-files f1 f2 #!optional verbose?)
+ (let ((quiet? (or (default-object? verbose?) (not verbose?)))
+ (memoizations '()))
+
+ (define (compare-blocks b1 b2)
+ (memoize! b1 b2
+ (lambda ()
+ (let ((l1 (system-vector-length b1))
+ (l2 (system-vector-length b2)))
+ (if (not (= l1 l2))
+ `(length ,l1 ,l2)
+ (or (compare-code-sections b1 b2)
+ (compare-constant-sections b1 b2)))))))
+
+ (define (memoize! b1 b2 do-it)
+ (let ((entry (assq b1 memoizations))
+ (if-not-found
+ (lambda ()
+ (let ((result (do-it)))
+ (let ((entry (assq b1 memoizations)))
+ (if entry
+ (let ((entry* (assq b2 (cdr entry))))
+ (if entry*
+ (set-cdr! entry* result)
+ (set-cdr! entry
+ (cons (cons b2 result) (cdr entry)))))
+ (set! memoizations
+ (cons (list b1 (cons b2 result))
+ memoizations))))
+ result))))
+ (if entry
+ (let ((entry (assq b2 (cdr entry))))
+ (if entry
+ (cdr entry)
+ (if-not-found)))
+ (if-not-found))))
+
+ (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 (= s1 s2))
+ `(code-start ,s1 ,s2))
+ ((not (= e1 e2))
+ `(code-end ,e1 ,e2))
+ ((not (bit-string=? (read-code b1 s1 e1)
+ (read-code b2 s2 e2)))
+ `(code))
+ (else
+ false))))
+
+ (define (read-code b s e)
+ (let ((bs (bit-string-allocate (* addressing-granularity (- e s)))))
+ (read-bits! b (* addressing-granularity s) bs)
+ bs))
+
+ (define addressing-granularity 8)
+
+ (define (compare-constant-sections b1 b2)
+ ;; 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 (= s1 s2))
+ `(constant-start ,s1 ,s2))
+ ((not (= e1 e2))
+ `(constant-end ,e1 ,e2))
+ (else
+ (let loop ((s s1) (e e1) (diffs '()))
+ (cond ((<= s e)
+ (let ((diff
+ (compare-constants
+ s
+ (system-vector-ref b1 s)
+ (system-vector-ref b2 s))))
+ (cond ((not diff)
+ (loop (1+ s) e diffs))
+ ((eq? (car diff) 'CONSTANTS)
+ (loop (1+ s)
+ e
+ (if (member (cadr diff) diffs)
+ diffs
+ (cons (cadr diff) diffs))))
+ (else
+ diff))))
+ ((null? diffs)
+ false)
+ (else
+ (cons 'CONSTANTS (reverse! diffs)))))))))
+
+ (define (compare-constants s c1 c2)
+ (and (not (equal? c1 c2))
+ (let ((differ
+ (lambda ()
+ `(CONSTANTS (,s ,c1 ,c2)))))
+ (cond ((compiled-code-block? c1)
+ (if (compiled-code-block? c2)
+ (compare-blocks c1 c2)
+ (differ)))
+ ((compiled-code-address? c1)
+ (if (and (compiled-code-address? c2)
+ (= (compiled-entry/offset c1)
+ (compiled-entry/offset c2)))
+ (compare-blocks (compiled-entry/block c1)
+ (compiled-entry/block c2))
+ (differ)))
+ ((quotation? c1)
+ (if (quotation? c2)
+ (compare-constants s
+ (quotation-expression c1)
+ (quotation-expression c2))
+ (differ)))
+ ((lambda? c1)
+ (if (lambda? c2)
+ (lambda-components c1
+ (lambda (name required optional rest auxiliary
+ declarations body)
+ (lambda-components c1
+ (lambda (name* required* optional* rest*
+ auxiliary* declarations* body*)
+ (if (and (eqv? name name*)
+ (equal? required required*)
+ (equal? optional optional*)
+ (eqv? rest rest*)
+ (equal? auxiliary auxiliary*)
+ (equal? declarations declarations*))
+ (compare-constants s body body*)
+ (differ))))))
+ (differ)))
+ (else
+ (differ))))))
+
+ (let ((s1 (fasload f1 quiet?))
+ (s2 (fasload f2 quiet?))
+ (dbg-info-vector?
+ (access dbg-info-vector?
+ (->environment '(RUNTIME COMPILER-INFO))))
+ (dbg-info-vector/blocks-vector
+ (access dbg-info-vector/blocks-vector
+ (->environment '(RUNTIME COMPILER-INFO)))))
+ (if (and (comment? s1) (dbg-info-vector? (comment-text s1)))
+ (if (and (comment? s2) (dbg-info-vector? (comment-text s2)))
+ (let ((v1 (dbg-info-vector/blocks-vector (comment-text s1)))
+ (v2 (dbg-info-vector/blocks-vector (comment-text s2))))
+ (let ((e1 (vector-length v1))
+ (e2 (vector-length v2)))
+ (if (= e1 e2)
+ (compare-blocks (vector-ref v1 0) (vector-ref v2 0))
+ `(number-of-blocks ,e1 ,e2))))
+ '(block-structure))
+ (if (and (comment? s2) (dbg-info-vector? (comment-text s2)))
+ '(block-structure)
+ (compare-blocks (compiled-code-address->block s1)
+ (compiled-code-address->block s2)))))))
(define (show-differences f1 f2)
(define (->name f)
(for-each display
(list "*** Files " (->name f1)
" and " (->name f2)
- " differ : "))
- (if (and (eq? 'CONSTANTS (car result))
- (> (length result) 2))
+ " differ: "))
+ (if (eq? 'CONSTANTS (car result))
(begin
(display "***")
(newline)
- (display "(CONSTANTS")
+ (display "(constants")
(for-each (lambda (c)
(newline)
- (display " ")
+ (display " ")
(write c))
(cdr result))
- (newline)
(display ")"))
(begin
(write result)
- (display " ***")))))))
+ (display " ***")))))))
\ No newline at end of file
#| -*-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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/etc/comcmp.scm,v 1.2 1989/09/21 01:55:35 cph Rel $
Copyright (c) 1989 Massachusetts Institute of Technology
(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 (compare-com-files f1 f2 #!optional verbose?)
+ (let ((quiet? (or (default-object? verbose?) (not verbose?)))
+ (memoizations '()))
+
+ (define (compare-blocks b1 b2)
+ (memoize! b1 b2
+ (lambda ()
+ (let ((l1 (system-vector-length b1))
+ (l2 (system-vector-length b2)))
+ (if (not (= l1 l2))
+ `(length ,l1 ,l2)
+ (or (compare-code-sections b1 b2)
+ (compare-constant-sections b1 b2)))))))
+
+ (define (memoize! b1 b2 do-it)
+ (let ((entry (assq b1 memoizations))
+ (if-not-found
+ (lambda ()
+ (let ((result (do-it)))
+ (let ((entry (assq b1 memoizations)))
+ (if entry
+ (let ((entry* (assq b2 (cdr entry))))
+ (if entry*
+ (set-cdr! entry* result)
+ (set-cdr! entry
+ (cons (cons b2 result) (cdr entry)))))
+ (set! memoizations
+ (cons (list b1 (cons b2 result))
+ memoizations))))
+ result))))
+ (if entry
+ (let ((entry (assq b2 (cdr entry))))
+ (if entry
+ (cdr entry)
+ (if-not-found)))
+ (if-not-found))))
+
+ (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 (= s1 s2))
+ `(code-start ,s1 ,s2))
+ ((not (= e1 e2))
+ `(code-end ,e1 ,e2))
+ ((not (bit-string=? (read-code b1 s1 e1)
+ (read-code b2 s2 e2)))
+ `(code))
+ (else
+ false))))
+
+ (define (read-code b s e)
+ (let ((bs (bit-string-allocate (* addressing-granularity (- e s)))))
+ (read-bits! b (* addressing-granularity s) bs)
+ bs))
+
+ (define addressing-granularity 8)
+
+ (define (compare-constant-sections b1 b2)
+ ;; 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 (= s1 s2))
+ `(constant-start ,s1 ,s2))
+ ((not (= e1 e2))
+ `(constant-end ,e1 ,e2))
+ (else
+ (let loop ((s s1) (e e1) (diffs '()))
+ (cond ((<= s e)
+ (let ((diff
+ (compare-constants
+ s
+ (system-vector-ref b1 s)
+ (system-vector-ref b2 s))))
+ (cond ((not diff)
+ (loop (1+ s) e diffs))
+ ((eq? (car diff) 'CONSTANTS)
+ (loop (1+ s)
+ e
+ (if (member (cadr diff) diffs)
+ diffs
+ (cons (cadr diff) diffs))))
+ (else
+ diff))))
+ ((null? diffs)
+ false)
+ (else
+ (cons 'CONSTANTS (reverse! diffs)))))))))
+
+ (define (compare-constants s c1 c2)
+ (and (not (equal? c1 c2))
+ (let ((differ
+ (lambda ()
+ `(CONSTANTS (,s ,c1 ,c2)))))
+ (cond ((compiled-code-block? c1)
+ (if (compiled-code-block? c2)
+ (compare-blocks c1 c2)
+ (differ)))
+ ((compiled-code-address? c1)
+ (if (and (compiled-code-address? c2)
+ (= (compiled-entry/offset c1)
+ (compiled-entry/offset c2)))
+ (compare-blocks (compiled-entry/block c1)
+ (compiled-entry/block c2))
+ (differ)))
+ ((quotation? c1)
+ (if (quotation? c2)
+ (compare-constants s
+ (quotation-expression c1)
+ (quotation-expression c2))
+ (differ)))
+ ((lambda? c1)
+ (if (lambda? c2)
+ (lambda-components c1
+ (lambda (name required optional rest auxiliary
+ declarations body)
+ (lambda-components c1
+ (lambda (name* required* optional* rest*
+ auxiliary* declarations* body*)
+ (if (and (eqv? name name*)
+ (equal? required required*)
+ (equal? optional optional*)
+ (eqv? rest rest*)
+ (equal? auxiliary auxiliary*)
+ (equal? declarations declarations*))
+ (compare-constants s body body*)
+ (differ))))))
+ (differ)))
+ (else
+ (differ))))))
+
+ (let ((s1 (fasload f1 quiet?))
+ (s2 (fasload f2 quiet?))
+ (dbg-info-vector?
+ (access dbg-info-vector?
+ (->environment '(RUNTIME COMPILER-INFO))))
+ (dbg-info-vector/blocks-vector
+ (access dbg-info-vector/blocks-vector
+ (->environment '(RUNTIME COMPILER-INFO)))))
+ (if (and (comment? s1) (dbg-info-vector? (comment-text s1)))
+ (if (and (comment? s2) (dbg-info-vector? (comment-text s2)))
+ (let ((v1 (dbg-info-vector/blocks-vector (comment-text s1)))
+ (v2 (dbg-info-vector/blocks-vector (comment-text s2))))
+ (let ((e1 (vector-length v1))
+ (e2 (vector-length v2)))
+ (if (= e1 e2)
+ (compare-blocks (vector-ref v1 0) (vector-ref v2 0))
+ `(number-of-blocks ,e1 ,e2))))
+ '(block-structure))
+ (if (and (comment? s2) (dbg-info-vector? (comment-text s2)))
+ '(block-structure)
+ (compare-blocks (compiled-code-address->block s1)
+ (compiled-code-address->block s2)))))))
(define (show-differences f1 f2)
(define (->name f)
(for-each display
(list "*** Files " (->name f1)
" and " (->name f2)
- " differ : "))
- (if (and (eq? 'CONSTANTS (car result))
- (> (length result) 2))
+ " differ: "))
+ (if (eq? 'CONSTANTS (car result))
(begin
(display "***")
(newline)
- (display "(CONSTANTS")
+ (display "(constants")
(for-each (lambda (c)
(newline)
- (display " ")
+ (display " ")
(write c))
(cdr result))
- (newline)
(display ")"))
(begin
(write result)
- (display " ***")))))))
+ (display " ***")))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff