path: root/src/interp/pf2sex.boot

-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007, 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.


)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