*** src/utils/rename-for-clisp.orig	Wed Oct 13 20:27:23 1993
--- src/utils/rename-for-clisp	Fri Jul  1 23:51:15 1994
***************
*** 2,13 ****
  #
  # Provided by Bruno Haible <haible@ma2s2.mathematik.uni-karlsruhe.de>
  #
! # Renames the files to CLISP conventions:
! # .lsp for lisp source, .txt for miscellaneous text
  
  for d in . aggregadgets c32 debug demos gadgets gesture gilt inter kr \
!          lapidary opal ps utils contrib contrib/graph-editor \
!          contrib/multi-garnet contrib/prompter contrib/xpm
  do
  (cd $d
  for f in *.lisp
--- 2,11 ----
  #
  # Provided by Bruno Haible <haible@ma2s2.mathematik.uni-karlsruhe.de>
  #
! # Renames the files to CLISP conventions: .lsp for lisp source
  
  for d in . aggregadgets c32 debug demos gadgets gesture gilt inter kr \
!          lapidary opal ps utils contrib contrib/graph-editor contrib/prompter
  do
  (cd $d
  for f in *.lisp
*** src/garnet-loader.lisp.orig	Wed Oct 13 20:27:24 1993
--- src/garnet-loader.lisp	Sat Jul  2 00:06:03 1994
***************
*** 54,60 ****
  #|
  ============================================================
  Change log:
!  9/22/93 Bruno Haible - Added FLET for merge-pathnames in CLISP
   8/13/93 Andrew Mickish - Added user::Garnet-Readtable
   8/12/93 Andrew Mickish - Closed display in Verify-Display-Can-Be-Opened;
             added #+garnet-processes to *features* list
--- 54,60 ----
  #|
  ============================================================
  Change log:
!  9/22/93 Bruno Haible - Added FLET for merge-pathnames in KCL
   8/13/93 Andrew Mickish - Added user::Garnet-Readtable
   8/12/93 Andrew Mickish - Closed display in Verify-Display-Can-Be-Opened;
             added #+garnet-processes to *features* list
***************
*** 143,148 ****
--- 143,158 ----
      (pushnew :garnet-debug *features*)
      (setf *features* (delete :garnet-debug *features*)))
  
+ ;;; The :GARNET-BINS option controls whether
+ ;;; T - Garnet uses its own kind of do-it-yourself hash tables called "bins" or
+ ;;; NIL - it uses the system's hash tables
+ ;;; at the kernel of the KR system.
+ ;;; Choose T for implementations that compile to machine code and have slow
+ ;;; hash tables. Choose NIL for implementations like CLISP which have fast
+ ;;; hash tables.
+ #-CLISP
+ (pushnew :GARNET-BINS *features*)
+ 
  ;;; The :GARNET-PROCESSES keyword goes on the *features* list if this version
  ;;; of lisp supports multiple processes.  Then things like the animation
  ;;; interactor can use the #+garnet-processes switch, instead of referring
***************
*** 424,430 ****
  (defvar Garnet-Gesture-Data-Pathname
    (merge-pathnames "gesture/" Garnet-Lib-Pathname))
  
!   ) ; Close CLISP's flet
  
  ;;;----------------------------------------------------------
  
--- 434,440 ----
  (defvar Garnet-Gesture-Data-Pathname
    (merge-pathnames "gesture/" Garnet-Lib-Pathname))
  
!   ) ; Close KCL's flet
  
  ;;;----------------------------------------------------------
  
*** src/kr/kr-macros.lisp.orig	Wed Oct 13 20:25:17 1993
--- src/kr/kr-macros.lisp	Sat Jul  2 00:30:22 1994
***************
*** 145,154 ****
  
  
  (eval-when (compile load eval)
!   (defparameter *bins-length* 8))
  
  
  (eval-when (compile load eval)
    (defvar *store-lambdas* T
      "If NIL, lambda expressions are not stored in formulas"))
  
--- 145,163 ----
  
  
  (eval-when (compile load eval)
!   (defmacro defparam (&rest body)
!     #+(or GARNET-DEBUG (not CLISP)) `(defparameter ,@body)
!     ;; Get more speed out of clisp by using constants
!     #+(and (not GARNET-DEBUG) CLISP) `(defconstant ,@body)
!     ))
  
  
+ #+GARNET-BINS
  (eval-when (compile load eval)
+   (defparam *bins-length* 8))
+ 
+ 
+ (eval-when (compile load eval)
    (defvar *store-lambdas* T
      "If NIL, lambda expressions are not stored in formulas"))
  
***************
*** 273,279 ****
    "List of slots that should be printed when printing schemata as structures.")
  
  
! (defvar *no-value* '(:no-value)
    "A cons cell which is used to mark the value of non-existent slots.")
  
  
--- 282,288 ----
    "List of slots that should be printed when printing schemata as structures.")
  
  
! (defparam *no-value* '(:no-value)
    "A cons cell which is used to mark the value of non-existent slots.")
  
  
***************
*** 283,320 ****
  
  
  (eval-when (eval compile load)
!   (defparameter *type-bits* 10)  ;; # of bits for encoding type
  
!   (defparameter *type-mask* (1- (expt 2 *type-bits*))) ;; to extract type
  
    ;; bit is 1 if slot contains inherited values, 0 for local values
!   (defparameter *inherited-bit*          *type-bits*)
    ;; bit is 1 if any other schema inherited the value from here
!   (defparameter *is-parent-bit*          (1+ *inherited-bit*))
!   (defparameter *is-constant-bit*        (1+ *is-parent-bit*))
!   (defparameter *is-update-slot-bit*     (1+ *is-constant-bit*))
!   (defparameter *is-local-only-slot-bit* (1+ *is-update-slot-bit*))
!   (defparameter *is-parameter-slot-bit*  (1+ *is-local-only-slot-bit*)))
  
  
  (eval-when (eval compile load)
!   (defparameter *local-mask* 0)
!   (defparameter *constant-mask* (ash 1 *is-constant-bit*))
!   (defparameter *is-update-slot-mask* (ash 1 *is-update-slot-bit*))
!   (defparameter *inherited-mask* (ash 1 *inherited-bit*))
!   (defparameter *is-parent-mask* (ash 1 *is-parent-bit*))
  
!   (defparameter *clear-slot-mask*
      (logior *local-mask* *type-mask* *constant-mask* *is-update-slot-mask*))
  
!   (defparameter *inherited-parent-mask*
      (logior *inherited-mask* *is-parent-mask*))
!   (defparameter *not-inherited-mask* (lognot *inherited-mask*))
!   (defparameter *not-parent-mask* (lognot *is-parent-mask*))
!   (defparameter *not-parent-constant-mask*
      (lognot (logior *is-parent-mask* *constant-mask*)))
  
!   (defparameter *all-bits-mask* (lognot *type-mask*)))
  
  
  (defvar *check-constants* NIL
--- 292,329 ----
  
  
  (eval-when (eval compile load)
!   (defparam *type-bits* 10)  ;; # of bits for encoding type
  
!   (defparam *type-mask* (1- (expt 2 *type-bits*))) ;; to extract type
  
    ;; bit is 1 if slot contains inherited values, 0 for local values
!   (defparam *inherited-bit*          *type-bits*)
    ;; bit is 1 if any other schema inherited the value from here
!   (defparam *is-parent-bit*          (1+ *inherited-bit*))
!   (defparam *is-constant-bit*        (1+ *is-parent-bit*))
!   (defparam *is-update-slot-bit*     (1+ *is-constant-bit*))
!   (defparam *is-local-only-slot-bit* (1+ *is-update-slot-bit*))
!   (defparam *is-parameter-slot-bit*  (1+ *is-local-only-slot-bit*)))
  
  
  (eval-when (eval compile load)
!   (defparam *local-mask* 0)
!   (defparam *constant-mask* (ash 1 *is-constant-bit*))
!   (defparam *is-update-slot-mask* (ash 1 *is-update-slot-bit*))
!   (defparam *inherited-mask* (ash 1 *inherited-bit*))
!   (defparam *is-parent-mask* (ash 1 *is-parent-bit*))
  
!   (defparam *clear-slot-mask*
      (logior *local-mask* *type-mask* *constant-mask* *is-update-slot-mask*))
  
!   (defparam *inherited-parent-mask*
      (logior *inherited-mask* *is-parent-mask*))
!   (defparam *not-inherited-mask* (lognot *inherited-mask*))
!   (defparam *not-parent-mask* (lognot *is-parent-mask*))
!   (defparam *not-parent-constant-mask*
      (lognot (logior *is-parent-mask* *constant-mask*)))
  
!   (defparam *all-bits-mask* (lognot *type-mask*)))
  
  
  (defvar *check-constants* NIL
***************
*** 373,417 ****
  #+EAGER
  (eval-when (eval compile load)
    ;; bit is 1 if formula is part of a cycle, 0 otherwise
!   (defparameter *cycle-bit* 0)
    ;; bit is 1 if formula is on the evaluation queue, 0 otherwise
!   (defparameter *eval-bit* 1)
    ;; bit is 1 if the formula has been visited during a depth-first
    ;; search, 0 otherwise
!   (defparameter *visited-bit* 2)
    ;; bit is 1 if the formula's priority has been renumbered during the
    ;; renumbering of a cycle, 0 otherwise
!   (defparameter *renumber-bit* 3)
    ;; count keeps track of how many times the formula has been evaluated and
    ;; is called the formula's timestamp
!   (defparameter *fixed-bit* 4)
    ;; indicates if formula's value is fixed on this iteration of the constraint
    ;; solver and thus should not be reevaluated
  
!   (defparameter *count-bit* 5)
!   (defparameter *neg-count-bit* (- *count-bit*))
  
    ;;; Bits in a dependency structure.
    ;; bit is 1 if the dependency is part of a cycle, 0 otherwise
!   (defparameter *cycle-edge-bit* 0)
    ;; the status of a dependency is indicated by a timestamp. if the
    ;; timestamp is greater than or equal to the timestamp in the dependency's
    ;; formula, the dependency is valid; otherwise the dependency is invalid
!   (defparameter *status-bit* 1)
!   (defparameter *neg-status-bit* (- *status-bit*)))
  
  
  
  #+EAGER
  (eval-when (eval compile load)
!   (defparameter *cycle-mask* (ash 1 *cycle-bit*))
!   (defparameter *eval-mask* (ash 1 *eval-bit*))
!   (defparameter *visited-mask* (ash 1 *visited-bit*))
!   (defparameter *renumber-mask* (ash 1 *renumber-bit*))
!   (defparameter *fixed-mask* (ash 1 *fixed-bit*))
!   (defparameter *count-mask* (ash 1 *count-bit*))
!   (defparameter *status-mask* (ash 1 *status-bit*))
!   (defparameter *cycle-edge-mask* (ash 1 *cycle-edge-bit*)))
  
  
  
--- 382,426 ----
  #+EAGER
  (eval-when (eval compile load)
    ;; bit is 1 if formula is part of a cycle, 0 otherwise
!   (defparam *cycle-bit* 0)
    ;; bit is 1 if formula is on the evaluation queue, 0 otherwise
!   (defparam *eval-bit* 1)
    ;; bit is 1 if the formula has been visited during a depth-first
    ;; search, 0 otherwise
!   (defparam *visited-bit* 2)
    ;; bit is 1 if the formula's priority has been renumbered during the
    ;; renumbering of a cycle, 0 otherwise
!   (defparam *renumber-bit* 3)
    ;; count keeps track of how many times the formula has been evaluated and
    ;; is called the formula's timestamp
!   (defparam *fixed-bit* 4)
    ;; indicates if formula's value is fixed on this iteration of the constraint
    ;; solver and thus should not be reevaluated
  
!   (defparam *count-bit* 5)
!   (defparam *neg-count-bit* (- *count-bit*))
  
    ;;; Bits in a dependency structure.
    ;; bit is 1 if the dependency is part of a cycle, 0 otherwise
!   (defparam *cycle-edge-bit* 0)
    ;; the status of a dependency is indicated by a timestamp. if the
    ;; timestamp is greater than or equal to the timestamp in the dependency's
    ;; formula, the dependency is valid; otherwise the dependency is invalid
!   (defparam *status-bit* 1)
!   (defparam *neg-status-bit* (- *status-bit*)))
  
  
  
  #+EAGER
  (eval-when (eval compile load)
!   (defparam *cycle-mask* (ash 1 *cycle-bit*))
!   (defparam *eval-mask* (ash 1 *eval-bit*))
!   (defparam *visited-mask* (ash 1 *visited-bit*))
!   (defparam *renumber-mask* (ash 1 *renumber-bit*))
!   (defparam *fixed-mask* (ash 1 *fixed-bit*))
!   (defparam *count-mask* (ash 1 *count-bit*))
!   (defparam *status-mask* (ash 1 *status-bit*))
!   (defparam *cycle-edge-mask* (ash 1 *cycle-edge-bit*)))
  
  
  
***************
*** 776,786 ****
--- 785,797 ----
  ;;; -------------------------------------------------- Low-level slot access
  
  
+ #+GARNET-BINS
  (defparameter *bin-indices* (make-array 256)
    "From the first character of a slot name, get the index to the corresponding
    slots bin.")
  
  
+ #+GARNET-BINS
  (defparameter *bin-layout* '(	( #\J  #\Y  #\F )
    				( #\K  #\N  #\A  #\B )
    				( #\G  #\M  #\P )
***************
*** 795,805 ****
--- 806,818 ----
  
  
  ;; First assign all letters random bins
+ #+GARNET-BINS
  (dotimes (i 256)
    (setf (svref *bin-indices* i) (mod i *bins-length*)))
  
  
  ;; Then place all the letters in the *bin-layout* where they belong.
+ #+GARNET-BINS
  (when *bin-layout*
    (let ((bin 0))
      (dolist (bin-letters *bin-layout*)
***************
*** 809,814 ****
--- 822,828 ----
  
  
  
+ #+GARNET-BINS
  (defmacro slot-to-bin-index (slot)
    (if (keywordp slot)
      `(svref *bin-indices* ,(char-code (schar (symbol-name slot) 0)))
***************
*** 828,837 ****
  ;;; RETURNS: a slot structure, or NIL.
  ;;;
  (defmacro slot-accessor (schema slot)
    (let ((entry (gensym)))
      `(dolist (,entry (svref (schema-bins ,schema) (slot-to-bin-index ,slot)))
        (if (eq (sl-name ,entry) ,slot)
! 	(return ,entry)))))
  
  
  
--- 842,855 ----
  ;;; RETURNS: a slot structure, or NIL.
  ;;;
  (defmacro slot-accessor (schema slot)
+   #+GARNET-BINS
    (let ((entry (gensym)))
      `(dolist (,entry (svref (schema-bins ,schema) (slot-to-bin-index ,slot)))
        (if (eq (sl-name ,entry) ,slot)
! 	(return ,entry))))
!   #-GARNET-BINS
!   `(values (gethash ,slot (schema-bins ,schema)))
!   )
  
  
  
***************
*** 841,846 ****
--- 859,865 ----
  ;;; modified to be a full-slot structure.
  ;;;
  (defmacro set-slot-accessor (schema slot value bits the-dependents)
+   #+GARNET-BINS
    (let ((the-index (gensym))
  	(the-bins (gensym))
  	(the-entry (gensym))
***************
*** 873,879 ****
  	  (if ,dependents
  	    (setf (full-sl-dependents ,the-entry) ,dependents))
  	  (push ,the-entry (svref ,the-bins ,the-index))
! 	  ,the-entry)))))
  
  
  
--- 892,927 ----
  	  (if ,dependents
  	    (setf (full-sl-dependents ,the-entry) ,dependents))
  	  (push ,the-entry (svref ,the-bins ,the-index))
! 	  ,the-entry))))
!   #-GARNET-BINS
!   (let ((the-bins (gensym))
!   	(the-entry (gensym))
!   	(dependents (gensym)))
!     `(let* ((,the-bins (schema-bins ,schema))
! 	    (,the-entry (gethash ,slot ,the-bins))
! 	    (,dependents ,the-dependents))
!        (if ,the-entry
! 	 (progn
! 	   (when (and ,dependents (not (full-sl-p ,the-entry)))
! 	     ;; Need to use a full slot, only have a short one.
! 	     (setf (gethash ,slot ,the-bins) (setf ,the-entry (make-full-sl)))
! 	     (setf (sl-name ,the-entry) ,slot))
! 	   ;; Slot is present - update it.
! 	   (setf (sl-value ,the-entry) ,value)
! 	   (setf (sl-bits ,the-entry) ,bits)
! 	   (if ,dependents
! 	     (setf (full-sl-dependents ,the-entry) ,dependents))
! 	   ,the-entry)
! 	 ;; Slot is not present - create it.
! 	 (progn
! 	   (setf ,the-entry (if ,dependents (make-full-sl) (make-sl)))
! 	   (setf (sl-name ,the-entry) ,slot)
! 	   (setf (sl-value ,the-entry) ,value)
! 	   (setf (sl-bits ,the-entry) ,bits)
! 	   (if ,dependents
! 	     (setf (full-sl-dependents ,the-entry) ,dependents))
! 	   (setf (gethash ,slot ,the-bins) ,the-entry)))))
!   )
  
  
  
***************
*** 941,946 ****
--- 989,995 ----
  (defmacro iterate-slot-value ((a-schema inherited everything check-formula-p)
  			      &body body)
    `(,@(if check-formula-p `(if (not (formula-p ,a-schema))) '(progn))
+     #+GARNET-BINS
      ;; Process all bins and all slots within.
      (let ((bins (schema-bins ,a-schema)))
        (dotimes (i *bins-length*)
***************
*** 961,967 ****
  		    ,@(if everything
  			body
  			`((unless (eq value *no-value*)
! 			    ,@body))))))))))))
  
  
  
--- 1010,1039 ----
  		    ,@(if everything
  			body
  			`((unless (eq value *no-value*)
! 			    ,@body))))))))))
!     #-GARNET-BINS
!     (maphash
!       #'(lambda (iterate-ignored-slot-name iterate-slot-value-entry)
! 	  (declare (ignore iterate-ignored-slot-name))
! 	  (let ((slot (sl-name iterate-slot-value-entry)) ; name for the slot
! 		(value (sl-value iterate-slot-value-entry)))
! 	    ;; This slot exists
! 	    ,@(if inherited
! 		;; Either local or inherited will do.
! 		(if everything
! 		  ;; Execute on a no-value, too.
! 		  body
! 		  ;; Only execute on real values.
! 		  `((unless (eq value *no-value*)
! 		      ,@body)))
! 		;; Make sure that the slot is not inherited.
! 		`((unless (is-inherited (sl-bits iterate-slot-value-entry))
! 		    ,@(if everything
! 			body
! 			`((unless (eq value *no-value*)
! 			    ,@body))))))))
!       (schema-bins ,a-schema))
!     ))
  
  
  
*** src/kr/kr.lisp.orig	Tue Oct 19 02:45:09 1993
--- src/kr/kr.lisp	Sat Jul  2 00:34:12 1994
***************
*** 84,92 ****
  ;;; Completely clear ALL the slots in the <schema>.
  ;;;
  (defun clear-schema-slots (schema)
    (let ((bins (schema-bins schema)))
      (dotimes (i *bins-length*)
!       (setf (aref bins i) NIL))))
  
  
  
--- 84,96 ----
  ;;; Completely clear ALL the slots in the <schema>.
  ;;;
  (defun clear-schema-slots (schema)
+   #+GARNET-BINS
    (let ((bins (schema-bins schema)))
      (dotimes (i *bins-length*)
!       (setf (aref bins i) NIL)))
!   #-GARNET-BINS
!   (clrhash (schema-bins schema))
!   )
  
  
  
***************
*** 2228,2233 ****
--- 2232,2238 ----
  
  
  
+ #+GARNET-BINS
  (defparameter *min-size* 0
    "Initial size for a new array of slots")
  
***************
*** 2238,2243 ****
--- 2243,2249 ----
  ;;; at least <how-many> entries.
  ;;; RETURNS: the resource, or NIL if none can be found.
  ;;;
+ #+GARNET-BINS
  (defun find-unused-resource (array how-many)
    (dotimes (i (length array))
      (let* ((slots (aref array i))
***************
*** 2257,2264 ****
  
  (defun allocate-schema-slots (schema)
    (setf (schema-bins schema)
  	(or (find-unused-resource *reuse-slots* *bins-length*)
! 	    (make-array *bins-length* :initial-element NIL)))
    schema)
  
  
--- 2263,2274 ----
  
  (defun allocate-schema-slots (schema)
    (setf (schema-bins schema)
+ 	#+GARNET-BINS
  	(or (find-unused-resource *reuse-slots* *bins-length*)
! 	    (make-array *bins-length* :initial-element NIL))
! 	#-GARNET-BINS
! 	(make-hash-table :test #'eq)
! 	)
    schema)
  
  
*** src/kr/constraints.lisp.orig	Wed Oct 13 20:25:18 1993
--- src/kr/constraints.lisp	Sat Jul  2 00:37:07 1994
***************
*** 407,417 ****
  	(setf entry (set-slot-accessor schema slot *no-value* 0 NIL)))
        (unless (full-sl-p entry)
  	;; We did have an entry, but it was too small.
! 	(let ((full-entry (make-full-sl))
! 	      (bin (svref (schema-bins schema) (slot-to-bin-index slot))))
! 	  (do ((e bin (cdr e)))
  	      ((eq (car e) entry)
  	       (setf (car e) full-entry)))
  	  (setf (sl-name full-entry) slot)
  	  (if entry
  	    (setf (sl-value full-entry) (sl-value entry)
--- 407,419 ----
  	(setf entry (set-slot-accessor schema slot *no-value* 0 NIL)))
        (unless (full-sl-p entry)
  	;; We did have an entry, but it was too small.
! 	(let ((full-entry (make-full-sl)))
! 	  #+GARNET-BINS
! 	  (do ((e (svref (schema-bins schema) (slot-to-bin-index slot)) (cdr e)))
  	      ((eq (car e) entry)
  	       (setf (car e) full-entry)))
+ 	  #-GARNET-BINS
+ 	  (setf (gethash slot (schema-bins schema)) full-entry)
  	  (setf (sl-name full-entry) slot)
  	  (if entry
  	    (setf (sl-value full-entry) (sl-value entry)
*** src/debug/objsize.lisp.orig	Wed Oct 13 20:26:13 1993
--- src/debug/objsize.lisp	Sat Jul  2 00:08:27 1994
***************
*** 124,130 ****
    (if is-formula
      (formula-bytes obj)
      (let ((size (+ schema-size
! 		   (* 4 (1+ (array-dimension (kr::schema-bins obj) 0)))))
  	  obj-isa stats)
        (kr::iterate-slot-value (obj T NIL NIL)
  	(let ((entry kr::iterate-slot-value-entry))
--- 124,133 ----
    (if is-formula
      (formula-bytes obj)
      (let ((size (+ schema-size
! 		   (* 4 (1+
! 			  #+GARNET-BINS (array-dimension (kr::schema-bins obj) 0)
! 			  #-GARNET-BINS (hash-table-count (kr::schema-bins obj))
! 			  ))))
  	  obj-isa stats)
        (kr::iterate-slot-value (obj T NIL NIL)
  	(let ((entry kr::iterate-slot-value-entry))