;;; -*- Mode: LISP; Package: USER; Base: 10.; fonts:(cptfontb) -*-

;;; $Header: /ct/ctlisp/cthash.l,v 1.7 84/06/19 23:22:33 alex Exp $
;;; $Log:	/ct/ctlisp/cthash.l,v $
;;;Revision 1.7  84/06/19  23:22:33  alex
;;;Fix the problem of the Maclisp array stuff.
;;;
;;;Revision 1.6  83/08/07  17:10:39  mark
;;;Same as previous version, trying to get it checked in frozen.
;;;
;;;Revision 1.5  83/08/07  17:08:37  mark
;;;Same as previous version.  Checkin to ensure it becomes frozen.
;;;
;;;Revision 1.4  83/07/04  01:11:17  mark
;;;
;;; Fixed incompatible "//" to be "!/" so as to correct Franz bug.
;;;
;;;
;;;Revision 1.3  83/07/04  00:40:44  mark
;;; This version has been compiled and tested on both dialects.
;;; There are no substantive changes to the original code.
;;; A few comments were added here and there and some formatting
;;; was done.  -- mlm
;;; 
;;;Revision 1.2  83/07/03  19:02:43  mark
;;; Intermediate version -- session interrupted.  It has been left in
;;; a consistent state, with only some comments and such modified.  mlm.
;;;
;;;Revision 1.1  83/06/27  16:12:18  penny
;;; Initial revision
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                              CT_HASH                             ;;;
;;; John Shelton                                            June 83  ;;;
;;;                                                                  ;;;
;;; Originally written in support of Ada Generic IO, these hashtable ;;;
;;; routines may be of general interest.  --mlm.                     ;;;
;;;                                                                  ;;;
;;;     "I was afraid it would come to this.  The hashing fun(s) on  ;;;
;;; the LispM are not quite right; neither are they in Franz lisp.   ;;;
;;; Thus, they are implemented here.  Syntax similar to LM manual.   ;;;
;;;     Hash tables here are implemented as arrays.  The size of the ;;;
;;; array is the size of the table.  Hash tables do not grow         ;;;
;;; automatically; instead, a GROW function is called.  The initial  ;;;
;;; application of this code demands a table that never grows, but   ;;;
;;; does something entirely different when full.                     ;;;
;;;     Franz uses maclisp style arrays.  Therefore, we use maclisp  ;;;
;;; style arrays in the lisp machine version, too.  This causes      ;;;
;;; some minor overhead, but makes the two versions compatible.      ;;;
;;; 'Compatibility is good.' (as taken from E. Faber.)               ;;;
;;;     Items are stored in the array as a cons of the key and the   ;;;
;;; value.  An empty slot in the array is easily identified because  ;;;
;;; it is NIL.  Functions that return a hash value always return     ;;;
;;; the cons (or NIL); this allows nil keys and nil values to be     ;;;
;;; used without confusion.  If you retrieve a value, it will only   ;;;
;;; be NIL if there is no value.  If the really true value is NIL,   ;;;
;;; you will get back (<key> . NIL).  Some caution should be         ;;;
;;; exercised; wantonly taking the CDR of a retrieved value will     ;;;
;;; obscure the NIL from the NIL.  (Har har.)                        ;;;
;;;     A hash table has some additional information associated with ;;;
;;; it.  The size of the array is known, and the function to call    ;;;
;;; if the table is full.  Normally, for pure LISPM code, these      ;;;
;;; things would be stored in an array leader, but since this code   ;;;
;;; must run in Franz Lisp as well, we have to resort to some        ;;;
;;; kludges."  -- john                                               ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer * Thought Corporation.    ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Foderaro and Sklower, The FRANZ LISP Manual, September 1981.   ;;;
;;;   Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981.   ;;;
;;;   Charniak et al., 1980.  Artificial Intelligence Programming.   ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;                                                                  ;;;
;;;	        ASSUMES CT_LOAD AND SUITABLE FILEMAP                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(eval-when (compile load eval)
	   (ct_load 'charmac))		  ;CT char set extensions.

(eval-when (compile load eval) (ct_load 'aip))	  ;AIP macros pkg. 

(eval-when (compile load eval) (ct_load 'compat)) ;Franz/LM compat pkg.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros -- 

;;;  (<array> <array-size> <grow-function> <owner> <max-key>)

;;;  Extracts the real array from a hash table.
(defun ht_array (ht)
  (car ht))

;;;  Extracts the size of the array from a hash table.
(defun ht_size (ht)
  (cadr ht))

;;;  Extracts the grow function from a hash table.
(defun ht_grow (ht)
  (caddr ht))

;;;  Extracts the OWNER of the table.  This is used in Ada's direct-io
;;;  package as a pointer to the file object owning the hash table.
(defun ht_owner (ht) (cadddr ht))

;;;  Extracts the maximum key value used to store in the table.
(defun ht_max_key (ht) (caddddr ht))

;;;  Creates a new hash table, returning it.  Choose a size that is a
;;;  prime multiple of 16, if you can.  That will make things hash
;;;  better.  Make-array (in Z-lisp) returns an array already
;;;  initialized to nil for you.
(defun ct_make_hash_table (size grow_fn owner)
    (let ((name (gensym)))
	 #+lispm (setq name (make-array size))
	 #+franz (*array name t size)
	 (list name
	       size
	       grow_fn
	       owner
	       0)))		 ;initial max key is 0

;;;  Clears out the hash table.  Sort of cheats to do it, by replacing
;;;  the array with a new one.  There are other ways to do this, of course.
(defun ct_clrhash (table)
  #+franz (*array (ht_array table) t (ht_size table))
  #+lispm  (%= (car table) (make-array (ht_size table)))
  (rplaca (cddddr table) 0))

;;; continued --


;;; Externally callables, cont'd --

;;;  Installs a new entry in the hash table.  If the table is full,
;;;  calls the grow function (which should make the table non-full
;;;  somehow) and then retries.  We don't actually get the table REALLY
;;;  full; we merely try to get it largely full.
(defun ct_puthash (key value table)
  (loop for i from 0 to (!/ (ht_size table) 2)
	with size = (ht_size table)
	with j = (ct_hash key size)
	with array = (ht_array table)
	do (cond ((or (null #+franz
			    (apply array (list (remainder (+ i j) size)))
			    #+lispm
			    (aref array
				  (remainder (+ i j) size))
			    )
		      (= (car
			   #+franz
			   (apply array (list (remainder (+ i j) size)))
			   #+lispm
			   (aref array
				  (remainder (+ i j) size))
			   )
			 key))
		  (rplaca (cddddr table) (max key (ht_max_key table)))
	  #+franz (eval `(store (,array ,(remainder (+ i j) size))
				',(cons key value)))
	  #+lispm (eval `(aset ',(cons key value)
					',array
					,(remainder (+ i j) size)))

		  (return t)))
	finally (funcall (ht_grow table) table)
	finally (ct_puthash key value table)))

;;;  Locates a value in the hash table, if possible.
(defun ct_gethash (key table)
  (loop for i from 0 to (1- (ht_size table))
	with size = (ht_size table)
	with j = (ct_hash key size)
	with array = (ht_array table)
	do (cond (#+franz
		  (equal (car (apply array
				     (list (remainder (+ i j) size)))) key)
		  #+lispm
		  (equal (car (aref array (remainder (+ i j) size)))
					  key)
		  
		  (return #+franz (apply array (list (remainder (+ i j) size)))
			  #+lispm (aref array (remainder (+ i j) size))
			  ))
		 (#+franz (null (car (apply array
					    (list (remainder (+ i j) size)))))
		  #+lispm (null (aref array (remainder (+ i j) size)))
		  (return nil)))
	finally (return nil)))

;;;  A simple hashing function:  We want numbers near each other to hash
;;;  to different values.  This might be improved some time.
(defun ct_hash (key size)
  (remainder key size))

;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;