;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 124.48
;;; Reason:
;;;  Passing an invalid :TEST keyword value to MAKE-HASH-TABLE, as in
;;;  (make-hash-table :test "foo"), threw you into the error handler, then
;;;  again into the error handler with a buggy call to FORMAT.
;;; Written 10-Jun-88 17:34:53 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 3
;;; with Experimental System 124.44, Experimental Local-File 74.1, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.1, microcode 1756, SDU Boot Tape 3.14, SDU ROM 103.



; From modified file DJ: L.SYS2; HASHFL.LISP#74 at 10-Jun-88 17:34:54
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; HASHFL  "

(defun make-hash-table (&rest options
			&key (test #'eql testp)
			     (compare-function nil cfp) (hash-function nil hfp)
			     (size 128.) (number-of-values 1) area
			     (rehash-threshold 0.7s0) (rehash-size 1.3s0) rehash-function
			     rehash-before-cold
			     actual-size
			&aux (flavor 'generic-pointer-dependent-hash-table))
  "Create a hash table.  Keyword args are as follows:
TEST: Common Lisp way to specify the hashing and comparison functions.
 It must be EQ, EQL (the default) or EQUAL.
Instead of specifying TEST, one way specify the comparison and hasing functions
 explicitly by way of the COMPARE-FUNCTION and HASH-FUNCTION options.
 See the code for details on what these functions should do.
AREA: area to cons the table in.
SIZE: lower bound for number of entries (this may be rounded up).
 Note that the table cannot actually hold that many keys; this value merely serves
 as an approximation of the expected number of keys.
ACTUAL-SIZE: precise number of entries worth of size to use.
NUMBER-OF-VALUES: number of values to associate with each key (default 1).
 Each PUTHASH can set all the values, and GETHASH retrieves them all.
 Note that SETF of GETHASH can only set one value.
REHASH-FUNCTION: a function which accepts a hash table
 and returns a larger one.
REHASH-THRESHOLD: determines what \"fullness\" will make a growth of the hashtable
 and corresponding rehash necessary.
 Either a flonum between 0 and 1 (default 0.7), meaning that rehash occurs
 if more than that fraction full, or a fixnum, meaning rehash if more than that
 number of slots are filled. If a fixnum, it is automatically proportionally
 increased when the hashtable grows.
REHASH-SIZE: the ratio by which the default REHASH-FUNCTION
 will increase the size of the table.  By default, 1.3.
 This may also be a fixnum, in which case it determines the number of extra slots
 which are added to the hastable's size when it grows.
REHASH-BEFORE-COLD: rehash the hash-table if necessary before disk-saving"
  (check-type size (integer 1))
  (check-type number-of-values (integer 1))
  (check-type rehash-size (or (integer 1) (float (1.0))))
  (check-type rehash-threshold (or (integer 1) (float (0.0) (1.0))))
;; some sort of check is needed here
;  (assert (if (integerp rehash-threshold) (> rehash-threshold rehash-size size)
;       (ferror "rehash-threshold, ~D, is greater than rehash-size (~D)"
;	       rehash-threshold rehash-size))
  (cond (testp
	 (if (or cfp hfp)
	     (ferror "Both ~S and ~S supplied" :test (if cfp :compare-function :hash-function)))
	 (if (typep test '(or compiled-function microcode-function))
	     (setq test (function-name test)))
	 (setq test (or (assq test *hash-table-test-alist*)
			(ferror "Test ~S is not valid: should be one of ~{~S~^, ~}"
				test (mapcar #'car *hash-table-test-alist*))))
	 (setq flavor (cadr test)
	       compare-function (caddr test)
	       hash-function (cadddr test)
	       cfp (cddr test)
	       test (car test)))
	(cfp
	 (if (null compare-function)
	     (ferror "~S is ~S" :compare-function nil))
	 (if (null hfp)
	     (ferror "~S supplied without ~S" :compare-function :hash-function)))
	(hfp
	 (if (null hash-function)
	     (ferror "~S is ~S" :hash-function nil))
	 (if (null cfp)
	     (ferror "~S supplied without ~S" :hash-function :compare-function)))
	((and size actual-size)
	 (ferror "Both ~S and ~S supplied" :size :actual-size))
	(t
	 (setq flavor 'eql-hash-table)))
  (if cfp
      (make-instance flavor :compare-function compare-function :hash-function hash-function
			    :size size :number-of-values number-of-values :area area
			    :rehash-threshold rehash-threshold :rehash-size rehash-size
			    :rehash-function rehash-function :actual-size actual-size
			    :rehash-before-cold rehash-before-cold)
      (make-instance flavor :size size :number-of-values number-of-values :area area
			    :rehash-threshold rehash-threshold :rehash-size rehash-size
			    :rehash-function rehash-function :actual-size actual-size
			    :rehash-before-cold rehash-before-cold)))

))