diff options
Diffstat (limited to 'src/interp/pf2atree.boot.pamphlet')
| -rw-r--r-- | src/interp/pf2atree.boot.pamphlet | 575 |
1 files changed, 0 insertions, 575 deletions
diff --git a/src/interp/pf2atree.boot.pamphlet b/src/interp/pf2atree.boot.pamphlet deleted file mode 100644 index 29e85ad1..00000000 --- a/src/interp/pf2atree.boot.pamphlet +++ /dev/null @@ -1,575 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp pf2atree.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<<license>>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- 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. - -@ -<<*>>= -<<license>> - --- not hooked in yet - --- BB parser tree to interpreter vectorized attributed trees. --- Used to interface the BB parser --- technology to the interpreter. The input is a parseTree and the --- output is an interpreter attributed tree. - -SETANDFILEQ($useParserSrcPos, true) -SETANDFILEQ($transferParserSrcPos, true) - -pf2Sexpr pf == packageTran (pf2Sex1)(pf) - -pf2Atree pf == - (intUnsetQuiet)() - - $insideRule: local := false - $insideApplication: local := false - $insideSEQ: local := false - - -- we set the following because we will be using some things - -- within pf2sex.boot and they are in the spadcomp package. - - ($insideRule): local := false - ($insideApplication): local := false - ($insideSEQ): local := false - - pf2Atree1 pf - -pf2Atree1 pf == - -- some simple things that are really just S-expressions - - (pfNothing?)(pf) => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - (pfSymbol?) pf => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - (pfLiteral?)(pf) => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - (pfId?) pf => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - - -- Now some compound forms - - (pfApplication?)(pf) => - pfApplication2Atree pf - - (pfTuple?)(pf) => - [mkAtreeNodeWithSrcPos("Tuple",pf), - :[pf2Atree1 x for x in (pf0TupleParts)(pf)]] - - (pfIf?)(pf) => - condPf := (pfIfCond)(pf) - condPart := pf2Atree1 condPf - thenPart := pf2Atree1 (pfIfThen)(pf) - elsePart := pf2Atree1 (pfIfElse)(pf) - ifPart := mkAtreeNodeWithSrcPos("IF", pf) - thenPart = "noBranch" => - [ifPart, [mkAtreeNodeWithSrcPos("not", condPf), condPart], - elsePart, thenPart] - [ifPart, condPart, thenPart, elsePart] - - (pfTagged?)(pf) => - tag := (pfTaggedTag)(pf) - tagPart := - (pfTuple?) tag => - ["Tuple", :[pf2Sexpr(arg) for arg in (pf0TupleParts)(tag)]] - pf2Sexpr(tag) - [mkAtreeNodeWithSrcPos("Declare",pf), tagPart, - pf2Sexpr((pfTaggedExpr)(pf))] - - (pfCoerceto?)(pf) => - [mkAtreeNodeWithSrcPos("COERCE",pf), - pf2Atree1 (pfCoercetoExpr)(pf), - pf2Sexpr((pfCoercetoType)(pf))] - - (pfPretend?)(pf) => - [mkAtreeNodeWithSrcPos("pretend",pf), - pf2Atree1 (pfPretendExpr)(pf), - pf2Sexpr((pfPretendType)(pf))] - - (pfFromdom?)(pf) => - op := packageTran (opTran)(pf2Sexpr((pfFromdomWhat)(pf))) - if op = "braceFromCurly" then op := "SEQ" -- ?? - - op = 0 => - -- 0$Foo => Zero()$Foo - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - [mkAtreeNodeWithSrcPos("Zero",pf)]] - op = 1 => - -- 1$Foo => One()$Foo - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - [mkAtreeNodeWithSrcPos("One",pf)]] - INTEGERP op => - -- n$Foo => n * One()$Foo - [mkAtreeNodeWithSrcPos("*",pf), - mkAtree1WithSrcPos(op,pf), - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - [mkAtreeNodeWithSrcPos("One",pf)]]] - - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - mkAtreeNodeWithSrcPos(op,pf)] - - (pfSequence?)(pf) => - pfSequence2Atree pf - - (pfExit?)(pf) => - $insideSEQ => - [mkAtreeNodeWithSrcPos("exit",pf), - pf2Atree1 (pfExitCond)(pf), - pf2Atree1 (pfExitExpr)(pf)] - [mkAtreeNodeWithSrcPos("IF",pf), - pf2Atree1 (pfExitCond)(pf), - pf2Atree1 (pfExitExpr)(pf), "noBranch"] - - (pfLoop?)(pf) => - [mkAtreeNodeWithSrcPos("REPEAT",pf), - :loopIters2Atree (pf0LoopIterators)(pf)] - - (pfCollect?)(pf) => - pfCollect2Atree(pf) - - (pfForin?)(pf) => - ["IN", :[pf2Atree1 x for x in (pf0ForinLhs)(pf)], - pf2Atree1 (pfForinWhole)(pf)] - - (pfWhile?)(pf) => - ["WHILE", pf2Atree1((pfWhileCond)(pf))] - - (pfSuchthat?)(pf) => - $insideRule = 'left => - keyedSystemError('"S2GE0017", ['"pf2Atree1: pfSuchThat"]) - ["SUCHTHAT", pf2Atree1 (pfSuchthatCond)(pf)] - - (pfDo?)(pf) => - pf2Atree1 (pfDoBody)(pf) - --- (pfTyped?)(pf) => --- type := pfTypedType pf --- pfNothing? type => pf2Atree1 pfTypedId pf --- [":", pf2Atree1 pfTypedId pf, pf2Atree1 pfTypedType pf] - - (pfAssign?)(pf) => - -- declarations on the lhs are broken out into another - -- statement preceding the LET of the id(s) - lhsThings := (pf0AssignLhsItems)(pf) - if #lhsThings = 1 and (pfTuple?)(first lhsThings) then - lhsThings := (pf0TupleParts)(first lhsThings) - decls := nil - ids := nil - for x in lhsThings repeat - (pfTagged?)(x) => - decls := [x, :decls] - ids := [(pfTaggedTag)(x), :ids] - ids := [x, :ids] - idList := [pf2Atree1 x for x in reverse ids] - if #idList ^= 1 then idList := - [mkAtreeNodeWithSrcPos("Tuple",pf), :idList] - else idList := first idList - x := [mkAtreeNodeWithSrcPos("LET",pf), - idList, pf2Atree1 (pfAssignRhs)(pf)] - decls => - [mkAtreeNodeWithSrcPos("SEQ",pf), - :[pf2Atree1 decl for decl in nreverse decls], x] - x - --- (pfDefinition?)(pf) => --- pfDefinition2Atree pf - --- (pfLambda?)(pf) => --- pfLambda2Atree pf --- (pfRestrict?)(pf) => --- ["@", pf2Atree1 pfRestrictExpr pf, pf2Atree1 pfRestrictType pf] - - (pfFree?)(pf) => - [mkAtreeNodeWithSrcPos("free",pf), - :[pf2Atree1 item for item in (pf0FreeItems)(pf)]] - (pfLocal?)(pf) => - [mkAtreeNodeWithSrcPos("local",pf), - :[pf2Atree1 item for item in (pf0LocalItems)(pf)]] - - (pfWrong?)(pf) => - spadThrow() - - -- next 3 are probably be handled in pfApplication2Atree - - (pfAnd?)(pf) => - [mkAtreeNodeWithSrcPos("and",pf), - pf2Atree1 (pfAndLeft)(pf), - pf2Atree1 (pfAndRight)(pf)] - (pfOr?)(pf) => - [mkAtreeNodeWithSrcPos("or",pf), - pf2Atree1 (pfOrLeft)(pf), - pf2Atree1 (pfOrRight)(pf)] - (pfNot?)(pf) => - [mkAtreeNodeWithSrcPos("not",pf), - pf2Atree1 (pfNotArg)(pf)] - --- (pfNovalue?)(pf) => --- intSetQuiet() --- ["SEQ", pf2Atree1 pfNovalueExpr pf] --- (pfRule?)(pf) => --- pfRule2Atree pf - - (pfBreak?)(pf) => - [mkAtreeNodeWithSrcPos("break",pf), (pfBreakFrom)(pf)] - - (pfMacro?)(pf) => - tree := mkAtree1WithSrcPos('(void), pf) - putValue(tree,objNewWrap(voidValue(),$Void)) - putModeSet(tree,[$Void]) - tree - - (pfReturn?)(pf) => - [mkAtreeNodeWithSrcPos("return",pf), - pf2Atree1 (pfReturnExpr)(pf)] - - (pfIterate?)(pf) => - [mkAtreeNodeWithSrcPos("iterate",pf)] - --- (pfWhere?)(pf) => --- args := [pf2Atree1 p for p in pf0WhereContext pf] --- #args = 1 => --- ["where", pf2Atree1 pfWhereExpr pf, :args] --- ["where", pf2Atree1 pfWhereExpr pf, ["SEQ", :args]] - - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - --- keyedSystemError('"S2GE0017", ['"pf2Atree1"]) --- - -pfApplication2Atree pf == - $insideApplication: local := true - ($insideApplication): local := true - - opPf := (pfApplicationOp)(pf) - op := packageTran ((opTran)(pfOp2Sex)(opPf)) - op = "->" => - args := (pf0TupleParts)((pfApplicationArg)(pf)) - if (pfTuple?)(CAR args) then - typeList := [pf2Atree1 arg for arg in (pf0TupleParts)(CAR args)] - else - typeList := [pf2Atree1 CAR args] - args := [pf2Atree1 CADR args, :typeList] - [mkAtreeNodeWithSrcPos("Mapping", opPf), :args] - - (symEqual)(op, '":") and $insideRule = 'left => - [mkAtreeNodeWithSrcPos("multiple",opPf), - pf2Atree (pfApplicationArg)(pf)] - - (symEqual)(op, '"?") and $insideRule = 'left => - [mkAtreeNodeWithSrcPos("optional",opPf), - pf2Atree (pfApplicationArg)(pf)] - - args := (pfApplicationArg)(pf) - - (pfTuple?)(args) => ---! symEqual(op, '"|") and $insideRule = 'left => ---! pfSuchThat2Atree args - argAtree := [pf2Atree1 arg for arg in (pf0TupleParts)(args)] - - (symEqual)(op, '">") => - [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)] - (symEqual)(op, '">=") => - [mkAtreeNodeWithSrcPos("not",opPf), - [mkAtreeNodeWithSrcPos("<",opPf), :argAtree]] - (symEqual)(op, '"<=") => - [mkAtreeNodeWithSrcPos("not",opPf), - [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)]] - (symEqual)(op, '"AND") => - [mkAtreeNodeWithSrcPos("and",opPf), :argAtree] - (symEqual)(op, '"OR") => - [mkAtreeNodeWithSrcPos("or",opPf), :argAtree] - (symEqual) (op, '"Iterate") => - [mkAtreeNodeWithSrcPos("iterate",opPf)] - (symEqual)(op, '"by") => - [mkAtreeNodeWithSrcPos("BY",opPf), :argAtree] - (symEqual)(op, '"braceFromCurly") => - argAtree and getUnname first argAtree = "SEQ" => argAtree - [mkAtreeNodeWithSrcPos("SEQ",opPf), :argAtree] - op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => - [mkAtreeNodeWithSrcPos("applyQuote",opPf), - mkAtreeNodeWithSrcPos(op,opPf), :argAtree] ---! val := (hasOptArgs?)(argSex) => [op, :val] - -- handle package call - (pfFromdom?)(opPf) => - opAtree := pf2Atree1 opPf - [CAR opAtree, CADR opAtree, [CADDR opAtree, :argAtree]] - -- regular call - [mkAtreeNodeWithSrcPos(op,opPf), :argAtree] - - op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => - [mkAtreeNodeWithSrcPos("applyQuote",opPf), - mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] - (symEqual)(op, '"braceFromCurly") => - x := pf2Atree1 args - x and getUnname x = "SEQ" => x - [mkAtreeNodeWithSrcPos("SEQ",opPf), x] - (symEqual)(op, '"by") => - [mkAtreeNodeWithSrcPos("BY",opPf), pf2Atree1 args] - -- handle package call - (pfFromdom?)(opPf) => - opAtree := pf2Atree1 opPf - [CAR opAtree, CADR opAtree, [CADDR opAtree, pf2Atree1 args]] - -- regular call - [mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] - --- pfDefinition2Atree pf == --- --! $insideApplication => --- --! ["OPTARG", pf2Atree1 CAR pf0DefinitionLhsItems pf, --- --! pf2Atree1 pfDefinitionRhs pf] --- idList := [pf2Atree1 x for x in (pf0DefinitionLhsItems)(pf)] --- #idList ^= 1 => --- systemError '"lhs of definition must be a single item in the interpreter" --- id := first idList --- rhs := (pfDefinitionRhs)(pf) --- [argList, :body] := pfLambdaTran rhs --- ["DEF", (argList = 'id => id; [id, :argList]), :body] - --- pfLambdaTran pf == --- pfLambda? pf => --- argTypeList := nil --- argList := nil --- for arg in pf0LambdaArgs pf repeat --- pfTyped? arg => --- argList := [pfCollectArgTran pfTypedId arg, :argList] --- pfNothing? pfTypedType arg => --- argTypeList := [nil, :argTypeList] --- argTypeList := [pf2Atree1 pfTypedType arg, :argTypeList] --- systemError '"definition args should be typed" --- argList := nreverse argList --- retType := --- pfNothing? pfLambdaRets pf => nil --- pf2Atree1 pfLambdaRets pf --- argTypeList := [retType, :nreverse argTypeList] --- [argList, :[argTypeList, [nil for arg in argTypeList], --- pf2Atree1 pfLambdaBody pf]] --- ['id, :['(()), '(()), pf2Atree1 pf]] --- --- pfLambda2Atree pf == --- [argList, :body] := pfLambdaTran pf --- ["ADEF", argList, :body] --- --- pfCollectArgTran pf == --- pfCollect? pf => --- conds := [pf2Atree1 x for x in pfParts pfCollectIterators pf] --- id := pf2Atree1 pfCollectBody pf --- conds is [["|", cond]] => --- ["|", id, cond] --- [id, :conds] --- pf2Atree1 pf --- - -pfSequence2Atree pf == - $insideSEQ: local := true - ($insideSEQ): local := true - - seq := pfSequence2Atree0([pf2Atree1 x for x in (pf0SequenceArgs)(pf)], pf) - seqSex := (pfSequence2Sex0)([pf2Sexpr(x) for x in (pf0SequenceArgs)(pf)]) - seqSex is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => - [mkAtreeNodeWithSrcPos("ruleset",pf), - [mkAtreeNodeWithSrcPos("construct",pf), :rest seq]] - seq - -pfSequence2Atree0(seqList, pf) == - null seqList => "noBranch" - seqTranList := [] - while seqList ^= nil repeat - item := first seqList - item is [exitVal, cond, value] and getUnname(exitVal) = "exit" => - item := [mkAtreeNodeWithSrcPos("IF",pf), cond, value, - pfSequence2Atree0(rest seqList, pf)] - seqTranList := [item, :seqTranList] - seqList := nil - seqTranList := [item ,:seqTranList] - seqList := rest seqList - #seqTranList = 1 => first seqTranList - [mkAtreeNodeWithSrcPos("SEQ",pf), :nreverse seqTranList] - --- --- float2Atree num == --- eIndex := SEARCH('"e", num) --- mantPart := --- eIndex => SUBSEQ(num, 0, eIndex) --- num --- expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) --- dotIndex := SEARCH('".", mantPart) --- intPart := --- dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) --- READ_-FROM_-STRING mantPart --- fracPartString := --- dotIndex => SUBSEQ(mantPart, dotIndex+1) --- '"0" --- bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, --- LENGTH fracPartString, expPart) --- [., frac, :exp] := bfForm --- [["$elt", intNewFloat(), 'float], frac, exp, 10] --- - -loopIters2Atree iterList == - -- could probably do a better job of getting accurate SrcPos info onto parts - result := nil - for iter in iterList repeat - -- ON and UNTIL forms are no longer supported - sex := pf2Sexpr(iter) - sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => - newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), - mkAtree1WithSrcPos(incr, iter)] - result := [newIter, :result] - sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => - newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), - mkAtree1WithSrcPos(incr, iter), mkAtree1WithSrcPos(j,iter)] - result := [newIter, :result] - sex is ['IN, var, ['SEGMENT, i, j]] => - newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), - mkAtree1WithSrcPos(1,iter), mkAtree1WithSrcPos(j,iter)] - result := [newIter, :result] - sex is ['IN, var, s] => - newIter := ["IN", var, mkAtree1 s] - result := [newIter, :result] - result := [pf2Atree1(iter), :result] - nreverse result - -pfCollect2Atree pf == - atree := [mkAtree1WithSrcPos("COLLECT",pf), - :loopIters2Atree (pfParts)((pfCollectIterators)(pf)), - pf2Atree1 (pfCollectBody)(pf)] - - -- next are for what appears to a parser screw-up - sex := ["COLLECT", - :(loopIters2Sex)((pfParts)((pfCollectIterators)(pf))), - pf2Sexpr (pfCollectBody)(pf)] - sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => - [., [., condAtree], varAtree] := atree - ["SUCHTHAT", varAtree, condAtree] - - atree - --- --- pfRule2Atree pf == --- $quotedOpList:local := nil --- $predicateList:local := nil --- $multiVarPredicateList:local := nil --- lhs := pfLhsRule2Atree pfRuleLhsItems pf --- rhs := pfRhsRule2Atree pfRuleRhs pf --- lhs := ruleLhsTran lhs --- rulePredicateTran --- $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] --- ["rule", lhs, rhs] --- --- --- ruleLhsTran ruleLhs == --- for pred in $predicateList repeat --- [name, predLhs, :predRhs] := pred --- vars := patternVarsOf predRhs --- CDR vars => -- if there is more than one patternVariable --- ruleLhs := NSUBST(predLhs, name, ruleLhs) --- $multiVarPredicateList := [pred, :$multiVarPredicateList] --- predicate := --- [., var] := predLhs --- ["suchThat", predLhs, ["ADEF", [var], --- '((Boolean) (Expression (Integer))), '(() ()), predRhs]] --- ruleLhs := NSUBST(predicate, name, ruleLhs) --- ruleLhs --- --- rulePredicateTran rule == --- null $multiVarPredicateList => rule --- varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] --- predBody := --- CDR $multiVarPredicateList => --- ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in --- $multiVarPredicateList]] --- [[.,.,:rhs],:.] := $multiVarPredicateList --- pvarPredTran(rhs, varList) --- ['suchThat, rule, --- ['construct, :[["QUOTE", var] for var in varList]], --- ['ADEF, '(predicateVariable), --- '((Boolean) (List (Expression (Integer)))), '(() ()), --- predBody]] --- --- pvarPredTran(rhs, varList) == --- for var in varList for i in 1.. repeat --- rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) --- rhs --- --- patternVarsOf expr == --- patternVarsOf1(expr, nil) --- --- patternVarsOf1(expr, varList) == --- NULL expr => varList --- ATOM expr => --- null SYMBOLP expr => varList --- SymMemQ(expr, varList) => varList --- [expr, :varList] --- expr is [op, :argl] => --- for arg in argl repeat --- varList := patternVarsOf1(arg, varList) --- varList --- varList --- --- pfLhsRule2Atree lhs == --- $insideRule: local := 'left --- ($insideRule): local := 'left --- pf2Atree1 lhs --- --- --- pfRhsRule2Atree rhs == --- $insideRule: local := 'right --- ($insideRule): local := 'right --- pf2Atree1 rhs --- - --- pfSuchThat2Atree args == --- name := GENTEMP() --- argList := pf0TupleParts args --- lhsSex := pf2Atree1 CAR argList --- rhsSex := pf2Atree CADR argList --- $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] --- name -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} |