1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34mkList u ==
35  u => ["LIST",:u]
36  nil
37
38mkOperatorEntry(opSig is [op,sig,:flag],pred,count) ==
39  null flag => [opSig,pred,["ELT","$",count]]
40  first flag="constant" => [[op,sig],pred,["CONST","$",count]]
41  systemError ["unknown variable mode: ",flag]
42
43--% Code for encoding function names inside package or domain
44
45encodeFunctionName(fun,package is [packageName,:arglist],signature,sep,count)
46   ==
47    signature':= substitute("$",package,signature)
48    reducedSig:= mkRepititionAssoc [:rest signature',first signature']
49    encodedSig:=
50      ("STRCONC"/[encodedPair for [n,:x] in reducedSig]) where
51        encodedPair() ==
52          n=1 => encodeItem x
53          STRCONC(STRINGIMAGE n,encodeItem x)
54    encodedName := INTERN(CONCAT(getAbbreviation(packageName, #arglist), ";",
55        encodeItem(fun), ";", encodedSig, sep, STRINGIMAGE(count)))
56    encodedName
57
58mkRepititionAssoc l ==
59  mkRepfun(l,1) where
60    mkRepfun(l,n) ==
61      null l => nil
62      l is [x] => [[n,:x]]
63      l is [x, =x,:l'] => mkRepfun(rest l,n+1)
64      [[n,:first l],:mkRepfun(rest l,1)]
65
66encodeItem x ==
67  x is [op,:argl] => getCaps op
68  IDENTP x => PNAME x
69  STRINGIMAGE x
70
71getCaps x ==
72  s:= STRINGIMAGE x
73  clist:= [c for i in 0..MAXINDEX s | UPPER_-CASE_-P (c:= s.i)]
74  null clist => '"__"
75  "STRCONC"/[first clist,:[DOWNCASE u for u in rest clist]]
76
77--% abbreviation code
78
79DEFPARAMETER($abbreviationTable, '())
80
81getAbbreviation(name,c) ==
82  --returns abbreviation of name with c arguments
83  x := constructor? name
84  X := ASSQ(x,$abbreviationTable) =>
85    N:= ASSQ(name,rest X) =>
86      C:= ASSQ(c,rest N) => rest C --already there
87      newAbbreviation:= mkAbbrev(X,x)
88      rplac(rest N, [[c, :newAbbreviation], :rest N])
89      newAbbreviation
90    newAbbreviation:= mkAbbrev(X,x)
91    rplac(rest X, [[name, [c, :newAbbreviation]], :rest X])
92    newAbbreviation
93  $abbreviationTable:= [[x,[name,[c,:x]]],:$abbreviationTable]
94  x
95
96mkAbbrev(X,x) == addSuffix(alistSize rest X,x)
97
98alistSize c ==
99  count(c,1) where
100    count(x,level) ==
101      level=2 => #x
102      null x => 0
103      count(CDAR x,level+1)+count(rest x,level)
104
105addSuffix(n,u) ==
106  ALPHA_-CHAR_-P((s := STRINGIMAGE u).(MAXINDEX s)) =>
107      INTERNL1(s, STRINGIMAGE(n))
108  INTERN(CONCAT(s, '";", STRINGIMAGE(n)))
109