-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- - Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- -- - Neither the name of The Numerical Algorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. import as namespace BOOT $stripTypes := false $pretendFlag := false $defaultFlag := false $baseForms := nil $literals := nil spad2AxTranslatorAutoloadOnceTrigger any == true sourceFilesToAxFile(filename, sourceFiles) == makeAxFile(filename, MAPCAN('fileConstructors, sourceFiles)) $extendedDomains := nil setExtendedDomains(l) == $extendedDomains := l fileConstructors name == [INTERN(con,"BOOT") for con in SRCABBREVS SOURCEPATH STRING name] makeAxFile(filename, constructors) == $defaultFlag : local := false $literals := [] axForms := [modemapToAx(modemap) for cname in constructors | (modemap:=getConstructorModemapFromDB cname) and not (cname in '(Tuple Exit Type)) and not isDefaultPackageName cname] if $baseForms then axForms := [:$baseForms, :axForms] if $defaultFlag then axForms := [['Foreign, ['Declare, 'dummyDefault, 'Exit], 'Lisp], :axForms] axForms := APPEND(axDoLiterals(), axForms) axForm := ['Sequence, _ ['Import, [], 'AxiomLib], ['Import, [], 'Boolean], :axForms] st := MAKE_-OUTSTREAM(filename) PPRINT(axForm,st) CLOSE st makeAxExportForm(filename, constructors) == $defaultFlag : local := false $literals := [] axForms := [modemapToAx(modemap) for cname in constructors | (modemap:=getConstructorModemapFromDB cname) and not (cname in '(Tuple Exit Type)) and not isDefaultPackageName cname] if $baseForms then axForms := [:$baseForms, :axForms] if $defaultFlag then axForms := [['Foreign, ['Declare, 'dummyDefault, 'Exit], 'Lisp], :axForms] axForms := APPEND(axDoLiterals(), axForms) axForm := ['Sequence, _ ['Import, [], 'AxiomLib], ['Import, [], 'Boolean], :axForms] axForm stripType type == $stripTypes => categoryForm? type => 'Type type type modemapToAx(modemap) == modemap is [[consform, target,:argtypes],.] consform is [constructor,:args] argdecls:=['Comma, : [axFormatDecl(a,stripType t) for a in args for t in argtypes]] resultType := axFormatType stripType target categoryForm? constructor => categoryInfo := getConstructorCategoryFromDB constructor categoryInfo := SUBLISLIS($FormalMapVariableList, $TriangleVariableList, categoryInfo) NULL args => ['Define,['Declare, constructor,'Category], addDefaults(constructor, axFormatType categoryInfo)] ['Define, ['Declare, constructor, ['Apply, "->", optcomma argdecls, 'Category]], ['Lambda, argdecls, 'Category, ['Label, constructor, addDefaults(constructor, axFormatType categoryInfo)]]] constructor in $extendedDomains => NULL args => ['Extend, ['Define, ['Declare, constructor, resultType], ['Add, ['PretendTo, ['Add, [], []], resultType], []]]] conscat := INTERN(STRCONC(SYMBOL_-NAME(constructor), "ExtendCategory"),"BOOT") rtype := ['Apply, conscat, :args] -- if resultType is ['With,a,b] then -- if not(b is ['Sequence,:withseq]) then withseq := [b] -- cosigs := rest getDualSignatureFromDB constructor -- exportargs := [['Export, [], arg, []] for arg in args for p in cosigs | p] -- resultType := ['With,a,['Sequence,:APPEND(exportargs, withseq)]] consdef := ['Define, ['Declare, conscat, ['Apply, "->", optcomma argdecls, 'Category]], ['Lambda, argdecls, 'Category, ['Label, conscat, resultType]]] ['Sequence, consdef, ['Extend, ['Define, ['Declare, constructor, ['Apply, "->", optcomma argdecls, rtype]], ['Lambda, argdecls, rtype, ['Label, constructor, ['Add, ['PretendTo, ['Add, [], []], rtype], []]]]]]] NULL args => ['Export, ['Declare, constructor, resultType],[],[]] -- if resultType is ['With,a,b] then -- if not(b is ['Sequence,:withseq]) then withseq := [b] -- cosigs := rest getDualSignatureFromDB constructor -- exportargs := [['Export, [], arg, []] for arg in args for p in cosigs | p] -- resultType := ['With,a,['Sequence,:APPEND(exportargs, withseq)]] ['Export, ['Declare, constructor, ['Apply, "->", optcomma argdecls, resultType]],[],[]] optcomma [op,:args] == # args = 1 => first args [op,:args] axFormatDecl(sym, type) == if sym = '$ then sym := '% opOf type in '(StreamAggregate FiniteLinearAggregate) => ['Declare, sym, 'Type] ['Declare, sym, axFormatType type] makeTypeSequence l == ['Sequence,: delete('Type, l)] axFormatAttrib(typeform) == atom typeform => typeform axFormatType typeform axFormatType(typeform) == atom typeform => typeform = '$ => '% STRINGP typeform => ['Apply,'Enumeration, INTERN typeform] INTEGERP typeform => -- need to test for PositiveInteger vs Integer axAddLiteral('integer, 'PositiveInteger, 'Literal) ['RestrictTo, ['LitInteger, STRINGIMAGE typeform ], 'PositiveInteger] FLOATP typeform => ['LitFloat, STRINGIMAGE typeform] MEMQ(typeform,$TriangleVariableList) => SUBLISLIS($FormalMapVariableList, $TriangleVariableList, typeform) MEMQ(typeform, $FormalMapVariableList) => typeform axAddLiteral('string, 'Symbol, 'Literal) ['RestrictTo, ['LitString, PNAME typeform], 'Symbol] typeform is ['construct,: args] => axAddLiteral('bracket, ['Apply, 'List, 'Symbol], [ 'Apply, 'Tuple, 'Symbol]) axAddLiteral('string, 'Symbol, 'Literal) ['RestrictTo, ['Apply, 'bracket, :[axFormatType a for a in args]], ['Apply, 'List, 'Symbol] ] typeform is [op] => op = '$ => '% op = 'Void => ['Comma] op typeform is ['local, val] => axFormatType val typeform is ['QUOTE, val] => axFormatType val typeform is ['Join,:cats,lastcat] => lastcat is ['CATEGORY,type,:ops] => ['With, [], makeTypeSequence( APPEND([axFormatType c for c in cats], [axFormatOp op for op in ops]))] ['With, [], makeTypeSequence([axFormatType c for c in rest typeform])] typeform is ['CATEGORY, type, :ops] => ['With, [], axFormatOpList ops] typeform is ['Mapping, target, :argtypes] => ['Apply, "->", ['Comma, :[axFormatType t for t in argtypes]], axFormatType target] typeform is ['_:, name, type] => axFormatDecl(name,type) typeform is ['Union, :args] => first args is ['_:,.,.] => ['Apply, 'Union, :[axFormatType a for a in args]] taglist := [] valueCount := 0 for x in args repeat tag := STRINGP x => INTERN x x is ['QUOTE,val] and STRINGP val => INTERN val valueCount := valueCount + 1 INTERNL("value", STRINGIMAGE valueCount) taglist := [tag ,: taglist] ['Apply, 'Union, :[axFormatDecl(name,type) for name in reverse taglist for type in args]] typeform is ['Dictionary,['Record,:args]] => ['Apply, 'Dictionary, ['PretendTo, axFormatType second typeform, 'SetCategory]] typeform is ['FileCategory,xx,['Record,:args]] => ['Apply, 'FileCategory, axFormatType xx, ['PretendTo, axFormatType third typeform, 'SetCategory]] typeform is [op,:args] => $pretendFlag and constructor? op and getConstructorModemapFromDB op is [[.,target,:argtypes],.] => ['Apply, op, :[['PretendTo, axFormatType a, axFormatType t] for a in args for t in argtypes]] op in '(SquareMatrix SquareMatrixCategory DirectProduct DirectProductCategory RadixExpansion) and getConstructorModemapFromDB op is [[.,target,arg1type,:restargs],.] => ['Apply, op, ['PretendTo, axFormatType first args, axFormatType arg1type], :[axFormatType a for a in rest args]] ['Apply, op, :[axFormatType a for a in args]] error "unknown entry type" axFormatOpList ops == ['Sequence,:[axFormatOp o for o in ops]] axOpTran(name) == ATOM name => name = 'elt => 'apply name = 'setelt => 'set_! name = 'SEGMENT => ".." name = 1 => '_1 name = 0 => '_0 name opOf name = 'Zero => '_0 opOf name = 'One => '_1 error "bad op name" axFormatOpSig(name, [result,:argtypes]) == ['Declare, axOpTran name, ['Apply, "->", ['Comma, :[axFormatType t for t in argtypes]], axFormatType result]] axFormatConstantOp(name, [result]) == ['Declare, axOpTran name, axFormatType result] axFormatPred pred == atom pred => pred [op,:args] := pred op = 'IF => axFormatOp pred op = "has" => [name,type] := args if name = '$ then name := '% else name := axFormatOp name ftype := axFormatOp type if ftype is ['Declare,:.] then ftype := ['With, [], ftype] ['Test,['Has,name, ftype]] axArglist := [axFormatPred arg for arg in args] op = 'AND => ['And,:axArglist] op = 'OR => ['Or,:axArglist] op = 'NOT => ['Not,:axArglist] error "unknown predicate" axFormatCondOp op == $pretendFlag:local := true axFormatOp op axFormatOp op == op is ['IF, pred, trueops, falseops] => NULL(trueops) or trueops='%noBranch => ['If, ['Test,['Not, axFormatPred pred]], axFormatCondOp falseops, axFormatCondOp trueops] ['If, axFormatPred pred, axFormatCondOp trueops, axFormatCondOp falseops] -- ops are either single op or ['PROGN, ops] op is ['SIGNATURE, name, type] => axFormatOpSig(name,type) op is ['SIGNATURE, name, type, 'constant] => axFormatConstantOp(name,type) op is ['ATTRIBUTE, attributeOrCategory] => categoryForm? attributeOrCategory => axFormatType attributeOrCategory ['RestrictTo, axFormatAttrib attributeOrCategory, 'Category] op is ['PROGN, :ops] => axFormatOpList ops op is '%noBranch => [] axFormatType op addDefaults(catname, withform) == withform isnt ['With, joins, ['Sequence,: oplist]] => error "bad category body" null(defaults := getDefaultingOps catname) => withform defaultdefs := [makeDefaultDef(decl) for decl in defaults] ['With, joins, ['Sequence, :oplist, ['Default, ['Sequence,: defaultdefs]]]] makeDefaultDef(decl) == decl isnt ['Declare, op, type] => error "bad default definition" $defaultFlag := true type is ['Apply, "->", args, result] => ['Define, decl, ['Lambda, makeDefaultArgs args, result, ['Label, op, 'dummyDefault]]] ['Define, ['Declare, op, type], 'dummyDefault] makeDefaultArgs args == args isnt ['Comma,:argl] => error "bad default argument list" ['Comma,: [['Declare,v,t] for v in $TriangleVariableList for t in argl]] getDefaultingOps catname == not(name:=hasDefaultPackage catname) => nil $infovec: local := getInfovec name opTable := $infovec.1 $opList:local := nil for i in 0..MAXINDEX opTable repeat op := opTable.i i := i + 1 startIndex := opTable.i stopIndex := i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector() opTable.(i + 2) curIndex := startIndex while curIndex < stopIndex repeat curIndex := get1defaultOp(op,curIndex) $pretendFlag : local := true catops := getConstructorOperationsFromDB catname [axFormatDefaultOpSig(op,sig,catops) for opsig in $opList | opsig is [op,sig]] axFormatDefaultOpSig(op, sig, catops) == #sig > 1 => axFormatOpSig(op,sig) nsig := MSUBST('$,'($), sig) -- dcSig listifies '$ ?? (catsigs := LASSOC(op, catops)) and (catsig := assoc(nsig, catsigs)) and last(catsig) = 'CONST => axFormatConstantOp(op, sig) axFormatOpSig(op,sig) get1defaultOp(op,index) == numvec := getCodeVector() segment := getOpSegment index numOfArgs := numvec.index index := index + 1 predNumber := numvec.index index := index + 1 signumList := -- following substitution fixes the problem that default packages -- have $ added as a first arg, thus other arg counts are off by 1. SUBLISLIS($FormalMapVariableList, rest $FormalMapVariableList, dcSig(numvec,index,numOfArgs)) index := index + numOfArgs + 1 slotNumber := numvec.index if not([op,signumList] in $opList) then $opList := [[op,signumList],:$opList] index + 1 axAddLiteral(name, type, dom) == elt := [name, type, dom] if not member( elt, $literals) then $literals := [elt, :$literals] axDoLiterals() == [ [ 'Import, [ 'With, [], ['Declare, name, [ 'Apply, '_-_> , dom , '_% ]]], type ] for [name, type, dom] in $literals]