home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / link / lp_table.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  3.0 KB  |  94 lines
  1. (herald lp-table
  2.   (env tsys))
  3.  
  4. ;;; a simple table package using a linear probing hash algorithm.
  5.  
  6. ;;; Evens are objects; odds are assocs.
  7.  
  8.  
  9. ;;; Nil is not a possible entry in a table.
  10.  
  11. ;;; (vref t *jtable-len*) = (gc-stamp) of last time
  12.  
  13.  
  14. (lset *max-chain-size* 100)
  15.  
  16. (define-integrable (lp-hash obj)
  17.   (let ((n (descriptor->fixnum obj)))
  18.     (fx-xor (fx-xor (fx-and n 255)
  19.                     (fx-ashl (fx-and n 255) 3))
  20.             (fx-xor (fixnum-ashr n 7)
  21.                     (fx-xor (fx-ashl n 6) (fx-ashr n 16))))))
  22.  
  23. (define-structure-type %lp-table
  24.   id
  25.   vector
  26.   stamp
  27.   count
  28.   (((setter self)
  29.     (lambda (obj val) (set-lp-table-entry table obj val)))
  30.    ((get-vector self)
  31.     (%lp-table-vector self))
  32.    ((print-type-string self) "LP-table")
  33.    ((identification self) 'make-lp-table)))
  34.  
  35.  
  36. (define (make-lp-table size . id)
  37.   (let* ((len   (fx- (fixnum-expt 2 (fixnum-howlong size)) 2))
  38.          (table (make-%lp-table)))
  39.     (set (%lp-table-id table) (car id))
  40.     (set (%lp-table-count table) 0)
  41.     (set (%lp-table-stamp table) (gc-stamp))
  42.     (set (%lp-table-vector table) (vector-fill (make-vector len) nil))
  43.     table))
  44.  
  45. (define (lp-table-entry table obj)
  46.   (let* ((v   (%lp-table-vector table))
  47.          (len (vector-length v)))
  48.     (iterate loop ((index (fx-and (lp-hash obj) len)))
  49.       (let ((slot (vref v index)))
  50.         (cond ((null? slot) nil)
  51.               ((eq? slot obj)
  52.                (vref v (fx+ index 1)))
  53.               (else
  54.                (let ((next (fx+ index 2)))
  55.                  (loop (if (fx>= next len) 0 next)))))))))
  56.  
  57. (define (set-lp-table-entry table obj val)
  58.   (let* ((v     (%lp-table-vector table))
  59.          (len   (vector-length v))
  60.          (start (fx-and (lp-hash obj) len)))
  61.     (iterate loop ((index start) (chain-size 0))
  62.       (let* ((index (if (fx>= index len) 0 index))
  63.              (slot  (vref v index)))
  64.         (cond ((null? slot)
  65.                (set (vref v index) obj)
  66.                (set (vref v (fx+ index 1)) val))
  67.               ((eq? slot obj)
  68.                (error "resetting slot (~s ~s)" obj val))
  69.                ;++(set (vref v (fx+ index 1)) val))
  70.               ((fx> chain-size *max-chain-size*)
  71.                (rehash-lp-table table)
  72.                (set-lp-table-entry table obj val))
  73.               (else
  74.                (loop (fx+ index 2) (fx+ chain-size 1))))))
  75.     (set (%lp-table-count table) (fx+ 1 (%lp-table-count table)))))
  76.  
  77.  
  78. (define (rehash-lp-table table)
  79.   (format t "** Warning: rehashing table ~a ..." table)
  80.   (let* ((ov   (%lp-table-vector table))
  81.          (olen (vector-length ov))
  82.          (len  (fx- (fixnum-expt 2 (fx+ (fixnum-howlong olen) 1)) 2))
  83.          (v    (vector-fill (make-vector len) nil)))
  84.     (set (%lp-table-vector table) v)
  85.     (iterate loop ((i 0))
  86.       (cond ((fx>= i olen))
  87.             (else
  88.              (let ((obj (vref ov i)))
  89.                (if obj (set-lp-table-entry table
  90.                                            obj
  91.                                            (vref ov (fx+ i 1))))
  92.                (loop (fx+ i 2))))))
  93.     (format t "(~a ~a ~a ~a) done.~%" olen ov len v)))
  94.