/[gcl]/gcl/tests/hashlong.tst
ViewVC logotype

Diff of /gcl/tests/hashlong.tst

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Thu Dec 20 20:29:54 2001 UTC revision 1.2 by camm, Sun Feb 3 18:44:08 2002 UTC
# Line 0  Line 1 
1    #+CLISP (progn (setf (symbol-function 'setf-gethash)
2                         (symbol-function 'sys::puthash)) t)
3    #+CLISP t
4    
5    (DEFUN SYMBOLE ()
6      (LET ((B 0.)
7            (HASH-TABLE (MAKE-HASH-TABLE :SIZE 20. :REHASH-THRESHOLD #+XCL 15. #-XCL 0.75))
8            (LISTE (MAKE-LIST 50.))
9            (LISTE2 (MAKE-LIST 50.)))
10        (RPLACD (LAST LISTE) LISTE)
11        (RPLACD (LAST LISTE2) LISTE2)
12        (DO-SYMBOLS (X (FIND-PACKAGE #+XCL 'lisptest #-XCL "LISP"))
13    ;     (PRINT X) (FINISH-OUTPUT)
14          (COND ((CAR LISTE)
15                 (LET ((HVAL (GETHASH (CAR LISTE) HASH-TABLE))
16                       (LVAL (CAR LISTE2)))
17                   (UNLESS (EQ HVAL LVAL)
18                     (PRINT "mist, hash-tabelle kaputt")
19                     (PRINT (CAR LISTE))
20                     (PRINT HASH-TABLE)
21                     (PRINT (HASH-TABLE-COUNT HASH-TABLE))
22                     (PRINT "hval:") (PRINT HVAL)
23                     (PRINT "lval:") (PRINT LVAL)
24                     (return-from symbols 'error))
25                   (REMHASH (CAR LISTE) HASH-TABLE)
26                   #+XCL (WHEN (< (ROOM) 30000.) (SYSTEM::%GARBAGE-COLLECTION))
27                   (SETF-GETHASH X HASH-TABLE (SETQ B (+ 1. B)))
28                   (RPLACA LISTE X)
29                   (RPLACA LISTE2 B)
30                   (SETQ LISTE (CDR LISTE))
31                   (SETQ LISTE2 (CDR LISTE2))))
32                (T (SETF-GETHASH X HASH-TABLE (SETQ B (+ 1. B)))
33                   (RPLACA LISTE X)
34                   (RPLACA LISTE2 B)
35                   (SETQ LISTE (CDR LISTE))
36                   (SETQ LISTE2 (CDR LISTE2)))))))
37    symbole
38    
39    
40    (SYMBOLE) nil
41    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26