perm filename VHASH[LST,LMM] blob
sn#060156 filedate 1973-08-29 generic text, type T, neo UTF8
(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ")
T)
(LISPXPRIN1 (QUOTE " 1-FEB-73 23:20:51")
T)
(LISPXTERPRI T))
(DEFINEQ
(VHASHSET
[LAMBDA NIL
(SETQ HCNILARRAY (CONS (HARRAY 100)
2.0))
(SETQ HCARRAY (CONS (HARRAY 100)
2.0))
(SETQ HNLARRAY (ARRAY 32))
(MAPC (QUOTE (1.0 10000 ""))
(FUNCTION (LAMBDA (X)
(SETA HNLARRAY (NTYP X)
(LIST X])
(HCONS
[LAMBDA (X Y)
(COND
[(NULL Y)
(OR (GETHASH X HCNILARRAY)
(PROG ((E (LIST X)))
(PUTHASH X E HCNILARRAY)
(RETURN E]
(T (PROG ((D (GETHASH Y HCARRAY))
E)
(COND
((NULL D)
(PUTHASH Y (LIST (SETQ D (CONS X Y)))
HCARRAY)
(RETURN D))
((SETQ E (FASSOC X D))
(RETURN E))
(T (FRPLACD D (CONS (SETQ E (CONS X Y))
(CDR D)))
(RETURN E])
(HNONL
[LAMBDA (E)
(PROG (L M)
(COND
([SETQ M (MEMBER E (SETQ L (ELT HNLARRAY (NTYP E]
(RETURN (CAR M)))
(L (FRPLACD L (CONS E (CDR L)))
(RETURN E))
(T (HELP])
(HCONSP
[LAMBDA (E)
(COND
[(NLISTP E)
(OR (LITATOM E)
(SMALLP E)
(FMEMB E (ELT HNLARRAY (NTYP E]
((NULL (CDR E))
(EQ (GETHASH (CAR E)
HCNILARRAY)
E))
(T (EQ (FASSOC (CAR E)
(GETHASH (CDR E)
HCARRAY))
E])
(HLIST
[LAMBDA K
(PROG (L (N K))
LP (COND
((ZEROP N)
(RETURN L)))
(SETQ L (HCONS (ARG K N)
L))
(SUB1VAR N)
(GO LP])
(HCOPY
[LAMBDA (E)
(COND
[(NLISTP E)
(COND
((OR (LITATOM E)
(SMALLP E))
E)
(T (HNONL E]
((HCONSP E)
E)
(T (HCONS (HCOPY (CAR E))
(AND (SETQ E (CDR E))
(HCOPY E])
(HSUBLIS
[LAMBDA (LIS X)
(COND
[(NLISTP X)
(COND
((LITATOM X)
(COND
((SETQ LIS (FASSOC X LIS))
(CDR LIS))
(T X)))
((SMALLP X)
X)
(T (HNONL X]
(T (HCONS (HSUBLIS LIS (CAR X))
(AND (SETQ X (CDR X))
(HSUBLIS LIS X])
(MK1
[LAMBDA (OP L)
(HCONS OP (HCOPY L])
(MK1*
[LAMBDA K
(PROG ((J K)
L)
LP [COND
((EQ J 1)
(RETURN (HCONS (ARG K 1)
L]
(SETQ L (HCONS (HCOPY (ARG K J))
L))
(SUB1VAR J)
(GO LP])
(GSTART
[LAMBDA NIL
(SETQ *MARKER*(CONS T (GENSYM])
(RMARK
[LAMBDA (E)
(COND
((NOT (MARK E))
(RMARK (CAR E))
(RMARK (CDR E])
(MARK
[LAMBDA (E)
(COND
((NLISTP E))
[(NULL (CDR E))
(PROG ((D (GETHASH (CAR E)
HCNILARRAY)))
(RETURN (COND
((FMEMB *MARKER* D))
(D (PUTHASH (CAR E)
(CONS *MARKER* E)
HCNILARRAY)
NIL]
(T (PROG ((D (GETHASH (CDR E)
HCARRAY))
M N S)
(COND
[(NULL (SETQ M (FMEMB *MARKER* D)))
(NCONC D (SETQ M (LIST *MARKER*]
((FMEMB E (CDR M))
(RETURN T)))
(COND
[(NULL (SETQ N (FMEMB E D]
((EQ (SETQ S (CDR N))
M)
(FRPLACA M E)
(FRPLACA N *MARKER*))
(T (FRPLACA N (CAR S))
(FRPLACD N (CDR S))
(FRPLACA S E)
(FRPLACD S (CDR M))
(FRPLACD M S)))
(RETURN NIL])
(GSWEEP
[LAMBDA NIL
(MAPCAR
(QUOTE (HCNILARRAY HCARRAY))
(FUNCTION (LAMBDA (NAME)
(PROG ((N 0)
(M 0)
(Z (CAR NAME))
S)
(SETQ S (ARRAYSIZE (CAR Z)))
[MAPHASH1
Z
(FUNCTION (LAMBDA (P)
(PROG ((L (CAR P)))
(COND
(L (SETQ M (ADD1 M))
(COND
((SETQ L (CDR (FMEMB *MARKER* L)))
(SETQ N (ADD1 N))
(FRPLACA P L))
(T (PUTHASH (CDR P)
NIL Z]
[COND
((ILESSP N (QUOTIENT S 4))
(SETQ N (CONS (HARRAY (ITIMES N 2))
(CDR Z)))
(REHASH (CAR Z)
(CAR N))
(FRPLACA Z (CAR N]
(RETURN (LIST NAME N M S])
)
(LISPXPRINT (QUOTE VHASHFNS)
T)
(RPAQQ VHASHFNS
(VHASHSET HCONS HNONL HCONSP HLIST HCOPY HSUBLIS MK1 MK1*
GSTART RMARK MARK GSWEEP))
(LISPXPRINT (QUOTE VHASHVARS)
T)
[RPAQQ VHASHVARS ((BLOCKS (MARKBLOCK MARK RMARK (ENTRIES RMARK))
(HSUBBLOCK HSUBLIS (ENTRIES HSUBLIS)))
(ADDVARS (GLOBALVARS *MARKER* HCARRAY HCNILARRAY))
(P (ENDLOAD (QUOTE VHASH]
(DECLARE
(BLOCK: MARKBLOCK MARK RMARK (ENTRIES RMARK))
(BLOCK: HSUBBLOCK HSUBLIS (ENTRIES HSUBLIS))
) (ADDTOVAR GLOBALVARS *MARKER* HCARRAY HCNILARRAY)
(ENDLOAD (QUOTE VHASH))
STOP