DataMuseum.dk

top - metrics - download

    Length: 3909 (0xf45)
    Types: TextFile
    Names: »equals.scm.3«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/equals.scm.3« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 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.
;;;

;;;; Equality

(declare (usual-integrations))
\f


;;; EQV? is finer than EQUAL?, but not so fine as EQ?.  EQV? should be
;;; true for two bignums of the same magnitude, or two character strings
;;; with the same characters, but not in general for two lists with the
;;; same elements.  The general rule is that EQV? is equality for
;;; apparently atomic objects; such objects include both atomic objects
;;; and compound objects with immutable components, or mutable objects
;;; that are EQ?.

(define eqv?)
(define equal?)

(let ((&= (make-primitive-procedure '&=))
      (string-equal? (make-primitive-procedure 'STRING-EQUAL?)))

(declare (compilable-primitive-functions &= string-equal?))

(define ((make-comparator table) x y)
  (disjunction (eq? x y)
	       (conjunction (primitive-type? (primitive-type x) y)
			    ((vector-ref table (primitive-type x)) x y))))

(define (make-comparator-table default . initializations)
  (let ((table (vector-cons number-of-microcode-types default)))
    (let loop ((entries initializations))
      (if (null? entries)
	  table
	  (sequence (vector-set! table
				 (microcode-type (car (car entries)))
				 (cdr (car entries)))
		    (loop (cdr entries)))))))

(define (always-true x y)
  #!TRUE)

(define (always-false x y)
  #!FALSE)
\f


(define (equal-list? x y)
  (conjunction (equal? (car x) (car y))
	       (equal? (cdr x) (cdr y))))

(define (equal-vector? x y)
  (let ((size (vector-size x)))
    (if (&= size (vector-size y))
	(let loop ((index 0))
	  (cond ((&= index size) #!TRUE)
		((equal? (vector-ref x index)
			 (vector-ref y index))
		 (loop (1+ index)))
		(else #!FALSE)))
	#!FALSE)))

(set! eqv?
      (make-comparator
       (make-comparator-table always-false
			      (cons 'NULL always-true)
			      ;; (cons 'FALSE always-true)
			      (cons 'TRUE always-true)
			      (cons 'FIXNUM &=)
			      (cons 'BIG-FIXNUM &=)
			      (cons 'BIG-FLONUM &=)
			      (cons 'CHARACTER-STRING string-equal?))))

(set! equal?
      (make-comparator
       (make-comparator-table always-false
			      (cons 'NULL always-true)
			      ;; (cons 'FALSE always-true)
			      (cons 'TRUE always-true)
			      (cons 'FIXNUM &=)
			      (cons 'BIG-FIXNUM &=)
			      (cons 'BIG-FLONUM &=)
			      (cons 'CHARACTER-STRING string-equal?)
			      (cons 'LIST equal-list?)
			      (cons 'VECTOR equal-vector?))))

)