(FILECREATED "12-Dec-83 06:26:38" {PHYLUM}<LISPCORE>SOURCES>GENSYM.;24 13410
changes to: (VARS GENSYMCOMS)
(FNS ATOMHASH#PROBES \ATOM.FIRSTHASHINDEX)
previous date: " 9-Dec-83 07:03:37" {PHYLUM}<LISPCORE>SOURCES>GENSYM.;23)
(* Copyright (c) 1983 by Xerox Corporation)
(PRETTYCOMPRINT GENSYMCOMS)
(RPAQQ GENSYMCOMS ((COMS (* Put this guy on ADDARITH for Interlisp-D and on NONDADDARITH for the
other systems)
(FNS INTEGERLENGTH.DECIMAL))
(COMS (* This goes on MISC)
(FNS GENSYM \GS.INITBUF)
(CONSTANTS (\GS.BUFSIZE 100))
(INITVARS (GENNUM 0)
(\GS.OGENNUM -1)
(\GS.NUMLEN 0)
(\GS.BUF (ALLOCSTRING \GS.BUFSIZE))
(\GS.STR (ALLOCSTRING 0)))
(PROP ARGNAMES GENSYM)
(GLOBALVARS GENNUM \GS.OGENNUM \GS.NUMLEN \GS.BUF \GS.STR))
(COMS (* These are optimizations for Interlisp-D only)
(FNS ATOMHASH#PROBES \ATOM.FIRSTHASHINDEX)
(COMS (* This goes on DMISC which overrides the definition found on MISC)
(FNS GENSYM?))
(COMS (* This goes on LLBASIC as a sub-declaration of LITATOM)
(DECLARE: DONTCOPY (RECORDS PROPCELL)))
(COMS (* This goes on BYTECOMPILER)
(FNS COMP.GENFN)
(INITVARS (COMP.GENFN.NUM 0)
(COMP.GENFN.BUF (ALLOCSTRING 100)))
(GLOBALVARS COMP.GENFN.NUM COMP.GENFN.BUF)
(DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY
(P (MOVD (QUOTE COMP.GENFN)
(QUOTE \BYTECOMPBLOCK/COMP.GENFN))))))))
(* Put this guy on ADDARITH for Interlisp-D and on NONDADDARITH for the other systems)
(DEFINEQ
(INTEGERLENGTH.DECIMAL
(LAMBDA (N) (* JonL "17-NOV-83 14:28")
(if (OR (SELECTQ (SYSTEMTYPE)
(D (ILEQ N MAX.SMALLP))
NIL)
(ILESSP N (CONSTANT (EXPT 10 5))))
then (* 5 or fewer digits)
(if (ILESSP N (CONSTANT (EXPT 10 3)))
then (* 3 or fewer digits)
(if (ILESSP N (CONSTANT (EXPT 10 1)))
then (if (ILESSP N 1)
then 0
else 1)
elseif (ILESSP N (CONSTANT (EXPT 10 2)))
then 2
else 3)
elseif (ILESSP N (CONSTANT (EXPT 10 4)))
then 4
else 5)
elseif (ILESSP N (CONSTANT (EXPT 10 9)))
then (* Between 6 and 9 digits)
(if (ILESSP N (CONSTANT (EXPT 10 7)))
then (* 6 or 7 digits)
(if (ILESSP N (CONSTANT (EXPT 10 6)))
then 6
else 7)
else (if (ILESSP N (CONSTANT (EXPT 10 8)))
then 8
else 9))
else (SELECTQ (SYSTEMTYPE)
((TOPS20 TENEX)
(if (ILESSP N (CONSTANT (EXPT 10 10)))
then 10
else 11))
10))))
)
(* This goes on MISC)
(DEFINEQ
(GENSYM
(LAMBDA (PREFIX NUMSUFFIX OSTRBUFFER NEW? CHARCODE) (* JonL " 9-Dec-83 04:45")
(OR (NULL PREFIX)
(STRINGP PREFIX)
(LITATOM PREFIX)
(ERRORX (LIST 27 PREFIX)))
(OR (NULL NUMSUFFIX)
(FIXP NUMSUFFIX)
(ERRORX (LIST 27 NUMSUFFIX)))
(OR (NULL OSTRBUFFER)
(STRINGP OSTRBUFFER)
(ERRORX (LIST 27 OSTRBUFFER)))
(OR (NULL CHARCODE)
(CHARCODEP CHARCODE)
(ERRORX (LIST 27 CHARCODE)))
(PROG ((BUFSIZE \GS.BUFSIZE)
(NUMLEN \GS.NUMLEN)
(BUF \GS.BUF)
(PREFIXLEN 0)
BEG.I ATOM)
(if (OR (NULL PREFIX)
(ZEROP (SETQ PREFIXLEN (NCHARS PREFIX))))
then (SETQ PREFIX)
(if (NULL CHARCODE)
then (* Here's the default case)
(SETQ CHARCODE (CHARCODE A)))
elseif (IGREATERP PREFIXLEN (IDIFFERENCE BUFSIZE 10))
then (ERROR PREFIX "Too long"))
(if (if OSTRBUFFER
then (if (NULL NUMSUFFIX)
then (HELP "OSTRBUFFER supplied without NUMSUFFIX")
elseif (ILESSP (SETQ BUFSIZE (NCHARS OSTRBUFFER))
(IPLUS 12 PREFIXLEN))
then (ERROR OSTRBUFFER "Too short"))
T
elseif NUMSUFFIX
then (* Insulate the normal \GS.BUF from random intrustions)
(SETQ OSTRBUFFER (ALLOCSTRING (SETQ BUFSIZE (IPLUS PREFIXLEN 12))))
T)
then (SETQ BUF OSTRBUFFER))
A (UNINTERRUPTABLY
(if (if OSTRBUFFER
then (* Use the user-supplied buffer, or a freshly cons'd one
if he supplied NUMSUFFIX without OSTRBUFFER)
T
elseif (NOT (FIXP GENNUM))
then (* Disaster recovery)
(SETQ GENNUM 0)
T)
then (SETQ NUMLEN (\GS.INITBUF BUF BUFSIZE (OR NUMSUFFIX GENNUM)))
else
(* In this case, we have kept account of the contents of \GS.BUF so we don't have to call \GS.INITBUF afresh, but
rather merely "patch up" the effect of adding 1 to GENNUM)
(if (if (NOT (IEQP GENNUM \GS.OGENNUM))
then (* User perhaps has reset GENNUM)
(if (ILESSP GENNUM 0)
then (SETQ GENNUM 0))
T
elseif (IGEQ GENNUM MAX.FIXP)
then (* Sigh, two's complement wrap-around)
(SETQ GENNUM 0)
T)
then (SETQ NUMLEN (\GS.INITBUF BUF BUFSIZE GENNUM)))
(* Increment the GENNUM counter and the string buffer
buffer.)
(if (for CNT C to NUMLEN as I from BUFSIZE by -1
do (* Simulates a BCD type add in the gensym string)
(SETQ C (NTHCHARCODE \GS.BUF I))
(if (ILEQ (add C 1)
(CHARCODE 9))
then (* ha, carry stops here)
(RPLCHARCODE BUF I C)
(RETURN)
else (RPLCHARCODE BUF I (CHARCODE 0)))
finally (RETURN T))
then (* Sigh, we have to extend the numerical part)
(RPLCHARCODE BUF (IDIFFERENCE BUFSIZE NUMLEN)
(CHARCODE 1))
(SETQ NUMLEN (add \GS.NUMLEN 1)))
(SETQ \GS.OGENNUM (add GENNUM 1))) (* BEG.I will be the beginning index, in the buffer, for
the atom)
(SETQ BEG.I (ADD1 (IDIFFERENCE BUFSIZE NUMLEN)))
(if CHARCODE
then (RPLCHARCODE BUF (add BEG.I -1)
CHARCODE))
(if PREFIX
then (RPLSTRING BUF (SETQ BEG.I (IDIFFERENCE BEG.I PREFIXLEN))
PREFIX))
(SETQ \GS.STR (SUBSTRING BUF BEG.I BUFSIZE \GS.STR))
(SETQ ATOM (if (SELECTQ (SYSTEMTYPE)
(D (* As of 9 Dec 1983 only Interlisp-D permits this test)
(OR (NULL NEW?)
(NULL (ATOMHASH#PROBES \GS.STR))))
T)
then (MKATOM \GS.STR))))
(if (NUMBERP ATOM)
then (ERRORX (LIST 27 PREFIX))
elseif (NULL ATOM)
then (* A GENSYM always has a numeric component, so can never
be NIL or T)
(SELECTQ (SYSTEMTYPE)
(D (AND NUMSUFFIX (add NUMSUFFIX 1))
(GO A))
(SHOULDNT))
else (SELECTQ (SYSTEMTYPE)
(D (replace (LITATOM PROPCELL GENSYMP) of ATOM with T))
NIL))
(RETURN ATOM))))
(\GS.INITBUF
(LAMBDA (BUF BUFSIZE N) (* JonL " 9-Dec-83 03:38")
(* Initializes BUF (which must be a stringp of length BUFSIZE) with the digits of N right-justified and left-0
padded up to a minimum of 4 digits. Returns the decimal length of N)
(PROG (NUMLEN)
(RPLSTRING BUF (IDIFFERENCE BUFSIZE (if (ILESSP N 10000)
then (* Trick to get leading zeros)
(SETQ N (IPLUS N 10000))
(SETQ NUMLEN 4)
else (SUB1 (SETQ NUMLEN (INTEGERLENGTH.DECIMAL N)))))
N)
(AND (EQ BUF \GS.BUF)
(SETQ \GS.NUMLEN NUMLEN))
(RETURN NUMLEN))))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \GS.BUFSIZE 100)
(CONSTANTS (\GS.BUFSIZE 100))
)
(RPAQ? GENNUM 0)
(RPAQ? \GS.OGENNUM -1)
(RPAQ? \GS.NUMLEN 0)
(RPAQ? \GS.BUF (ALLOCSTRING \GS.BUFSIZE))
(RPAQ? \GS.STR (ALLOCSTRING 0))
(PUTPROPS GENSYM ARGNAMES (PREFIX --))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS GENNUM \GS.OGENNUM \GS.NUMLEN \GS.BUF \GS.STR)
)
(* These are optimizations for Interlisp-D only)
(DEFINEQ
(ATOMHASH#PROBES
(LAMBDA (STRING) (* JonL "12-Dec-83 06:21")
(PROG (BASE OFFST LEN HINDEX)
(if (LITATOM STRING)
then (SETQ BASE (fetch (LITATOM PNAMEBASE) of STRING))
(SETQ OFFST 1)
(SETQ LEN (fetch (LITATOM PNAMELENGTH) of STRING))
else (SETQ BASE (ffetch (STRINGP BASE) of (SETQ STRING (MKSTRING STRING))))
(SETQ OFFST (ffetch (STRINGP OFFST) of STRING))
(SETQ LEN (ffetch (STRINGP LENGTH) of STRING))
(OR (ILEQ LEN \PNAMELIMIT)
(RETURN)))
(if (EQ LEN 1)
then (RETURN (if (OR (IGREATERP (\GETBASEBYTE BASE OFFST)
(CHARCODE 9))
(ILESSP (\GETBASEBYTE BASE OFFST)
(CHARCODE 0)))
then 0)))
(SETQ HINDEX (OR (\ATOM.FIRSTHASHINDEX BASE OFFST LEN)
(RETURN)))
(RETURN (for PROBES from 1 bind HTENT ATOMINDEX until (ZEROP (SETQ HTENT (\GETBASE
\AtomHashTable
HINDEX)))
do (SETQ ATOMINDEX (\ADDBASE \ATOMSPACE (SUB1 HTENT)))
(if (AND (EQ LEN (fetch (LITATOM PNAMELENGTH) of ATOMINDEX))
(NOT (bind (NBASE ←(fetch (LITATOM PNAMEBASE) of ATOMINDEX))
find I to LEN as J from OFFST
suchthat (NEQ (\GETBASEBYTE NBASE I)
(\GETBASEBYTE BASE J)))))
then (* So these two atom have the same pname characters)
(RETURN PROBES))
(SETQ HINDEX (LOGAND (IPLUS HINDEX \HashInc)
\AtomHTmask)) (* \HashInc is relatively prime to \AtomHTmask so we
will cycle thru all slots)
)))))
(\ATOM.FIRSTHASHINDEX
(LAMBDA (BASE OFFST LEN) (* JonL "12-Dec-83 06:25")
(if (ZEROP LEN)
then 0
else (for I from 0
bind (HINDEX ← 0)
(NUM? ← T)
(NDOTS ← 0)
CHAR TEM
while (ILESSP I LEN)
do (* Mash down the string into a 15-bit number, to use as
the initial probe index)
(SETQ CHAR (\GETBASEBYTE BASE (IPLUS OFFST I)))
(if (OR (IGREATERP CHAR (CHARCODE 9))
(ILESSP CHAR (CHARCODE 0)))
then (SETQ NUM?)
elseif (AND NUM? (EQ CHAR (CHARCODE %.)))
then (* A number is allowed up to one decimal point)
(if (ILESSP 1 (add NDOTS 1))
then (SETQ NUM?)))
(SETQ TEM (IPLUS HINDEX (LLSH (LOADBYTE HINDEX 0 12)
2)))
(SETQ HINDEX (LOGAND (IPLUS (LOGAND TEM \AtomHTmask)
(LLSH (LOADBYTE TEM 0 7)
8)
CHAR)
\AtomHTmask))
finally (RETURN (AND (NULL NUM?)
HINDEX))))))
)
(* This goes on DMISC which overrides the definition found on MISC)
(DEFINEQ
(GENSYM?
(LAMBDA (X ON\OFF) (* JonL " 9-Dec-83 05:48")
(if (OR (NOT (LITATOM X))
(NULL X)
(EQ X T))
then (if (NULL ON\OFF)
then NIL
elseif (LITATOM X)
then (\ILLEGAL.ARG X))
else (PROG1 (fetch (LITATOM PROPCELL GENSYMP) of X)
(if ON\OFF
then (replace (LITATOM PROPCELL GENSYMP) of X with (SELECTQ ON\OFF
((OFF)
NIL)
((ON T)
T)
(\ILLEGAL.ARG
ON\OFF))))))))
)
(* This goes on LLBASIC as a sub-declaration of LITATOM)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD PROPCELL ((NIL BITS 1)
(GENSYMP FLAG)
(NIL BITS 6)
(PROPLIST POINTER)))
]
)
(* This goes on BYTECOMPILER)
(DEFINEQ
(COMP.GENFN
(LAMBDA NIL (* JonL " 9-Dec-83 06:48")
(DECLARE (SPECVARS COMP.GENFN)
(USEDFREE COMP.GENFN))
(if (ILEQ (NCHARS COMP.GENFN.BUF)
(IPLUS 12 (NCHARS COMFN)))
then (SETQ COMP.GENFN.BUF (ALLOCSTRING (IPLUS 16 (NCHARS COMP.GENFN.BUF)))))
(if (IGEQ COMP.GENFN.NUM 9999)
then (SETQ COMP.GENFN.NUM 0))
(GENSYM COMFN (add COMP.GENFN.NUM 1)
COMP.GENFN.BUF NIL (CHARCODE A))))
)
(RPAQ? COMP.GENFN.NUM 0)
(RPAQ? COMP.GENFN.BUF (ALLOCSTRING 100))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS COMP.GENFN.NUM COMP.GENFN.BUF)
)
(DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY
(MOVD (QUOTE COMP.GENFN)
(QUOTE \BYTECOMPBLOCK/COMP.GENFN))
)
(PUTPROPS GENSYM COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1582 2921 (INTEGERLENGTH.DECIMAL 1592 . 2919)) (2952 8278 (GENSYM 2962 . 7573) (
\GS.INITBUF 7575 . 8276)) (8733 11595 (ATOMHASH#PROBES 8743 . 10469) (\ATOM.FIRSTHASHINDEX 10471 .
11593)) (11672 12274 (GENSYM? 11682 . 12272)) (12543 13051 (COMP.GENFN 12553 . 13049)))))
STOP