fortran.spad

)abbrev domain RESULT Result
++ Author: Didier Pinchon and Mike Dewar
++ Date Created:  8 April 1994
++ Basic Operations:
++ Related Domains:
++ Also See:
++ AMS Classifications:
++ Keywords:
++ Examples:
++ References:
++ Description: A domain used to return the results from a call to the NAG
++ Library.  It prints as a list of names and types, though the user may
++ choose to display values automatically if he or she wishes.
Result() : Exports==Implementation where

  O  ==> OutputForm

  Exports ==> Join(TableAggregate(Symbol, Any), finiteAggregate) with
    showScalarValues : Boolean -> Boolean
      ++ showScalarValues(true) forces the values of scalar components to be
      ++  displayed rather than just their types.
    showArrayValues : Boolean -> Boolean
      ++ showArrayValues(true) forces the values of array components to be
      ++  displayed rather than just their types.

  Implementation ==> Table(Symbol, Any) add

    -- Constant
    colon := ": "::Symbol::O
    elide := "..."::Symbol::O

    -- Flags
    showScalarValuesFlag : Boolean := false
    showArrayValuesFlag  : Boolean := false

    cleanUpDomainForm(d : SExpression) : O ==
      not list? d => d::O
      #d = 1 => (car d)::O
      -- If the car is an atom then we have a domain constructor, if not
      -- then we have some kind of value.  Since we often can't print these
      -- ^^ers we just elide them.
      not atom? car d => elide
      prefix((car d)::O, [cleanUpDomainForm(u) for u in destruct cdr(d)]$List(O))

    display(v : Any, d : SExpression) : O ==
      not list? d => error "Domain form is non-list"
      #d = 1 =>
       showScalarValuesFlag => objectOf v
       cleanUpDomainForm d
      car(d) = convert('Complex)@SExpression =>
       showScalarValuesFlag => objectOf v
       cleanUpDomainForm d
      showArrayValuesFlag => objectOf v
      cleanUpDomainForm d

    makeEntry(k : Symbol, v : Any) : O ==
      hconcat [k::O, colon, display(v, dom v)]

    coerce(r : %) : O ==
      bracket [makeEntry(key, r.key) for key in reverse! keys(r)]

    showArrayValues(b : Boolean) : Boolean  == showArrayValuesFlag := b
    showScalarValues(b : Boolean) : Boolean == showScalarValuesFlag := b


)abbrev domain FC FortranCode
-- The FortranCode domain is used to represent operations which are to be
-- translated into FORTRAN.
++ Author: Mike Dewar
++ Date Created: April 1991
++ Basic Operations:
++ Related Constructors: FortranProgram, Switch, FortranType
++ Also See:
++ AMS Classifications:
++ Keywords:
++ References:
++ Description:
++ This domain builds representations of program code segments for use with
++ the FortranProgram domain.
FortranCode() : public == private where
  L ==> List
  PI ==> PositiveInteger
  PIN ==> Polynomial Integer
  LS ==> List String
  O ==> OutputForm
  OP ==> Union(Null:"null",
               Assignment:"assignment",
               Conditional:"conditional",
               Return:"return",
               Block:"block",
               Comment:"comment",
               Call:"call",
               For:"for",
               While:"while",
               Repeat:"repeat",
               Goto:"goto",
               Continue:"continue",
               ArrayAssignment:"arrayAssignment",
               Save:"save",
               Stop:"stop",
               Common:"common",
               Print:"print")
  ARRAYASS ==> Record(var : Symbol, rand : O, ints2Floats? : Boolean)
  EXPRESSION ==> Record(ints2Floats? : Boolean, expr : O)
  ASS ==> Record(var : Symbol,
                 arrayIndex : L PIN,
                 rand : EXPRESSION
                )
  COND ==> Record(switch : Switch(),
                  thenClause : %,
                  elseClause : %
                 )
  RETURN ==> Record(empty? : Boolean, value : EXPRESSION)
  BLOCK ==> List %
  COMMENT ==> List String
  COMMON ==> Record(name : Symbol, contents : List Symbol)
  CALL ==> String
  FOR ==> Record(range : SegmentBinding PIN, span : PIN,  body : %)
  LABEL ==> SingleInteger
  LOOP ==> Record(switch : Switch(), body : %)
  PRINTLIST ==> List O
  OPREC ==> Union(nullBranch:"null", assignmentBranch:ASS,
                  arrayAssignmentBranch : ARRAYASS,
                  conditionalBranch : COND, returnBranch : RETURN,
                  blockBranch : BLOCK, commentBranch : COMMENT, callBranch : CALL,
                  forBranch : FOR, labelBranch : LABEL, loopBranch : LOOP,
                  commonBranch : COMMON, printBranch : PRINTLIST)

  public == SetCategory with
    coerce : % -> O
      ++ coerce(f) returns an object of type OutputForm.
    forLoop : (SegmentBinding PIN, %) -> %
     ++ forLoop(i=1..10, c) creates a representation of a FORTRAN DO loop with
     ++ \spad{i} ranging over the values 1 to 10.
    forLoop : (SegmentBinding PIN, PIN, %) -> %
     ++ forLoop(i=1..10, n, c) creates a representation of a FORTRAN DO loop with
     ++ \spad{i} ranging over the values 1 to 10 by n.
    whileLoop : (Switch, %) -> %
     ++ whileLoop(s, c) creates a while loop in FORTRAN.
    repeatUntilLoop : (Switch, %) -> %
     ++ repeatUntilLoop(s, c) creates a repeat ... until loop in FORTRAN.
    gotoJump : SingleInteger -> %
      ++ gotoJump(l) creates a representation of a FORTRAN GOTO statement
    continue : SingleInteger -> %
      ++ continue(l) creates a representation of a FORTRAN CONTINUE labelled
      ++ with l
    comment : String -> %
      ++ comment(s) creates a representation of the String s as a single FORTRAN
      ++ comment.
    comment : List String -> %
      ++ comment(s) creates a representation of the Strings s as a multi-line
      ++ FORTRAN comment.
    call : String -> %
      ++ call(s) creates a representation of a FORTRAN CALL statement
    returns : () -> %
      ++ returns() creates a representation of a FORTRAN RETURN statement.
    returns : Expression MachineFloat -> %
      ++ returns(e) creates a representation of a FORTRAN RETURN statement
      ++ with a returned value.
    returns : Expression MachineInteger -> %
      ++ returns(e) creates a representation of a FORTRAN RETURN statement
      ++ with a returned value.
    returns : Expression MachineComplex -> %
      ++ returns(e) creates a representation of a FORTRAN RETURN statement
      ++ with a returned value.
    returns : Expression Float -> %
      ++ returns(e) creates a representation of a FORTRAN RETURN statement
      ++ with a returned value.
    returns : Expression Integer -> %
      ++ returns(e) creates a representation of a FORTRAN RETURN statement
      ++ with a returned value.
    returns : Expression Complex Float -> %
      ++ returns(e) creates a representation of a FORTRAN RETURN statement
      ++ with a returned value.
    cond : (Switch, %) -> %
      ++ cond(s, e) creates a representation of the FORTRAN expression
      ++ IF (s) THEN e.
    cond : (Switch, %, %) -> %
      ++ cond(s, e, f) creates a representation of the FORTRAN expression
      ++ IF (s) THEN e ELSE f.
    assign : (Symbol, String) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Expression MachineInteger) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Expression MachineFloat) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Expression MachineComplex) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Matrix MachineInteger) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Matrix MachineFloat) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Matrix MachineComplex) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Vector MachineInteger) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Vector MachineFloat) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Vector MachineComplex) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Matrix Expression MachineInteger) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Matrix Expression MachineFloat) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Matrix Expression MachineComplex) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Vector Expression MachineInteger) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Vector Expression MachineFloat) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Vector Expression MachineComplex) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, L PIN, Expression MachineInteger) -> %
      ++ assign(x, l, y) creates a representation of the assignment of \spad{y}
      ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of
      ++ indices).
    assign : (Symbol, L PIN, Expression MachineFloat) -> %
      ++ assign(x, l, y) creates a representation of the assignment of \spad{y}
      ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of
      ++ indices).
    assign : (Symbol, L PIN, Expression MachineComplex) -> %
      ++ assign(x, l, y) creates a representation of the assignment of \spad{y}
      ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of
      ++ indices).
    assign : (Symbol, Expression Integer) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Expression Float) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Expression Complex Float) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Matrix Expression Integer) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Matrix Expression Float) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Matrix Expression Complex Float) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Vector Expression Integer) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Vector Expression Float) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, Vector Expression Complex Float) -> %
      ++ assign(x, y) creates a representation of the FORTRAN expression
      ++ x=y.
    assign : (Symbol, L PIN, Expression Integer) -> %
      ++ assign(x, l, y) creates a representation of the assignment of \spad{y}
      ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of
      ++ indices).
    assign : (Symbol, L PIN, Expression Float) -> %
      ++ assign(x, l, y) creates a representation of the assignment of \spad{y}
      ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of
      ++ indices).
    assign : (Symbol, L PIN, Expression Complex Float) -> %
      ++ assign(x, l, y) creates a representation of the assignment of \spad{y}
      ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of
      ++ indices).
    block : List(%) -> %
      ++ block(l) creates a representation of the statements in l as a block.
    stop : () -> %
      ++ stop() creates a representation of a STOP statement.
    save : () -> %
      ++ save() creates a representation of a SAVE statement.
    printStatement : List O -> %
      ++ printStatement(l) creates a representation of a PRINT statement.
    common : (Symbol, List Symbol) -> %
      ++ common(name, contents) creates a representation a named common block.
    operation : % -> OP
      ++ operation(f) returns the name of the operation represented by \spad{f}.
    code : % -> OPREC
      ++ code(f) returns the internal representation of the object represented
      ++ by \spad{f}.
    printCode : % -> Void
      ++ printCode(f) prints out \spad{f} in FORTRAN notation.
    getCode : % -> LS
      ++ getCode(f) returns a list of strings representing \spad{f}
      ++ in Fortran notation.  This is used by the FortranProgram domain.
    setLabelValue : SingleInteger -> SingleInteger
      ++ setLabelValue(i) resets the counter which produces labels to i

  private == add
    import from Void
    import from ASS
    import from COND
    import from RETURN
    import from L PIN
    import from O
    import from LS
    import from FortranType
    import from TheSymbolTable
    import from FortranCodeTools

    get_assignment(name : O,e : O, int_to_floats? : Boolean) : LS ==
        getStatement(elt('=::O, [name, e]), int_to_floats?)

    format_switch(switch1 : O, l : LS) : List(LS) ==
        if LISTP(switch1)$Lisp then
            l1 : List(O) := switch1 pretend List(O)
            if EQ(first(l1), 'NULL)$Lisp then
                switch1 := first rest l1
        r := reverse!(statement2Fortran switch1)
        while not(empty?(r)) and not(first(r) = "%l") repeat
            l := cons(first(r), l)
            r := rest(r)
        [l, r]

    fortFormatIf1(switch1 : O, i : Integer, kind : String) : LS ==
        l : LS := [")THEN"]
        changeExprLength(-i) -- Leave room for IF( ... )THEN
        (l, r) := format_switch(switch1, l)
        changeExprLength(i)
        reverse! append(reverse!(l), cons(kind, r))

    fortFormatIf(switch1 : O) : LS ==
        do_with_error_env1(() +-> fortFormatIf1(switch1, 8, "IF("))

    fortFormatElseIf(switch1 : O) : LS ==
        do_with_error_env1(() +-> fortFormatIf1(switch1, 12, "ELSEIF("))

    fortFormatIfGoto1(switch1 : O, lab : SingleInteger) : LS ==
        l : LS := [")GOTO ", convert(lab)@String]
        changeExprLength(-8) -- Leave room for IF( ... )THEN
        (l, r) := format_switch(switch1, l)
        changeExprLength(8)
        reverse! append(reverse!(l), cons("IF(", r))

    fortFormatIfGoto(switch1 : O, lab : SingleInteger) : LS ==
        do_with_error_env1(() +-> fortFormatIfGoto1(switch1, lab))

    fortFormatLabelledIfGoto1(switch1 : O, lab1 : SingleInteger,
                             lab2 : SingleInteger) : LS ==
        l := fortFormatIfGoto1(switch1, lab2)
        labString := convert(lab1)@String
        for i in #(labString)..5 repeat labString := concat(labString, " ")
        l := fort_clean_lines(l)
        cons(concat(labString, first(l)(7..)), rest(l))

    fortFormatLabelledIfGoto(switch1 : O, lab1 : SingleInteger,
                             lab2 : SingleInteger) : LS ==
        fortFormatLabelledIfGoto1(switch1, lab1, lab2)

    getfortarrayexp1(name : Symbol, of : O, int_to_floats? : Boolean) : LS ==
        l := expression2Fortran1(() +-> name, of, int_to_floats?)
        first(l, (#l - 2)::NonNegativeInteger)

    getfortarrayexp(name : Symbol, of : O, int_to_floats? : Boolean) : LS ==
        do_with_error_env2(int_to_floats?,
                           () +-> getfortarrayexp1(name, of, int_to_floats?))

    fortFormatDo1(var1 : Symbol, lo : O, hi : O, incr : O,
                 lab : SingleInteger) : LS ==
        lol := statement2Fortran lo
        hil := statement2Fortran hi
        incl : LS :=
            EQUAL(incr, 1@Integer)$Lisp => cons(",", statement2Fortran incr)
            []
        il := append(lol, cons(",", append(hil, incl)))
        append(["DO ", convert(lab)@String, " ", string(var1), "="], il)

    fortFormatDo(var1 : Symbol, lo : O, hi : O, inc : O,
                 lab : SingleInteger) : LS ==
        do_with_error_env2(false,
                           () +-> fortFormatDo1(var1, lo, hi, inc, lab))

    addCommas(l : List Symbol) : LS ==
        empty?(l) => []
        r := [string(first l)]
        for e in rest l repeat r := cons(string(e), cons(",", r))
        reverse!(r)

    Rep := Record(op : OP, data : OPREC)

    -- We need to be able to generate unique labels
    labelValue : SingleInteger := 25000::SingleInteger
    setLabelValue(u : SingleInteger) : SingleInteger == labelValue := u
    newLabel() : SingleInteger ==
      labelValue := labelValue + 1$SingleInteger
      labelValue

    commaSep(l : List String) : List(String) ==
      [(l.1),:[:[",",u] for u in rest(l)]]

    getReturn(rec : RETURN) : LS ==
      returnToken : O := "RETURN"::Symbol::O
      elt(rec, empty?)$RETURN =>
            getStatement(returnToken, false)
      rt : EXPRESSION := elt(rec, value)$RETURN
      rv : O := elt(rt, expr)$EXPRESSION
      getStatement(elt(returnToken, [rv]),
                   elt(rt, ints2Floats?)$EXPRESSION)

    getStop() : LS ==
        fort_clean_lines(["STOP"]$LS)

    getSave() : LS ==
        fort_clean_lines(["SAVE"])

    getCommon(u : COMMON) : LS ==
        fort_clean_lines(append(["COMMON", " /", string (u.name), "/ "]$LS,
                                addCommas(u.contents)))

    getPrint(l : PRINTLIST) : LS ==
        ll : LS := ["PRINT*"]
        for i in l repeat
            ll := append(ll, cons(",", expression2Fortran(i)))
        fort_clean_lines(ll)

    getBlock(rec : BLOCK) : LS ==
        indentFortLevel(1)
        expr : LS := []
        for u in rec repeat
            expr := append(expr, getCode(u))
        indentFortLevel(-1)
        expr

    getBody(f : %) : LS ==
      operation(f) case Block => getCode f
      indentFortLevel(1@Integer)
      expr := getCode f
      indentFortLevel(-1@Integer)
      expr

    getElseIf(f : %) : LS ==
      rec := code f
      expr : LS :=
          fortFormatElseIf(elt(rec.conditionalBranch, switch)$COND::O)
      expr :=
          append(expr, getBody elt(rec.conditionalBranch, thenClause)$COND)
      elseBranch := elt(rec.conditionalBranch, elseClause)$COND
      not(operation(elseBranch) case Null) =>
          operation(elseBranch) case Conditional =>
              append(expr, getElseIf elseBranch)
          expr := append(expr, getStatement('ELSE::O, false))
          expr := append(expr, getBody elseBranch)
      expr

    getContinue(label : SingleInteger) : LS ==
        lab := convert(label)@String
        if #lab > 6 then error "Label too big"
        cnt := "CONTINUE"
        sp  : O := hspace(get_fort_indent() - #lab)
        [STRCONC(lab, sp, cnt)$Lisp]$LS

    getGoto(label : SingleInteger) : LS ==
        fort_clean_lines([concat("GOTO ", convert(label)@String)])

    getRepeat(repRec : LOOP) : LS ==
      sw : Switch := NOT elt(repRec, switch)$LOOP
      lab := newLabel()
      bod := elt(repRec, body)$LOOP
      append(getContinue lab,
             append(getBody bod, fortFormatIfGoto(sw::O, lab)))

    getWhile(whileRec : LOOP) : LS ==
      sw := NOT elt(whileRec, switch)$LOOP
      lab1 := newLabel()
      lab2 := newLabel()
      bod := elt(whileRec, body)$LOOP
      ig : LS := fortFormatLabelledIfGoto(sw::O, lab1, lab2)
      rl1 := [ig, getBody bod, getBody gotoJump(lab1),
              getContinue lab2]$List(LS)
      concat(rl1)$LS

    getArrayAssign(rec : ARRAYASS) : LS ==
        getfortarrayexp(rec.var, rec.rand, rec.ints2Floats?)

    getAssign(rec : ASS) : LS ==
        indices : L PIN := elt(rec, arrayIndex)$ASS
        lhs := elt(rec, var)$ASS::O
        if not(empty?(indices))  then
            lhs := elt(lhs, map((ii : PIN) : O +-> ii::O, indices
                               )$ListFunctions2(PIN, O))
        ass := elt(rec, rand)$ASS
        ex := elt(ass, expr)$EXPRESSION
        get_assignment(lhs, ex, elt(ass, ints2Floats?)$EXPRESSION)

    getCond(rec : COND) : LS ==
      expr := append(fortFormatIf(elt(rec, switch)$COND::O),
                     getBody elt(rec, thenClause)$COND)
      elseBranch := elt(rec, elseClause)$COND
      if not(operation(elseBranch) case Null) then
        operation(elseBranch) case Conditional =>
            expr := append(expr, getElseIf elseBranch)
        expr := append(expr,
                       append(getStatement('ELSE::O, false),
                              getBody elseBranch))
      append(expr, getStatement('ENDIF::O, false))

    getComment(rec : COMMENT) : LS ==
        [concat("C     ", c)$String for c in rec]

    getCall(rec : CALL) : LS ==
      expr := concat("CALL ",rec)$String
      #expr > 1320 => error "Fortran CALL too large"
      fort_clean_lines([expr])

    getFor(rec : FOR) : LS ==
      rnge : SegmentBinding PIN := elt(rec, range)$FOR
      increment : PIN := elt(rec, span)$FOR
      lab : SingleInteger := newLabel()
      declare!(variable rnge, fortranInteger())
      expr : LS := fortFormatDo(variable rnge, (low(segment(rnge)))::O, _
          (high(segment(rnge)))::O, increment::O, lab)
      append(expr, append(getBody elt(rec, body)$FOR, getContinue(lab)))

    getCode(f : %) : LS ==
      opp : OP := operation f
      rec : OPREC := code f
      opp case Assignment => getAssign(rec.assignmentBranch)
      opp case ArrayAssignment => getArrayAssign(rec.arrayAssignmentBranch)
      opp case Conditional => getCond(rec.conditionalBranch)
      opp case Return => getReturn(rec.returnBranch)
      opp case Block => getBlock(rec.blockBranch)
      opp case Comment => getComment(rec.commentBranch)
      opp case Call => getCall(rec.callBranch)
      opp case For => getFor(rec.forBranch)
      opp case Continue => getContinue(rec.labelBranch)
      opp case Goto => getGoto(rec.labelBranch)
      opp case Repeat => getRepeat(rec.loopBranch)
      opp case While => getWhile(rec.loopBranch)
      opp case Save => getSave()
      opp case Stop => getStop()
      opp case Print => getPrint(rec.printBranch)
      opp case Common => getCommon(rec.commonBranch)
      error "Unsupported program construct."

    printCode(f : %) : Void ==
      displayLines(getCode f)
      void()$Void

    code (f : %) : OPREC ==
      elt(f, data)$Rep

    operation (f : %) : OP ==
      elt(f, op)$Rep

    common(name : Symbol, contents : List Symbol) : % ==
      [["common"]$OP,[[name,contents]$COMMON]$OPREC]$Rep

    stop() : % ==
      [["stop"]$OP,["null"]$OPREC]$Rep

    save() : % ==
      [["save"]$OP,["null"]$OPREC]$Rep

    printStatement(l : List O) : % ==
      [["print"]$OP,[l]$OPREC]$Rep

    comment(s : List String) : % ==
      [["comment"]$OP,[s]$OPREC]$Rep

    comment(s : String) : % ==
      [["comment"]$OP,[list s]$OPREC]$Rep

    forLoop(r : SegmentBinding PIN, body : %) : % ==
      [["for"]$OP,[[r,(incr segment r)::PIN,body]$FOR]$OPREC]$Rep

    forLoop(r : SegmentBinding PIN, increment : PIN, body : %) : % ==
      [["for"]$OP,[[r,increment,body]$FOR]$OPREC]$Rep

    gotoJump(l : SingleInteger) : % ==
      [["goto"]$OP,[l]$OPREC]$Rep

    continue(l : SingleInteger) : % ==
      [["continue"]$OP,[l]$OPREC]$Rep

    whileLoop(sw : Switch, b : %) : % ==
      [["while"]$OP,[[sw,b]$LOOP]$OPREC]$Rep

    repeatUntilLoop(sw : Switch, b : %) : % ==
      [["repeat"]$OP,[[sw,b]$LOOP]$OPREC]$Rep

    returns() : % ==
      v := [false, 0::O]$EXPRESSION
      [["return"]$OP,[[true,v]$RETURN]$OPREC]$Rep

    returns(v : Expression MachineInteger) : % ==
      [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep

    returns(v : Expression MachineFloat) : % ==
      [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep

    returns(v : Expression MachineComplex) : % ==
      [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep

    returns(v : Expression Integer) : % ==
      [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep

    returns(v : Expression Float) : % ==
      [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep

    returns(v : Expression Complex Float) : % ==
      [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep

    block(l : List %) : % ==
      [["block"]$OP,[l]$OPREC]$Rep

    cond(sw : Switch, thenC : %) : % ==
      [["conditional"]$OP,
       [[sw,thenC,[["null"]$OP,["null"]$OPREC]$Rep]$COND]$OPREC]$Rep

    cond(sw : Switch, thenC : %, elseC : %) : % ==
      [["conditional"]$OP,[[sw,thenC,elseC]$COND]$OPREC]$Rep

    coerce(f : %) : O ==
      (f.op)::O

    assign(v : Symbol, rhs : String) : % ==
      [["assignment"]$OP,[[v, []::L PIN,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Matrix MachineInteger) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Matrix MachineFloat) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Matrix MachineComplex) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Vector MachineInteger) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Vector MachineFloat) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Vector MachineComplex) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Matrix Expression MachineInteger) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Matrix Expression MachineFloat) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Matrix Expression MachineComplex) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Vector Expression MachineInteger) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Vector Expression MachineFloat) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Vector Expression MachineComplex) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, index : L PIN, rhs : Expression MachineInteger) : % ==
      [["assignment"]$OP,[[v,index,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    assign(v : Symbol, index : L PIN, rhs : Expression MachineFloat) : % ==
      [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    assign(v : Symbol, index : L PIN, rhs : Expression MachineComplex) : % ==
      [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Expression MachineInteger) : % ==
      [["assignment"]$OP,[[v, []::L PIN,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Expression MachineFloat) : % ==
      [["assignment"]$OP,[[v, []::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Expression MachineComplex) : % ==
      [["assignment"]$OP,[[v, []::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Matrix Expression Integer) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Matrix Expression Float) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Matrix Expression Complex Float) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Vector Expression Integer) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Vector Expression Float) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Vector Expression Complex Float) : % ==
      [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep

    assign(v : Symbol, index : L PIN, rhs : Expression Integer) : % ==
      [["assignment"]$OP,[[v,index,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    assign(v : Symbol, index : L PIN, rhs : Expression Float) : % ==
      [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    assign(v : Symbol, index : L PIN, rhs : Expression Complex Float) : % ==
      [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Expression Integer) : % ==
      [["assignment"]$OP,[[v, []::L PIN,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Expression Float) : % ==
      [["assignment"]$OP,[[v, []::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    assign(v : Symbol, rhs : Expression Complex Float) : % ==
      [["assignment"]$OP,[[v, []::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep

    call(s : String) : % ==
      [["call"]$OP,[s]$OPREC]$Rep

)abbrev domain FORTRAN FortranProgram
++ Author: Mike Dewar
++ Date Created: October 1992
++ Basic Operations:
++ Related Constructors: FortranType, FortranCode, Switch
++ Also See:
++ AMS Classifications:
++ Keywords:
++ References:
++ Description: \spadtype{FortranProgram} allows the user to build and manipulate simple
++ models of FORTRAN subprograms.  These can then be transformed into actual FORTRAN
++ notation.
FortranProgram(name, returnType, arguments, symbols) : Exports == Implement where
  name       : Symbol
  returnType : Union(fst:FortranScalarType,void:"void")
  arguments  : List Symbol
  symbols    : SymbolTable

  O ==> OutputForm
  FC     ==> FortranCode
  EXPR   ==> Expression
  INT    ==> Integer
  CMPX   ==> Complex
  MINT   ==> MachineInteger
  MFLOAT ==> MachineFloat
  MCMPLX ==> MachineComplex
  REP    ==> Record(localSymbols : SymbolTable, code : List FortranCode)

  Exports ==> FortranProgramCategory with
    coerce      : FortranCode -> %
        ++ coerce(fc) \undocumented{}
    coerce      : List FortranCode -> %
        ++ coerce(lfc) \undocumented{}
    coerce      : REP -> %
        ++ coerce(r) \undocumented{}
    coerce      : EXPR MINT -> %
        ++ coerce(e) \undocumented{}
    coerce      : EXPR MFLOAT -> %
        ++ coerce(e) \undocumented{}
    coerce      : EXPR MCMPLX -> %
        ++ coerce(e) \undocumented{}
    coerce      : Equation EXPR MINT -> %
        ++ coerce(eq) \undocumented{}
    coerce      : Equation EXPR MFLOAT -> %
        ++ coerce(eq) \undocumented{}
    coerce      : Equation EXPR MCMPLX -> %
        ++ coerce(eq) \undocumented{}
    coerce      : EXPR INT -> %
        ++ coerce(e) \undocumented{}
    coerce      : EXPR Float -> %
        ++ coerce(e) \undocumented{}
    coerce      : EXPR CMPX Float -> %
        ++ coerce(e) \undocumented{}
    coerce      : Equation EXPR INT -> %
        ++ coerce(eq) \undocumented{}
    coerce      : Equation EXPR Float -> %
        ++ coerce(eq) \undocumented{}
    coerce      : Equation EXPR CMPX Float -> %
        ++ coerce(eq) \undocumented{}

  Implement ==> add

    Rep := REP

    LS ==> List(String)

    import from TheSymbolTable
    import from FortranCode
    import from FortranCodeTools

    makeRep(b : List FortranCode) : % ==
      construct(empty()$SymbolTable, b)$REP

    codeFrom(u : %) : List FortranCode ==
      elt(u::Rep, code)$REP

    outputAsFortran(p : %) : Void ==
      setLabelValue(25000::SingleInteger)$FC
      -- Do this first to catch any extra type declarations:
      tempName := 'FPTEMP
      newSubProgram(tempName)
      clear_used_intrinsics()
      body : List LS := [getCode(l)$FortranCode for l in codeFrom(p)]
      intrinsics : LS := get_used_intrinsics()
      endSubProgram()
      fortFormatHead(name, returnType, arguments)
      printTypes(symbols)$SymbolTable
      printTypes((p::Rep).localSymbols)$SymbolTable
      printTypes(tempName)$TheSymbolTable
      if not(empty?(intrinsics)) then
          fortFormatTypeLines("INTRINSIC", intrinsics)
      clearTheSymbolTable(tempName)
      for expr in body repeat displayLines(expr)
      dispStatement('END::OutputForm)

    mkString(l : List Symbol) : String ==
      unparse(convert(l)@InputForm)$InputForm

    checkVariables(user : List Symbol, target : List Symbol) : Void ==
      -- We don't worry about whether the user has subscripted the
      -- variables or not.
      setDifference(map(name$Symbol, user), target) ~= empty()$List(Symbol) =>
        s1 : String := mkString(user)
        s2 : String := mkString(target)
        error ["Incompatible variable lists:", s1, s2]
      void()$Void

    coerce(u : EXPR MINT) : % ==
      checkVariables(variables(u)$EXPR(MINT), arguments)
      l : List(FC) := [assign(name, u)$FC, returns()$FC]
      makeRep l

    coerce(u : Equation EXPR MINT) : % ==
      retractIfCan(lhs u)@Union(Kernel(EXPR MINT),"failed") case "failed" =>
        error "left hand side is not a kernel"
      vList : List Symbol := variables lhs u
      #vList ~= #arguments =>
        error "Incorrect number of arguments"
      veList : List EXPR MINT := [w::EXPR(MINT) for w in vList]
      aeList : List EXPR MINT := [w::EXPR(MINT) for w in arguments]
      eList : List Equation EXPR MINT :=
        [equation(w, v) for w in veList for v in aeList]
      (subst(rhs u, eList))::%

    coerce(u : EXPR MFLOAT) : % ==
      checkVariables(variables(u)$EXPR(MFLOAT), arguments)
      l : List(FC) := [assign(name, u)$FC, returns()$FC]
      makeRep l

    coerce(u : Equation EXPR MFLOAT) : % ==
      retractIfCan(lhs u)@Union(Kernel(EXPR MFLOAT),"failed") case "failed" =>
        error "left hand side is not a kernel"
      vList : List Symbol := variables lhs u
      #vList ~= #arguments =>
        error "Incorrect number of arguments"
      veList : List EXPR MFLOAT := [w::EXPR(MFLOAT) for w in vList]
      aeList : List EXPR MFLOAT := [w::EXPR(MFLOAT) for w in arguments]
      eList : List Equation EXPR MFLOAT :=
        [equation(w, v) for w in veList for v in aeList]
      (subst(rhs u, eList))::%

    coerce(u : EXPR MCMPLX) : % ==
      checkVariables(variables(u)$EXPR(MCMPLX), arguments)
      l : List(FC) := [assign(name, u)$FC, returns()$FC]
      makeRep l

    coerce(u : Equation EXPR MCMPLX) : % ==
      retractIfCan(lhs u)@Union(Kernel EXPR MCMPLX,"failed") case "failed"=>
        error "left hand side is not a kernel"
      vList : List Symbol := variables lhs u
      #vList ~= #arguments =>
        error "Incorrect number of arguments"
      veList : List EXPR MCMPLX := [w::EXPR(MCMPLX) for w in vList]
      aeList : List EXPR MCMPLX := [w::EXPR(MCMPLX) for w in arguments]
      eList : List Equation EXPR MCMPLX :=
        [equation(w, v) for w in veList for v in aeList]
      (subst(rhs u, eList))::%


    coerce(u : REP) : % ==
      u@Rep

    coerce(u : %) : OutputForm ==
      coerce(name)$Symbol

    coerce(c : List FortranCode) : % ==
      makeRep c

    coerce(c : FortranCode) : % ==
      makeRep [c]

    coerce(u : EXPR INT) : % ==
      checkVariables(variables(u)$EXPR(INT), arguments)
      l : List(FC) := [assign(name, u)$FC, returns()$FC]
      makeRep l

    coerce(u : Equation EXPR INT) : % ==
      retractIfCan(lhs u)@Union(Kernel(EXPR INT),"failed") case "failed" =>
        error "left hand side is not a kernel"
      vList : List Symbol := variables lhs u
      #vList ~= #arguments =>
        error "Incorrect number of arguments"
      veList : List EXPR INT := [w::EXPR(INT) for w in vList]
      aeList : List EXPR INT := [w::EXPR(INT) for w in arguments]
      eList : List Equation EXPR INT :=
        [equation(w, v) for w in veList for v in aeList]
      (subst(rhs u, eList))::%

    coerce(u : EXPR Float) : % ==
      checkVariables(variables(u)$EXPR(Float), arguments)
      l : List(FC) := [assign(name, u)$FC, returns()$FC]
      makeRep l

    coerce(u : Equation EXPR Float) : % ==
      retractIfCan(lhs u)@Union(Kernel(EXPR Float),"failed") case "failed" =>
        error "left hand side is not a kernel"
      vList : List Symbol := variables lhs u
      #vList ~= #arguments =>
        error "Incorrect number of arguments"
      veList : List EXPR Float := [w::EXPR(Float) for w in vList]
      aeList : List EXPR Float := [w::EXPR(Float) for w in arguments]
      eList : List Equation EXPR Float :=
        [equation(w, v) for w in veList for v in aeList]
      (subst(rhs u, eList))::%

    coerce(u : EXPR Complex Float) : % ==
      checkVariables(variables(u)$EXPR(Complex Float), arguments)
      l : List(FC) := [assign(name, u)$FC, returns()$FC]
      makeRep l

    coerce(u : Equation EXPR CMPX Float) : % ==
      retractIfCan(lhs u)@Union(Kernel EXPR CMPX Float,"failed") case "failed"=>
        error "left hand side is not a kernel"
      vList : List Symbol := variables lhs u
      #vList ~= #arguments =>
        error "Incorrect number of arguments"
      veList : List EXPR CMPX Float := [w::EXPR(CMPX Float) for w in vList]
      aeList : List EXPR CMPX Float := [w::EXPR(CMPX Float) for w in arguments]
      eList : List Equation EXPR CMPX Float :=
        [equation(w, v) for w in veList for v in aeList]
      (subst(rhs u, eList))::%

)abbrev domain M3D ThreeDimensionalMatrix
++ Author: William Naylor
++ Date Created: 20 October 1993
++ BasicFunctions:
++ Related Constructors: Matrix
++ Also See: PrimitiveArray
++ AMS Classification:
++ Keywords:
++ References:
++ Description:
++ This domain represents three dimensional matrices over a general object type
-- Currently unused.
ThreeDimensionalMatrix(R) : Exports == Implementation where

  R : SetCategory
  L ==> List
  NNI ==> NonNegativeInteger
  A1AGG ==> OneDimensionalArrayAggregate
  ARRAY1 ==> OneDimensionalArray
  PA ==> PrimitiveArray
  INT ==> Integer
  PI ==> PositiveInteger

  Exports ==> HomogeneousAggregate(R) with

    if R has Ring then
      zeroMatrix : (NNI, NNI, NNI) -> %
         ++ zeroMatrix(i, j, k) create a matrix with all zero terms
      identityMatrix : (NNI) -> %
         ++ identityMatrix(n) create an identity matrix
         ++ we note that this must be square
      plus : (%, %) -> %
         ++ plus(x, y) adds two matrices, term by term
         ++ we note that they must be the same size
    construct : (L L L R) -> %
       ++ construct(lll) creates a 3-D matrix from a List List List R lll
    elt : (%, NNI, NNI, NNI) -> R
       ++ elt(x, i, j, k) extract an element from the matrix x
    setelt! : (%, NNI, NNI, NNI, R) -> R
       ++ setelt!(x, i, j, k, s) (or x.i.j.k := s) sets a specific element of the array to some value of type R
    coerce : (PA PA PA R) -> %
       ++ coerce(p) moves from the representation type
       ++ (PrimitiveArray  PrimitiveArray  PrimitiveArray R)
       ++ to the domain
    coerce : % -> (PA PA PA R)
        ++ coerce(x) moves from the domain to the representation type
    matrixConcat3D : (Symbol, %, %) -> %
         ++ matrixConcat3D(s, x, y) concatenates two 3-D matrices along a specified axis
    matrixDimensions : % -> Vector NNI
         ++ matrixDimensions(x) returns the dimensions of a matrix

  Implementation ==>  (PA PA PA R) add

    import from (PA PA PA R)
    import from (PA PA R)
    import from (PA R)
    import from R

    matrix1, matrix2, resultMatrix : %

    -- function to concatenate two matrices
    -- the first argument must be a symbol, which is either i, j or k
    -- to specify the direction in which the concatenation is to take place
    matrixConcat3D(dir : Symbol, mat1 : %, mat2 : %) : % ==
      not ((dir = 'i) or (dir = 'j) or (dir = 'k))_
       => error "the axis of concatenation must be i,j or k"
      mat1Dim := matrixDimensions(mat1)
      mat2Dim := matrixDimensions(mat2)
      iDim1 := mat1Dim.1
      jDim1 := mat1Dim.2
      kDim1 := mat1Dim.3
      iDim2 := mat2Dim.1
      jDim2 := mat2Dim.2
      kDim2 := mat2Dim.3
      matRep1 : (PA PA PA R) := copy(mat1 :: (PA PA PA R))$(PA PA PA R)
      matRep2 : (PA PA PA R) := copy(mat2 :: (PA PA PA R))$(PA PA PA R)
      retVal : %

      if (dir = 'i) then
        -- j, k dimensions must agree
        if (not ((jDim1 = jDim2) and (kDim1 = kDim2)))
        then
          error "jxk do not agree"
        else
          retVal := (coerce(concat(matRep1, matRep2)$(PA PA PA R))$%)@%

      if (dir = 'j) then
        -- i, k dimensions must agree
        if (not ((iDim1 = iDim2) and (kDim1 = kDim2)))
        then
          error "ixk do not agree"
        else
          for i in 0..(iDim1-1) repeat
            setelt!(matRep1, i, (concat(elt(matRep1, i)$(PA PA PA R)_
             , elt(matRep2, i)$(PA PA PA R))$(PA PA R))@(PA PA R))$(PA PA PA R)
          retVal := (coerce(matRep1)$%)@%

      if (dir = 'k) then
        temp : (PA PA R)
        -- i, j dimensions must agree
        if (not ((iDim1 = iDim2) and (jDim1 = jDim2)))
        then
          error "ixj do not agree"
        else
          for i in 0..(iDim1-1) repeat
            temp := copy(elt(matRep1, i)$(PA PA PA R))$(PA PA R)
            for j in 0..(jDim1-1) repeat
              setelt!(temp, j, concat(elt(elt(matRep1, i)$(PA PA PA R)_
              , j)$(PA PA R), elt(elt(matRep2, i)$(PA PA PA R), j)$(PA PA R)_
              )$(PA R))$(PA PA R)
            setelt!(matRep1, i, temp)$(PA PA PA R)
          retVal := (coerce(matRep1)$%)@%

      retVal

    matrixDimensions(mat : %) : Vector NNI ==
      matRep : (PA PA PA R) := mat :: (PA PA PA R)
      iDim : NNI := (#matRep)$(PA PA PA R)
      matRep2 : PA PA R := elt(matRep, 0)$(PA PA PA R)
      jDim : NNI := (#matRep2)$(PA PA R)
      matRep3 : (PA R) := elt(matRep2, 0)$(PA PA R)
      kDim : NNI := (#matRep3)$(PA R)
      retVal : Vector NNI := new(3, 0)$(Vector NNI)
      retVal.1 := iDim
      retVal.2 := jDim
      retVal.3 := kDim
      retVal

    coerce(matrixRep : (PA PA PA R)) : % == matrixRep pretend %

    coerce(mat : %) : (PA PA PA R) == mat pretend (PA PA PA R)

    -- i, j, k must be with in the bounds of the matrix
    elt(mat : %, i : NNI, j : NNI, k : NNI) : R ==
      matDims := matrixDimensions(mat)
      iLength := matDims.1
      jLength := matDims.2
      kLength := matDims.3
      ((i > iLength) or (j > jLength) or (k > kLength) or (i = 0) or (j = 0) or_
(k = 0)) => error "coordinates must be within the bounds of the matrix"
      matrixRep : PA PA PA R := mat :: (PA PA PA R)
      elt(elt(elt(matrixRep, i-1)$(PA PA PA R), j-1)$(PA PA R), k-1)$(PA R)

    setelt!(mat : %, i : NNI, j : NNI, k : NNI, val : R)_
        : R ==
      matDims := matrixDimensions(mat)
      iLength := matDims.1
      jLength := matDims.2
      kLength := matDims.3
      ((i > iLength) or (j > jLength) or (k > kLength) or (i = 0) or (j = 0) or_
(k = 0)) => error "coordinates must be within the bounds of the matrix"
      matrixRep : PA PA PA R := mat :: (PA PA PA R)
      row2 : PA PA R := copy(elt(matrixRep, i-1)$(PA PA PA R))$(PA PA R)
      row1 : PA R := copy(elt(row2, j-1)$(PA PA R))$(PA R)
      setelt!(row1, k - 1, val)$(PA R)
      setelt!(row2, j - 1, row1)$(PA PA R)
      setelt!(matrixRep, i - 1, row2)$(PA PA PA R)
      val

    if R has Ring then
      zeroMatrix(iLength : NNI, jLength : NNI, kLength : NNI) : % ==
        (new(iLength, new(jLength, new(kLength, (0$R))$(PA R))$(PA PA R))$(PA PA PA R)) :: %

      identityMatrix(iLength : NNI) : % ==
        retValueRep : PA PA PA R := zeroMatrix(iLength, iLength, iLength)$% :: (PA PA PA R)
        row1 : PA R
        row2 : PA PA R
        row1empty : PA R := new(iLength, 0$R)$(PA R)
        row2empty : PA PA R := new(iLength, copy(row1empty)$(PA R))$(PA PA R)
        for count in 0..(iLength-1) repeat
          row1 := copy(row1empty)$(PA R)
          setelt!(row1, count, 1$R)$(PA R)
          row2 := copy(row2empty)$(PA PA R)
          setelt!(row2, count, copy(row1)$(PA R))$(PA PA R)
          setelt!(retValueRep, count, copy(row2)$(PA PA R))$(PA PA PA R)
        retValueRep :: %


      plus(mat1 : %, mat2 : %) : % ==

        mat1Dims := matrixDimensions(mat1)
        iLength1 := mat1Dims.1
        jLength1 := mat1Dims.2
        kLength1 := mat1Dims.3

        mat2Dims := matrixDimensions(mat2)
        iLength2 := mat2Dims.1
        jLength2 := mat2Dims.2
        kLength2 := mat2Dims.3

        -- check that the dimensions are the same
        (not (iLength1 = iLength2) or not (jLength1 = jLength2) or not(kLength1 = kLength2))_
         => error "error the matrices are different sizes"

        sum : R
        row1 : (PA R) := new(kLength1, 0$R)$(PA R)
        row2 : (PA PA R) := new(jLength1, copy(row1)$(PA R))$(PA PA R)
        row3 : (PA PA PA R) := new(iLength1, copy(row2)$(PA PA R))$(PA PA PA R)

        for i in 1..iLength1 repeat
          for j in 1..jLength1 repeat
            for k in 1..kLength1 repeat
              sum := (elt(mat1, i, j, k)::R +$R elt(mat2, i, j, k)::R)
              setelt!(row1, k - 1, sum)$(PA R)
            setelt!(row2, j - 1, copy(row1)$(PA R))$(PA PA R)
          setelt!(row3, i - 1, copy(row2)$(PA PA R))$(PA PA PA R)

        resultMatrix := (row3 pretend %)

        resultMatrix

    construct(listRep : L L L R) : % ==

      (#listRep)$(L L L R) = 0 => error "empty list"
      (#(listRep.1))$(L L R) = 0 => error "empty list"
      (#((listRep.1).1))$(L R) = 0 => error "empty list"
      iLength := (#listRep)$(L L L R)
      jLength := (#(listRep.1))$(L L R)
      kLength := (#((listRep.1).1))$(L R)

      --first check that the matrix is in the correct form
      for subList in listRep repeat
        not((#subList)$(L L R) = jLength) => error_
 "can not have an irregular shaped matrix"
        for subSubList in subList repeat
          not((#(subSubList))$(L R) = kLength) => error_
 "can not have an irregular shaped matrix"

      row1 : (PA R) := new(kLength, ((listRep.1).1).1)$(PA R)
      row2 : (PA PA R) := new(jLength, copy(row1)$(PA R))$(PA PA R)
      row3 : (PA PA PA R) := new(iLength, copy(row2)$(PA PA R))$(PA PA PA R)

      for i in 1..iLength repeat
        for j in 1..jLength repeat
          for k in 1..kLength repeat

            element := elt(elt(elt(listRep, i)$(L L L R), j)$(L L R), k)$(L R)
            setelt!(row1, k - 1, element)$(PA R)
          setelt!(row2, j - 1, copy(row1)$(PA R))$(PA PA R)
        setelt!(row3, i - 1, copy(row2)$(PA PA R))$(PA PA PA R)

      resultMatrix := (row3 pretend %)

      resultMatrix

)abbrev domain SFORT SimpleFortranProgram

++ Author: Mike Dewar
++ Date Created: November 1992
++ Basic Operations:
++ Related Constructors: FortranType, FortranCode, Switch
++ Also See:
++ AMS Classifications:
++ Keywords:
++ References:
++ Description:
++ \spadtype{SimpleFortranProgram} provides a simple model of some
++ FORTRAN subprograms, making it possible to coerce objects of various
++ domains into a FORTRAN subprogram called \spad{f}.
++ These can then be translated into legal FORTRAN code.
SimpleFortranProgram(R, FS) : Exports == Implementation where
  R  : OrderedSet
  FS : FunctionSpace(R)

  FST ==> FortranScalarType

  Exports ==> FortranProgramCategory with
    fortran : (Symbol, FST, FS) -> %
    ++fortran(fname, ftype, body) builds an object of type
    ++\spadtype{FortranProgramCategory}. The three arguments specify
    ++the name, the type and the body of the program.

  Implementation ==> add

    Rep := Record(name : Symbol, type : FST, body : FS )

    import from FortranCodeTools

    fortran(fname, ftype, res) ==
      construct(fname, ftype, res)$Rep

    nameOf(u : %) : Symbol == u . name

    typeOf(u:%):Union(FST,"void") == u . type

    bodyOf(u : %) : FS == u . body

    argumentsOf(u : %) : List Symbol == variables(bodyOf u)$FS

    coerce(u : %) : OutputForm ==
      coerce(nameOf u)$Symbol

    outputAsFortran(u : %) : Void ==
      ftype := u.type
      ftype_s : String := checkType(ftype::String)
      fname := nameOf(u)
      args := argumentsOf(u)
      nargs := [arg::OutputForm for arg in args]$List(OutputForm)
      val  := bodyOf(u)::OutputForm
      fortFormatHead(fname, [ftype], args)
      fort_format_types(ftype_s, nargs)
      dispfortexp1$Lisp ["="::OutputForm, fname::OutputForm,
                         val]@List(OutputForm)
      dispfortexp1$Lisp "RETURN"::OutputForm
      dispfortexp1$Lisp "END"::OutputForm
      void()$Void

)abbrev domain SWITCH Switch

++ Author: Mike Dewar
++ Date Created: April 1991
++ Basic Operations:
++ Related Constructors: FortranProgram, FortranCode, FortranTypes
++ Also See:
++ AMS Classifications:
++ Keywords:
++ References:
++ Description:
++ This domain builds representations of boolean expressions for use with
++ the \spadtype{FortranCode} domain.
Switch() : public == private where
  EXPR ==> Union(I : Expression Integer, F : Expression Float,
                 CF : Expression Complex Float, switch : %)

  public ==  CoercibleTo OutputForm with
    coerce : Symbol -> %
        ++ coerce(s) \undocumented{}
    LT : (EXPR, EXPR) -> %
      ++ LT(x, y) returns the \spadtype{Switch} expression representing \spad{x<y}.
    GT : (EXPR, EXPR) -> %
      ++ GT(x, y) returns the \spadtype{Switch} expression representing \spad{x>y}.
    LE : (EXPR, EXPR) -> %
      ++ LE(x, y) returns the \spadtype{Switch} expression representing \spad{x<=y}.
    GE : (EXPR, EXPR) -> %
      ++ GE(x, y) returns the \spadtype{Switch} expression representing \spad{x>=y}.
    OR : (EXPR, EXPR) -> %
      ++ OR(x, y) returns the \spadtype{Switch} expression representing \spad{x or y}.
    EQ : (EXPR, EXPR) -> %
      ++ EQ(x, y) returns the \spadtype{Switch} expression representing \spad{x = y}.
    AND : (EXPR, EXPR) -> %
      ++ AND(x, y) returns the \spadtype{Switch} expression representing \spad{x and y}.
    NOT : EXPR -> %
      ++ NOT(x) returns the \spadtype{Switch} expression representing \spad{\~~x}.
    NOT : % -> %
      ++ NOT(x) returns the \spadtype{Switch} expression representing \spad{\~~x}.

  private == add
    Rep := Record(op : BasicOperator, rands : List EXPR)

    -- Public function definitions

    nullOp : BasicOperator := operator 'NULL

    coerce(s : %) : OutputForm ==
      rat := (s . op)::OutputForm
      ran := [u::OutputForm for u in s.rands]
      (s . op) = nullOp => first ran
      #ran = 1 =>
        prefix(rat, ran)
      infix(rat, ran)

    coerce(s : Symbol) : % == [nullOp, [[s::Expression(Integer)]$EXPR]$List(EXPR)]$Rep

    NOT(r : EXPR) : % ==
      [operator("~"::Symbol),[r]$List(EXPR)]$Rep

    NOT(r : %) : % ==
      [operator("~"::Symbol),[[r]$EXPR]$List(EXPR)]$Rep

    LT(r1 : EXPR, r2 : EXPR) : % ==
      [operator("<"::Symbol),[r1,r2]$List(EXPR)]$Rep

    GT(r1 : EXPR, r2 : EXPR) : % ==
      [operator(">"::Symbol),[r1,r2]$List(EXPR)]$Rep

    LE(r1 : EXPR, r2 : EXPR) : % ==
      [operator("<="::Symbol),[r1,r2]$List(EXPR)]$Rep

    GE(r1 : EXPR, r2 : EXPR) : % ==
      [operator(">="::Symbol),[r1,r2]$List(EXPR)]$Rep

    AND(r1 : EXPR, r2 : EXPR) : % ==
      [operator('and), [r1, r2]$List(EXPR)]$Rep

    OR(r1 : EXPR, r2 : EXPR) : % ==
      [operator('or), [r1, r2]$List(EXPR)]$Rep

    EQ(r1 : EXPR, r2 : EXPR) : % ==
      [operator('EQ), [r1, r2]$List(EXPR)]$Rep

)abbrev domain FTEM FortranTemplate
++ Author: Mike Dewar
++ Date Created:  October 1992
++ Basic Operations:
++ Related Domains:
++ Also See:
++ AMS Classifications:
++ Keywords:
++ Examples:
++ References:
++ Description: Code to manipulate Fortran templates
FortranTemplate() : specification == implementation where

  specification == FileCategory(FileName, String) with

    processTemplate : (FileName, FileName) -> FileName
      ++ processTemplate(tp, fn) processes the template tp, writing the
      ++ result out to fn.
    processTemplate : (FileName) -> FileName
      ++ processTemplate(tp) processes the template tp, writing the
      ++ result to the current FORTRAN output stream.
    fortranLiteralLine : String -> Void
      ++ fortranLiteralLine(s) writes s to the current Fortran output stream,
      ++ followed by a carriage return
    fortranLiteral : String -> Void
      ++ fortranLiteral(s) writes s to the current Fortran output stream
    fortranCarriageReturn : () -> Void
      ++ fortranCarriageReturn() produces a carriage return on the current
      ++ Fortran output stream

  implementation == TextFile add

    import from TemplateUtilities
    import from FortranOutputStackPackage

    Rep := TextFile

    fortranLiteralLine(s : String) : Void ==
      sayString(s, get_fortran_stream()$Lisp)$Lisp
      TERPRI(get_fortran_stream()$Lisp)$Lisp

    fortranLiteral(s : String) : Void ==
        sayString(s, get_fortran_stream()$Lisp)$Lisp

    fortranCarriageReturn() : Void ==
      TERPRI(get_fortran_stream()$Lisp)$Lisp

    writePassiveLine!(line : String) : Void ==
    -- We might want to be a bit clever here and look for new SubPrograms etc.
      fortranLiteralLine line

    processTemplate(tp : FileName, fn : FileName) : FileName ==
      pushFortranOutputStack(fn)
      processTemplate(tp)
      popFortranOutputStack()
      fn

    getLine(fp : TextFile) : String ==
      line : String := stripCommentsAndBlanks readLine!(fp)
      while not empty?(line) and elt(line,maxIndex line) = char "__" repeat
        setelt!(line, maxIndex line, char " ")
        line := concat(line, stripCommentsAndBlanks readLine!(fp))$String
      line

    processTemplate(tp : FileName) : FileName ==
      fp : TextFile := open(tp,"input")
      active : Boolean := true
      line : String
      endInput : Boolean := false
      while not (endInput or endOfFile? fp) repeat
        if active then
          line := getLine fp
          line = "endInput" => endInput := true
          if line = "beginVerbatim" then
            active := false
          else
            not empty? line => interpretString line
        else
          line := readLine!(fp)
          if line = "endVerbatim" then
            active := true
          else
            writePassiveLine! line
      close!(fp)
      if not active then
        error concat(["Missing `endVerbatim' line in ",tp::String])$String
      string(_$fortranOutputFile$Lisp)::FileName

)abbrev domain FEXPR FortranExpression
++ Author: Mike Dewar
++ Date Created:  December 1993
++ Basic Operations:
++ Related Domains:
++ Also See: FortranMachineTypeCategory, MachineInteger, MachineFloat,
++  MachineComplex
++ AMS Classifications:
++ Keywords:
++ Examples:
++ References:
++ Description: A domain of expressions involving functions which can be
++ translated into standard Fortran-77, with some extra extensions from
++ the NAG Fortran Library.
FortranExpression(basicSymbols, subscriptedSymbols, R):
                                Exports==Implementation where
  basicSymbols : List Symbol
  subscriptedSymbols : List Symbol
  R : FortranMachineTypeCategory

  EXPR ==> Expression
  EXF2 ==> ExpressionFunctions2
  S    ==> Symbol
  L    ==> List
  BO   ==> BasicOperator
  FRAC ==> Fraction
  POLY ==> Polynomial

  Exports ==> Join(ExpressionSpace, Algebra(R), RetractableTo(R),
                   PartialDifferentialRing(Symbol)) with
    retract : EXPR R -> %
      ++ retract(e) takes e and transforms it into a
      ++  FortranExpression checking that it contains no non-Fortran
      ++  functions, and that it only contains the given basic symbols
      ++  and subscripted symbols which correspond to scalar and array
      ++  parameters respectively.
    retractIfCan : EXPR R -> Union(%,"failed")
      ++ retractIfCan(e) takes e and tries to transform it into a
      ++  FortranExpression checking that it contains no non-Fortran
      ++  functions, and that it only contains the given basic symbols
      ++  and subscripted symbols which correspond to scalar and array
      ++  parameters respectively.
    retract : S -> %
      ++ retract(e) takes e and transforms it into a FortranExpression
      ++  checking that it is one of the given basic symbols
      ++  or subscripted symbols which correspond to scalar and array
      ++  parameters respectively.
    retractIfCan : S -> Union(%,"failed")
      ++ retractIfCan(e) takes e and tries to transform it into a FortranExpression
      ++  checking that it is one of the given basic symbols
      ++  or subscripted symbols which correspond to scalar and array
      ++  parameters respectively.
    coerce : % -> EXPR R
        ++ coerce(x) \undocumented{}
    if (R has RetractableTo(Integer)) then
      retract : EXPR Integer -> %
        ++ retract(e) takes e and transforms it into a
        ++  FortranExpression checking that it contains no non-Fortran
        ++  functions, and that it only contains the given basic symbols
        ++  and subscripted symbols which correspond to scalar and array
        ++  parameters respectively.
      retractIfCan : EXPR Integer -> Union(%,"failed")
        ++ retractIfCan(e) takes e and tries to transform it into a
        ++  FortranExpression checking that it contains no non-Fortran
        ++  functions, and that it only contains the given basic symbols
        ++  and subscripted symbols which correspond to scalar and array
        ++  parameters respectively.
      retract : FRAC POLY  Integer -> %
        ++ retract(e) takes e and transforms it into a
        ++  FortranExpression checking that it contains no non-Fortran
        ++  functions, and that it only contains the given basic symbols
        ++  and subscripted symbols which correspond to scalar and array
        ++  parameters respectively.
      retractIfCan : FRAC POLY  Integer -> Union(%,"failed")
        ++ retractIfCan(e) takes e and tries to transform it into a
        ++  FortranExpression checking that it contains no non-Fortran
        ++  functions, and that it only contains the given basic symbols
        ++  and subscripted symbols which correspond to scalar and array
        ++  parameters respectively.
      retract : POLY  Integer -> %
        ++ retract(e) takes e and transforms it into a
        ++  FortranExpression checking that it contains no non-Fortran
        ++  functions, and that it only contains the given basic symbols
        ++  and subscripted symbols which correspond to scalar and array
        ++  parameters respectively.
      retractIfCan : POLY  Integer -> Union(%,"failed")
        ++ retractIfCan(e) takes e and tries to transform it into a
        ++  FortranExpression checking that it contains no non-Fortran
        ++  functions, and that it only contains the given basic symbols
        ++  and subscripted symbols which correspond to scalar and array
        ++  parameters respectively.
    if (R has RetractableTo(Float)) then
      retract : EXPR Float -> %
        ++ retract(e) takes e and transforms it into a
        ++  FortranExpression checking that it contains no non-Fortran
        ++  functions, and that it only contains the given basic symbols
        ++  and subscripted symbols which correspond to scalar and array
        ++  parameters respectively.
      retractIfCan : EXPR Float -> Union(%,"failed")
        ++ retractIfCan(e) takes e and tries to transform it into a
        ++  FortranExpression checking that it contains no non-Fortran
        ++  functions, and that it only contains the given basic symbols
        ++  and subscripted symbols which correspond to scalar and array
        ++  parameters respectively.
      retract : FRAC POLY  Float -> %
        ++ retract(e) takes e and transforms it into a
        ++  FortranExpression checking that it contains no non-Fortran
        ++  functions, and that it only contains the given basic symbols
        ++  and subscripted symbols which correspond to scalar and array
        ++  parameters respectively.
      retractIfCan : FRAC POLY  Float -> Union(%,"failed")
        ++ retractIfCan(e) takes e and tries to transform it into a
        ++  FortranExpression checking that it contains no non-Fortran
        ++  functions, and that it only contains the given basic symbols
        ++  and subscripted symbols which correspond to scalar and array
        ++  parameters respectively.
      retract : POLY  Float -> %
        ++ retract(e) takes e and transforms it into a
        ++  FortranExpression checking that it contains no non-Fortran
        ++  functions, and that it only contains the given basic symbols
        ++  and subscripted symbols which correspond to scalar and array
        ++  parameters respectively.
      retractIfCan : POLY  Float -> Union(%,"failed")
        ++ retractIfCan(e) takes e and tries to transform it into a
        ++  FortranExpression checking that it contains no non-Fortran
        ++  functions, and that it only contains the given basic symbols
        ++  and subscripted symbols which correspond to scalar and array
        ++  parameters respectively.
    abs    : % -> %
      ++ abs(x) represents the Fortran intrinsic function ABS
    sqrt   : % -> %
      ++ sqrt(x) represents the Fortran intrinsic function SQRT
    exp    : % -> %
      ++ exp(x) represents the Fortran intrinsic function EXP
    log    : % -> %
      ++ log(x) represents the Fortran intrinsic function LOG
    log10  : % -> %
      ++ log10(x) represents the Fortran intrinsic function LOG10
    sin    : % -> %
      ++ sin(x) represents the Fortran intrinsic function SIN
    cos    : % -> %
      ++ cos(x) represents the Fortran intrinsic function COS
    tan    : % -> %
      ++ tan(x) represents the Fortran intrinsic function TAN
    asin   : % -> %
      ++ asin(x) represents the Fortran intrinsic function ASIN
    acos   : % -> %
      ++ acos(x) represents the Fortran intrinsic function ACOS
    atan   : % -> %
      ++ atan(x) represents the Fortran intrinsic function ATAN
    sinh   : % -> %
      ++ sinh(x) represents the Fortran intrinsic function SINH
    cosh   : % -> %
      ++ cosh(x) represents the Fortran intrinsic function COSH
    tanh   : % -> %
      ++ tanh(x) represents the Fortran intrinsic function TANH
    pi     : () -> %
      ++ pi(x) represents the NAG Library function X01AAF which returns
      ++  an approximation to the value of pi
    variables : % -> L S
      ++ variables(e) return a list of all the variables in \spad{e}.

  Implementation ==> EXPR R add

    -- The standard FORTRAN-77 intrinsic functions, plus nthRoot which
    -- can be translated into an arithmetic expression:
    f77Functions : L S := ['abs, 'sqrt, 'exp, 'log, 'log10, 'sin, 'cos,
                           'tan, 'asin, 'acos, 'atan, 'sinh, 'cosh, 'tanh,
                             'nthRoot, '%power]

    -- Local functions to check for "unassigned" symbols etc.

    mkEqn(s1 : Symbol, s2 : Symbol) : Equation EXPR(R) ==
      equation(s2::EXPR(R), script(s1, scripts(s2))::EXPR(R))

    fixUpSymbols(u:EXPR R):Union(EXPR R,"failed") ==
      -- If its a univariate expression then just fix it up:
      syms   : L S := variables(u)
      (#basicSymbols = 1) and zero?(#subscriptedSymbols) =>
        not (#syms = 1) => "failed"
        subst(u, equation(first(syms)::EXPR(R), first(basicSymbols)::EXPR(R)))
      -- We have one variable but it is subscripted:
      zero?(#basicSymbols) and (#subscriptedSymbols = 1) =>
        -- Make sure we don't have both X and X_i
        for s in syms repeat
          not scripted?(s) => return "failed"
        not ((#(syms := removeDuplicates! [name(s) for s in syms])) = 1)=> "failed"
        sym : Symbol := first subscriptedSymbols
        subst(u, [mkEqn(sym, i) for i in variables(u)])
      "failed"

    extraSymbols?(u : EXPR R) : Boolean ==
      syms   : L S := [name(v) for v in variables(u)]
      extras : L S := setDifference(syms,
                                    setUnion(basicSymbols, subscriptedSymbols))
      not empty? extras

    checkSymbols(u : EXPR R) : EXPR(R) ==
      syms   : L S := [name(v) for v in variables(u)]
      extras : L S := setDifference(syms,
                                    setUnion(basicSymbols, subscriptedSymbols))
      not empty? extras =>
        m := fixUpSymbols(u)
        m case EXPR(R) => m
        error ["Extra symbols detected:",
               [string(v) for v in extras]$L(String)]
      u

    notSymbol?(v : BO) : Boolean ==
      s : S := name v
      member?(s, basicSymbols) or
        scripted?(s) and member?(name s, subscriptedSymbols) => false
      true

    extraOperators?(u : EXPR R) : Boolean ==
      ops    : L S := [name v for v in operators(u) | notSymbol?(v)]
      fortranFunctions : L S := f77Functions
      extras : L S := setDifference(ops, fortranFunctions)
      not empty? extras

    checkOperators(u : EXPR R) : Void ==
      ops    : L S := [name v for v in operators(u) | notSymbol?(v)]
      fortranFunctions : L S := f77Functions
      extras : L S := setDifference(ops, fortranFunctions)
      not empty? extras =>
        error ["Non FORTRAN-77 functions detected:",
               [string(v) for v in extras]]
      void()

    -- Conditional retractions:

    if R has RetractableTo(Integer) then

      retractIfCan(u:POLY Integer):Union(%,"failed") ==
        retractIfCan(u::EXPR Integer)@Union(%,"failed")

      retract(u : POLY Integer) : % ==
        retract(u::EXPR Integer)@%

      retractIfCan(u:FRAC POLY Integer):Union(%,"failed") ==
        retractIfCan(u::EXPR Integer)@Union(%,"failed")

      retract(u : FRAC POLY  Integer) : % ==
        retract(u::EXPR Integer)@%

      int2R(u : Integer) : R == u::R

      retractIfCan(u:EXPR Integer):Union(%,"failed") ==
        retractIfCan(map(int2R,u)$EXF2(Integer,R))@Union(%,"failed")

      retract(u : EXPR Integer) : % ==
        retract(map(int2R, u)$EXF2(Integer, R))@%

    if R has RetractableTo(Float) then

      retractIfCan(u:POLY Float):Union(%,"failed") ==
        retractIfCan(u::EXPR Float)@Union(%,"failed")

      retract(u : POLY Float) : % ==
        retract(u::EXPR Float)@%

      retractIfCan(u:FRAC POLY Float):Union(%,"failed") ==
        retractIfCan(u::EXPR Float)@Union(%,"failed")

      retract(u : FRAC POLY  Float) : % ==
        retract(u::EXPR Float)@%

      float2R(u : Float) : R == (u::R)

      retractIfCan(u:EXPR Float):Union(%,"failed") ==
        retractIfCan(map(float2R,u)$EXF2(Float,R))@Union(%,"failed")

      retract(u : EXPR Float) : % ==
        retract(map(float2R, u)$EXF2(Float, R))@%

    -- Exported Functions

    log10(x : %) : % ==
      kernel(operator 'log10, x)

    pi() : % == kernel(operator 'X01AAF, 0)

    coerce(u : %) : EXPR R == u pretend EXPR(R)

    retractIfCan(u:EXPR R):Union(%,"failed") ==
      if (extraSymbols? u) then
        m := fixUpSymbols(u)
        m case "failed" => return "failed"
        u := m@EXPR(R)
      extraOperators? u => "failed"
      u pretend %

    retract(u : EXPR R) : % ==
      u := checkSymbols(u)
      checkOperators(u)
      u pretend %

    retractIfCan(u:Symbol):Union(%,"failed") ==
      not (member?(u, basicSymbols) or
           scripted?(u) and member?(name u,subscriptedSymbols)) => "failed"
      ((u::EXPR(R)) pretend Rep)::%

    retract(u : Symbol) : % ==
      res : Union(%,"failed") := retractIfCan(u)
      res case "failed" => error ["Illegal Symbol Detected:", u::String]
      res

--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.