diff options
Diffstat (limited to 'src/interp/pf2sex.boot.pamphlet')
| -rw-r--r-- | src/interp/pf2sex.boot.pamphlet | 526 |
1 files changed, 526 insertions, 0 deletions
diff --git a/src/interp/pf2sex.boot.pamphlet b/src/interp/pf2sex.boot.pamphlet new file mode 100644 index 00000000..a5ea9b6e --- /dev/null +++ b/src/interp/pf2sex.boot.pamphlet @@ -0,0 +1,526 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp pf2sex.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{Changes} +In the function [[float2Sex]] we need to special case the return value +if the global variable [[$useBFasDefault]] is set to true. This variable +allows ``big'' floating point values. + +The change can be seen from this email from Greg Vanuxem: +\begin{verbatim} +Attached is the patch (pf2sex.patch) that allows the use +of DoubleFloat by default in the interpreter. Test it. + +(1) -> 1.7+7.2 + + (1) 8.9 + Type: Float +(2) -> 1.7-7.2 + + (2) - 5.5 + Type: Float +(3) -> -1.7-7.2 + + (3) - 8.9 + Type: Float +(4) -> )boot $useBFasDefault:=false + +(SPADLET |$useBFasDefault| NIL) +Value = NIL + +(4) -> 1.7+7.2 + + (4) 8.9000000000000004 + Type: DoubleFloat +(5) -> 1.7-7.2 + + (5) - 5.5 + Type: DoubleFloat +(6) -> -1.7-7.2 + + (6) - 8.9000000000000004 + Type: DoubleFloat + + + +\end{verbatim} +\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>> + +)package "BOOT" + +$dotdot := INTERN('"..", '"BOOT") +$specificMsgTags := nil + +-- Pftree to s-expression translation. Used to interface the new parser +-- technology to the interpreter. The input is a parseTree and the +-- output is an old-parser-style s-expression + +pf2Sex pf == + intUnsetQuiet() + $insideRule:local := false + $insideApplication: local := false + $insideSEQ: local := false + pf2Sex1 pf + +pf2Sex1 pf == + pfNothing? pf => + "noBranch" + pfSymbol? pf => + $insideRule = 'left => + s := pfSymbolSymbol pf + ["constant", ["QUOTE", s]] + ["QUOTE", pfSymbolSymbol pf] + pfLiteral? pf => + pfLiteral2Sex pf + pfId? pf => + $insideRule => + s := pfIdSymbol pf + SymMemQ(s, '(%pi %e %i)) => s + ["QUOTE", s] + pfIdSymbol pf + pfApplication? pf => + pfApplication2Sex pf + pfTuple? pf => + ["Tuple", :[pf2Sex1 x for x in pf0TupleParts pf]] + pfIf? pf => + ['IF, pf2Sex1 pfIfCond pf, pf2Sex1 pfIfThen pf, pf2Sex1 pfIfElse pf] + pfTagged? pf => + tag := pfTaggedTag pf + tagPart := + pfTuple? tag => + ['Tuple, :[pf2Sex1 arg for arg in pf0TupleParts tag]] + pf2Sex1 tag + [":", tagPart, pf2Sex1 pfTaggedExpr pf] + pfCoerceto? pf => + ["::", pf2Sex1 pfCoercetoExpr pf, pf2Sex1 pfCoercetoType pf] + pfPretend? pf => + ["pretend", pf2Sex1 pfPretendExpr pf, pf2Sex1 pfPretendType pf] + pfFromdom? pf => + op := opTran pf2Sex1 pfFromdomWhat pf +-- if op = "braceFromCurly" then op := "brace" + if op = "braceFromCurly" then op := "SEQ" + ["$elt", pf2Sex1 pfFromdomDomain pf, op] + pfSequence? pf => + pfSequence2Sex pf + pfExit? pf => + $insideSEQ => ["exit", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf] + ["IF", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf, "noBranch"] + pfLoop? pf => + ["REPEAT", :loopIters2Sex pf0LoopIterators pf] + pfCollect? pf => + pfCollect2Sex pf + pfForin? pf => + ["IN", :[pf2Sex1 x for x in pf0ForinLhs pf], pf2Sex1 pfForinWhole pf] + pfWhile? pf => + ["WHILE", pf2Sex1 pfWhileCond pf] + pfSuchthat? pf => + $insideRule = 'left => + keyedSystemError('"S2GE0017", ['"pf2Sex1: pfSuchThat"]) + ["|", pf2Sex1 pfSuchthatCond pf] + pfDo? pf => + pf2Sex1 pfDoBody pf + pfTyped? pf => + type := pfTypedType pf + pfNothing? type => pf2Sex1 pfTypedId pf + [":", pf2Sex1 pfTypedId pf, pf2Sex1 pfTypedType pf] + pfAssign? pf => + idList := [pf2Sex1 x for x in pf0AssignLhsItems pf] + if #idList ^= 1 then idList := ['Tuple, :idList] + else idList := first idList + ["LET", idList, pf2Sex1 pfAssignRhs pf] + pfDefinition? pf => + pfDefinition2Sex pf + pfLambda? pf => + pfLambda2Sex pf + pfMLambda? pf => + "/throwAway" + pfRestrict? pf => + ["@", pf2Sex1 pfRestrictExpr pf, pf2Sex1 pfRestrictType pf] + pfFree? pf => + ['free, :[pf2Sex1 item for item in pf0FreeItems pf]] + pfLocal? pf => + ['local, :[pf2Sex1 item for item in pf0LocalItems pf]] + pfWrong? pf => + spadThrow() + pfAnd? pf => + ["and", pf2Sex1 pfAndLeft pf, pf2Sex1 pfAndRight pf] + pfOr? pf => + ["or", pf2Sex1 pfOrLeft pf, pf2Sex1 pfOrRight pf] + pfNot? pf => + ["not", pf2Sex1 pfNotArg pf] + pfNovalue? pf => + intSetQuiet() + ["SEQ", pf2Sex1 pfNovalueExpr pf] + pfRule? pf => + pfRule2Sex pf + pfBreak? pf => + ["break", pfBreakFrom pf] + pfMacro? pf => + "/throwAway" + pfReturn? pf => + ["return", pf2Sex1 pfReturnExpr pf] + pfIterate? pf => + ["iterate"] + pfWhere? pf => + args := [pf2Sex1 p for p in pf0WhereContext pf] + #args = 1 => + ["where", pf2Sex1 pfWhereExpr pf, :args] + ["where", pf2Sex1 pfWhereExpr pf, ["SEQ", :args]] + + -- under strange circumstances/piling, system commands can wind + -- up in expressions. This just passes it through as a string for + -- the user to figure out what happened. + pfAbSynOp(pf) = "command" => tokPart(pf) + + keyedSystemError('"S2GE0017", ['"pf2Sex1"]) + +pfLiteral2Sex pf == + type := pfLiteralClass pf + type = 'integer => + READ_-FROM_-STRING pfLiteralString pf + type = 'string or type = 'char => + pfLiteralString pf + type = 'float => + float2Sex pfLiteralString pf + type = 'symbol => + $insideRule => + s := pfSymbolSymbol pf + ["QUOTE", s] + pfSymbolSymbol pf + type = 'expression => + ["QUOTE", pfLeafToken pf] + keyedSystemError('"S2GE0017", ['"pfLiteral2Sex: unexpected form"]) + +symEqual(sym, sym2) == EQ(sym, sym2) + +SymMemQ(sy, l) == MEMQ(sy, l) + +pmDontQuote? sy == + SymMemQ(sy, '(_+ _- _* _*_* _^ _/ log exp pi sqrt ei li erf ci si dilog _ + sin cos tan cot sec csc asin acos atan acot asec acsc _ + sinh cosh tanh coth sech csch asinh acosh atanh acoth asech acsc)) + +pfOp2Sex pf == + alreadyQuoted := pfSymbol? pf + op := pf2Sex1 pf + op is ["QUOTE", realOp] => + $insideRule = 'left => realOp + $insideRule = 'right => + pmDontQuote? realOp => realOp + $quotedOpList := [op, :$quotedOpList] + op + symEqual(realOp, "|") => realOp + symEqual(realOp, ":") => realOp + symEqual(realOp, "?") => realOp + op + op + +pfApplication2Sex pf == + $insideApplication: local := true + op := pfOp2Sex pfApplicationOp pf + op := opTran op + op = "->" => + args := pf0TupleParts pfApplicationArg pf + if pfTuple? CAR args then + typeList := [pf2Sex1 arg for arg in pf0TupleParts CAR args] + else + typeList := [pf2Sex1 CAR args] + args := [pf2Sex1 CADR args, :typeList] + ["Mapping", :args] + symEqual(op, ":") and $insideRule = 'left => + ["multiple", pf2Sex pfApplicationArg pf] + symEqual(op, "?") and $insideRule = 'left => + ["optional", pf2Sex pfApplicationArg pf] + args := pfApplicationArg pf + pfTuple? args => + symEqual(op, "|") and $insideRule = 'left => + pfSuchThat2Sex args + argSex := rest pf2Sex1 args + symEqual(op, ">") => + ["<", CADR argSex, CAR argSex] + symEqual(op, ">=") => + ["not", ["<", CAR argSex, CADR argSex]] + symEqual(op, "<=") => + ["not", ["<", CADR argSex, CAR argSex]] +-- symEqual(op, "reduce") and (#argSex) = 2 => +-- ["REDUCE", first argSex, 0, CADR argSex] + symEqual(op, "AND") => + ["and", CAR argSex, CADR argSex] + symEqual(op, "OR") => + ["or", CAR argSex, CADR argSex] + symEqual(op, "Iterate") => + ["iterate"] + symEqual(op, "by") => + ["BY", :argSex] + symEqual(op, "braceFromCurly") => +-- ["brace", ["construct", :argSex]] + argSex is ["SEQ",:.] => argSex + ["SEQ", :argSex] + op is [qt, realOp] and symEqual(qt, "QUOTE") => + ["applyQuote", op, :argSex] + val := hasOptArgs? argSex => [op, :val] + [op, :argSex] + op is [qt, realOp] and symEqual(qt, "QUOTE") => + ["applyQuote", op, pf2Sex1 args] + symEqual(op, "braceFromCurly") => +-- ["brace", ["construct", pf2Sex1 args]] + x := pf2Sex1 args + x is ["SEQ", :.] => x + ["SEQ", x] + symEqual(op, "by") => + ["BY", pf2Sex1 args] + [op, pf2Sex1 args] + +hasOptArgs? argSex == + nonOpt := nil + opt := nil + for arg in argSex repeat + arg is ["OPTARG", lhs, rhs] => + opt := [[lhs, rhs], :opt] + nonOpt := [arg, :nonOpt] + null opt => nil + NCONC (nreverse nonOpt, [["construct", :nreverse opt]]) + +pfDefinition2Sex pf == + $insideApplication => + ["OPTARG", pf2Sex1 CAR pf0DefinitionLhsItems pf, + pf2Sex1 pfDefinitionRhs pf] + idList := [pf2Sex1 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 := [pf2Sex1 pfTypedType arg, :argTypeList] + systemError '"definition args should be typed" + argList := nreverse argList + retType := + pfNothing? pfLambdaRets pf => nil + pf2Sex1 pfLambdaRets pf + argTypeList := [retType, :nreverse argTypeList] + [argList, :[argTypeList, [nil for arg in argTypeList], + pf2Sex1 pfLambdaBody pf]] + ['id, :['(()), '(()), pf2Sex1 pf]] + +pfLambda2Sex pf == + [argList, :body] := pfLambdaTran pf + ["ADEF", argList, :body] + +pfCollectArgTran pf == + pfCollect? pf => + conds := [pf2Sex1 x for x in pfParts pfCollectIterators pf] + id := pf2Sex1 pfCollectBody pf + conds is [["|", cond]] => + ["|", id, cond] + [id, :conds] + pf2Sex1 pf + +opTran op == + op = $dotdot => "SEGMENT" + op = "[]" => "construct" + op = "{}" => "braceFromCurly" + op = "IS" => "is" + op + +pfSequence2Sex pf == + $insideSEQ:local := true + seq := pfSequence2Sex0 [pf2Sex1 x for x in pf0SequenceArgs pf] + seq is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => + ["ruleset", ["construct", :ruleList]] + seq + +pfSequence2Sex0 seqList == + null seqList => "noBranch" + seqTranList := [] + while seqList ^= nil repeat + item := first seqList + item is ["exit", cond, value] => + item := ["IF", cond, value, pfSequence2Sex0 rest seqList] + seqTranList := [item, :seqTranList] + seqList := nil + seqTranList := [item ,:seqTranList] + seqList := rest seqList + #seqTranList = 1 => first seqTranList + ["SEQ", :nreverse seqTranList] + +float2Sex 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) + $useBFasDefault => + [., frac, :exp] := bfForm + [["$elt", intNewFloat(), 'float], frac, exp, 10] + bfForm + +loopIters2Sex iterList == + result := nil + for iter in iterList repeat + sex := pf2Sex1 iter + sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => + result := [['STEP, var, i, incr], :result] + sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => + result := [['STEP, var, i, incr, j], :result] + sex is ['IN, var, ['SEGMENT, i, j]] => + result := [['STEP, var, i, 1, j], :result] + result := [sex, :result] + nreverse result + +pfCollect2Sex pf == + sex := ["COLLECT", :loopIters2Sex pfParts pfCollectIterators pf, + pf2Sex1 pfCollectBody pf] + sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => + ["|", var, cond] + sex + +pfRule2Sex pf == + $quotedOpList:local := nil + $predicateList:local := nil + $multiVarPredicateList:local := nil + lhs := pfLhsRule2Sex pfRuleLhsItems pf + rhs := pfRhsRule2Sex 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 + +pfLhsRule2Sex lhs == + $insideRule: local := 'left + pf2Sex1 lhs + + +pfRhsRule2Sex rhs == + $insideRule: local := 'right + pf2Sex1 rhs + +pfSuchThat2Sex args == + name := GENTEMP() + argList := pf0TupleParts args + lhsSex := pf2Sex1 CAR argList + rhsSex := pf2Sex CADR argList + $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] + name + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} |