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 |
|
|