1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:           PNK:STRING-GENSYM.SL
4% Title:          Complement to GenSym, makes a string instead of ID
5% Author:         Eric Benson
6% Created:        14 January 1982
7% Modified:       29-Aug-84 11:03:46 (Brian Beach)
8% Status:         Open Source: BSD License
9% Mode:           Lisp
10% Package:        Kernel
11%
12% (c) Copyright 1983, Hewlett-Packard Company, see the file
13%            HP_disclaimer at the root of the PSL file tree
14%
15% (c) Copyright 1982, University of Utah
16%
17% Redistribution and use in source and binary forms, with or without
18% modification, are permitted provided that the following conditions are met:
19%
20%    * Redistributions of source code must retain the relevant copyright
21%      notice, this list of conditions and the following disclaimer.
22%    * Redistributions in binary form must reproduce the above copyright
23%      notice, this list of conditions and the following disclaimer in the
24%      documentation and/or other materials provided with the distribution.
25%
26% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
27% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
28% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
29% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
30% CONTRIBUTORS
31% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
32% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
33% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
34% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
35% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
36% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
37% POSSIBILITY OF SUCH DAMAGE.
38%
39%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
40%
41% Revisions:
42%
43% 19-Dec-86 (Leigh Stoller)
44%  Added copystring to setq of stringgensym* below to make sure the string
45%  in allocated in heap, not bps.
46% 26 Jan 1984 1001-PST (Brian Beach)
47%  Corrected file name in header.
48% 01-Dec-83 15:02:12 (Brian Beach)
49%   Translated from Rlisp to Lisp.
50%
51% Edit by Cris Perdue,  9 Feb 1983 1620-PST
52% Modified to avoid using the CHAR macro in a top level form
53%
54%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
55
56(fluid '(stringgensym*))
57
58% Make sure that the string ends up in heap, not bps, so we can unexec over it.
59(setq stringgensym* (copystring (symnam (inf 'L0000))))
60
61% Copy to force into heap /csp
62(compiletime
63  (flag '(stringgensym1) 'internalfunction))
64
65(de stringgensym ()
66  %. Generate unique string
67  (stringgensym1 4))
68
69(de stringgensym1 (n)
70  %. Auxiliary function for StringGenSym
71  (let (ch)
72       (cond ((greaterp n 0) (if (lessp (setq ch (indx stringgensym* n))
73                                  (char !9))
74                (progn (setindx stringgensym* n (plus ch 1))
75                       (totalcopy stringgensym*))
76                (progn (setindx stringgensym* n (char !0))
77                       (stringgensym1 (difference n 1)))))
78             (t % Increment starting letter
79
80                (progn (setindx stringgensym* 0
81                        (plus (indx stringgensym* 0) 1))
82                       (stringgensym))))))
83
84