aboutsummaryrefslogtreecommitdiff
path: root/src/interp/pf2sex.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/pf2sex.boot.pamphlet')
-rw-r--r--src/interp/pf2sex.boot.pamphlet526
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}