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