(*
    Copyright (c) 2000
        Cambridge University Technical Services Limited

    Modified David C. J. Matthews 2010

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure GCode =
  GENERATE_CODE (
    structure CODECONS      = CodeCons
    structure CODEGEN_TABLE = CodeGenTable
    structure BASECODETREE  = BaseCodeTree
  );

Update X86-64 compiler build for latest changes.

(*
    Copyright (c) 2000
        Cambridge University Technical Services Limited

    Modified David C. J. Matthews 2010

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure GCode =
  GENERATE_CODE (
    structure CODECONS      = CodeCons
    structure CODEGEN_TABLE = CodeGenTable
    structure BASECODETREE  = BaseCodeTree
    structure DEBUG = Debug
  );


(* This crashed in the Power PC version. *)
Process.fork(fn () => ());

Change test because Process structure has been removed.

(* This crashed in the Power PC version. *)
(* Changed because Process has been removed. *)
Thread.Thread.fork(fn () => (), []);


"Global.x : "<input data=Global.x style={ width:100 } />

"Local.mouseX : " Local.mouseX

"Who's biggest?"

let coolStyle = { color:"red", marginTop:1 }

	if (Global.x > Local.mouseX) {
		 "Global!"
	} else {
		 "Local! "
	}

Use Global.foo instead of Global.x

"Global.foo : "<input data=Global.foo style={ width:100 } />

"Local.mouseX : " Local.mouseX

"Who's biggest?"

let coolStyle = { color:"red", marginTop:1 }

	if (Global.foo > Local.mouseX) {
		 "Global!"
	} else {
		 "Local! "
	}


(* Variant of p060.  This tests the error when the connection is refused. *)
val x = INetSock.TCP.socket(): Socket.passive INetSock.stream_sock
and y = INetSock.TCP.socket(): Socket.active INetSock.stream_sock;
val SOME me = NetHostDB.getByName "localhost";
val localhost = NetHostDB.addr me;
Socket.bind(x, INetSock.toAddr(localhost, 0));
(* Socket.listen(x, 5); *)
(
let
val (_, port) = INetSock.fromAddr(Socket.Ctl.getSockName x)
in
Socket.connect(y, INetSock.toAddr(localhost, port));

(* Shouldn't get here. *)
raise Fail "wrong"

end
) handle OS.SysErr(_, err) =>
    if err = OS.syserror "ECONNREFUSED" orelse err = OS.syserror "WSAECONNREFUSED" then () else raise Fail "bad error";

(* We could also get ECONNABORTED here perhaps. *)

Add ETIMEDOUT as a valid failure. Mac OS X seems to return this.

(* Variant of p060.  This tests the error when the connection is refused. *)
val x = INetSock.TCP.socket(): Socket.passive INetSock.stream_sock
and y = INetSock.TCP.socket(): Socket.active INetSock.stream_sock;
val SOME me = NetHostDB.getByName "localhost";
val localhost = NetHostDB.addr me;
Socket.bind(x, INetSock.toAddr(localhost, 0));
(* Socket.listen(x, 5); *)
(
let
val (_, port) = INetSock.fromAddr(Socket.Ctl.getSockName x)
in
Socket.connect(y, INetSock.toAddr(localhost, port));

(* Shouldn't get here. *)
raise Fail "wrong"

end
) handle OS.SysErr(_, err) =>
    if err = OS.syserror "ECONNREFUSED" orelse err = OS.syserror "WSAECONNREFUSED" orelse err = OS.syserror "ETIMEDOUT"
    then () else raise Fail "bad error";

(* We could also get ECONNABORTED here perhaps. *)


(*
	Copyright (c) 2000
		Cambridge University Technical Services Limited

	This library is free software; you can redistribute it and/or
	modify it under the terms of the GNU Lesser General Public
	License as published by the Free Software Foundation; either
	version 2.1 of the License, or (at your option) any later version.

	This library is distributed in the hope that it will be useful,
	but WITHOUT ANY WARRANTY; without even the implied warranty of
	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
	Lesser General Public License for more details.

	You should have received a copy of the GNU Lesser General Public
	License along with this library; if not, write to the Free Software
	Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CodeTree =
  CODETREE (
    structure GCODE         = GCode
    structure DEBUGSWITCH   = Debug
    structure PRETTYPRINTER = Boot.PrettyPrinter
    structure MISC          = Boot.Misc
    structure STRETCHARRAY  = StretchArray
    structure ADDRESS       = Address
    structure RUNCALL       = RunCall
  );

Add StructureEquality and BaseCodeTree structures as arguments and remove RunCall which is now global.

(*
	Copyright (c) 2000
		Cambridge University Technical Services Limited

	This library is free software; you can redistribute it and/or
	modify it under the terms of the GNU Lesser General Public
	License as published by the Free Software Foundation; either
	version 2.1 of the License, or (at your option) any later version.

	This library is distributed in the hope that it will be useful,
	but WITHOUT ANY WARRANTY; without even the implied warranty of
	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
	Lesser General Public License for more details.

	You should have received a copy of the GNU Lesser General Public
	License along with this library; if not, write to the Free Software
	Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CodeTree =
  CODETREE (
    structure GCODE         = GCode
    structure DEBUGSWITCH   = Debug
    structure PRETTYPRINTER = Boot.PrettyPrinter
    structure MISC          = Boot.Misc
    structure STRETCHARRAY  = StretchArray
    structure ADDRESS       = Address
    structure STRUCTUREEQ   = StructureEquality
    structure BASECODETREE  = BaseCodeTree
  );


(*
    Copyright (c) 2007-20 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.8.1 Release"
   val versionNumber = 581
   val versionSuffix = Int.toString versionNumber
end;

Update compiler version to 5.8.2 so that we pick up the correct files on bootstap.

(*
    Copyright (c) 2007-20 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.8.2 Testing"
   val versionNumber = 582
   val versionSuffix = Int.toString versionNumber
end;


(*
	Copyright (c) 2007-9 David C.J. Matthews

	This library is free software; you can redistribute it and/or
	modify it under the terms of the GNU Lesser General Public
	License as published by the Free Software Foundation; either
	version 2.1 of the License, or (at your option) any later version.

	This library is distributed in the hope that it will be useful,
	but WITHOUT ANY WARRANTY; without even the implied warranty of
	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
	Lesser General Public License for more details.

	You should have received a copy of the GNU Lesser General Public
	License along with this library; if not, write to the Free Software
	Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.3 Release candidate 2"
   val versionNumber = 530
   val versionSuffix = Int.toString versionNumber
end;

Update release string "5.3 Release".

(*
	Copyright (c) 2007-9 David C.J. Matthews

	This library is free software; you can redistribute it and/or
	modify it under the terms of the GNU Lesser General Public
	License as published by the Free Software Foundation; either
	version 2.1 of the License, or (at your option) any later version.

	This library is distributed in the hope that it will be useful,
	but WITHOUT ANY WARRANTY; without even the implied warranty of
	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
	Lesser General Public License for more details.

	You should have received a copy of the GNU Lesser General Public
	License along with this library; if not, write to the Free Software
	Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.3 Release"
   val versionNumber = 530
   val versionSuffix = Int.toString versionNumber
end;


(*
    Copyright (c) 2007-12 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.5.0 Testing"
   val versionNumber = 550
   val versionSuffix = Int.toString versionNumber
end;

Update compiler version for release.

(*
    Copyright (c) 2007-12 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.5.0 Release"
   val versionNumber = 550
   val versionSuffix = Int.toString versionNumber
end;


(* Bug with unused loop variable register being reused. *)

fun g r =
let
    val x = ref 0

    fun f () =
    let
        val () = x := !x+1
    in
        if !x = 0 then f() else ()
    end;
in
    f ()
end;

g();

Change test so it actually tests the bug.

(* Bug with unused loop variable register being reused. *)

fun g r =
let
    val x = ref 0

    fun f () =
    let
        val () = x := !x+1
    in
        if !x = 1 then f() else ()
    end;
in
    f ()
end;

g();


(* s(s(z)) *)
val term1 : Term.t =
    Term.$$(TermOps.Succ, [Term.$$(TermOps.Zero, [])])

(* lam{nat}(x.z) *)
val term2 : Term.t =
    Term.$$(TermOps.Lam (Type.$$(TypeOps.NAT, [])),
            [Term.\\ (Var.newvar "x",
                      Term.$$(TermOps.Zero, []))])

(* (lam{nat}(x.s(x))) s(s(z)) *)
val term3 : Term.t =
    Term.$$(TermOps.App, [term2, term1])

val term4 : Term.t =
    let
        val z : Term.t = Term.$$(TermOps.Zero, [])
        val body : Term.t = Term.\\ (Var.newvar "x",
                                     Term.\\ (Var.newvar "y",
                                              Term.$$(TermOps.Succ,
                                                      [Term.`` ("y", 2)])))
    in
        Term.$$(TermOps.Rec, [z, body, term1])
    end

val _ =
    let
        val nat = (Type.$$(TypeOps.NAT, []))
        fun printType (term : Term.t) : unit =
          let
              val termStr = Term.toString term
              val ty = TypeChecker.typecheck Context.empty term
              val tyStr = Type.toString ty
          in
              print (termStr ^ " : " ^ tyStr ^ "\n")
          end
    in
        List.map printType [term1, term2, term3, term4]
    end

Fix minor problem in examples

(* s(s(z)) *)
val term1 : Term.t =
    Term.$$(TermOps.Succ, [Term.$$(TermOps.Zero, [])])

(* lam{nat}(x.z) *)
val term2 : Term.t =
    Term.$$(TermOps.Lam (Type.$$(TypeOps.NAT, [])),
            [Term.\\ (Var.newvar "x",
                      Term.$$(TermOps.Zero, []))])

(* (lam{nat}(x.s(x))) s(s(z)) *)
val term3 : Term.t =
    Term.$$(TermOps.App, [term2, term1])

val term4 : Term.t =
    let
        val x1 = Var.newvar "x"
        val x2 = Var.newvar "y"
        val z : Term.t = Term.$$(TermOps.Zero, [])
        val body : Term.t = Term.\\ (x1,
                                     Term.\\ (x2,
                                              Term.$$(TermOps.Succ,
                                                      [Term.`` x2])))
    in
        Term.$$(TermOps.Rec, [z, body, term1])
    end

val _ =
    let
        val nat = (Type.$$(TypeOps.NAT, []))
        fun printType (term : Term.t) : unit =
          let
              val termStr = Term.toString term
              val ty = TypeChecker.typecheck Context.empty term
              val tyStr = Type.toString ty
          in
              print (termStr ^ " : " ^ tyStr ^ "\n")
          end
    in
        List.map printType [term1, term2, term3, term4]
    end


(*
	Copyright (c) 2000
		Cambridge University Technical Services Limited

	This library is free software; you can redistribute it and/or
	modify it under the terms of the GNU Lesser General Public
	License as published by the Free Software Foundation; either
	version 2.1 of the License, or (at your option) any later version.

	This library is distributed in the hope that it will be useful,
	but WITHOUT ANY WARRANTY; without even the implied warranty of
	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
	Lesser General Public License for more details.

	You should have received a copy of the GNU Lesser General Public
	License along with this library; if not, write to the Free Software
	Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

(* Script to rebuild the compiler. *)

PolyML.print_depth 0;

PolyML.make "mlsource/MLCompiler/Boot";
PolyML.make "mlsource/MLCompiler";

(* Compile the prelude and basis in the new compiler. *)
MLCompiler.use "mlsource/BuildBasis.sml";

(* This runs the new shell on top of the old one. *)
MLCompiler.shell();
PolyML.rootFunction();

Use MLCompiler.useString to run the new compiler.

(*
	Copyright (c) 2000
		Cambridge University Technical Services Limited

	This library is free software; you can redistribute it and/or
	modify it under the terms of the GNU Lesser General Public
	License as published by the Free Software Foundation; either
	version 2.1 of the License, or (at your option) any later version.

	This library is distributed in the hope that it will be useful,
	but WITHOUT ANY WARRANTY; without even the implied warranty of
	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
	Lesser General Public License for more details.

	You should have received a copy of the GNU Lesser General Public
	License along with this library; if not, write to the Free Software
	Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

(* Script to rebuild the compiler. *)
(* This is used only during testing.  The normal build process uses
   BuildExport to export a newly compiled compiler and exportPoly
   to compile the basis and produce an object file. *)

PolyML.print_depth 0;

PolyML.make "mlsource/MLCompiler/Boot";
PolyML.make "mlsource/MLCompiler";

(* Compile the prelude and basis in the new compiler. *)
MLCompiler.use "mlsource/BuildBasis.sml";

(* Use useString to start the new shell because it allows this
   to be pasted into a window as a single item.  Otherwise the
   line to start the new shell will be in the buffer of the old
   TextIO.stdIn not the one we've just built. *)
MLCompiler.useString "PolyML.rootFunction();";


(*
    Copyright (c) 2007-16 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.6 Release"
   val versionNumber = 560
   val versionSuffix = Int.toString versionNumber
end;

Update the compiler version for development. This is needed to allow the build process to distinguish old and new files.

(*
    Copyright (c) 2007-16 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.6.1 Testing"
   val versionNumber = 561
   val versionSuffix = Int.toString versionNumber
end;


(* Some bugs in Word32 on 64-bit and a bug in arithmetic right shift
   with a constant shift value. *)

fun check a b = if a = b then () else raise Fail "Bad";

check(Word32.toIntX 0wx0) 0;
check(Word32.toIntX 0wx1) 1;
check(Word32.toIntX 0wx7FFFFFFF) 2147483647;
check(Word32.toIntX 0wx80000000) ~2147483648;
check(Word32.toIntX 0wx80000001) ~2147483647;
check(Word32.toIntX 0wxFFFFFFFE) ~2;
check(Word32.toIntX 0wxFFFFFFFF) ~1;

check(Word32.toLargeX 0wx0) 0wx0;
check(Word32.toLargeX 0wx1) 0wx1;
check(Word32.toLargeX 0wx7FFFFFFF) 0wx7FFFFFFF;

check (let val r = ref 0w4 in Word.~>>(!r, 0w1) end) 0w2;

Include a regression test for the last commit.

(* Some bugs in Word32 on 64-bit and a bug in arithmetic right shift
   with a constant shift value. *)

fun check a b = if a = b then () else raise Fail "Bad";

check(Word32.toIntX 0wx0) 0;
check(Word32.toIntX 0wx1) 1;
check(Word32.toIntX 0wx7FFFFFFF) 2147483647;
check(Word32.toIntX 0wx80000000) ~2147483648;
check(Word32.toIntX 0wx80000001) ~2147483647;
check(Word32.toIntX 0wxFFFFFFFE) ~2;
check(Word32.toIntX 0wxFFFFFFFF) ~1;

check(Word32.toLargeX 0wx0) 0wx0;
check(Word32.toLargeX 0wx1) 0wx1;
check(Word32.toLargeX 0wx7FFFFFFF) 0wx7FFFFFFF;

check (let val r = ref 0w4 in Word.~>>(!r, 0w1) end) 0w2;

(* Checks that fromLargeInt returns the same result as fromInt *)

check(Word32.fromLargeInt ~1 = 0wxFFFFFFFF);
check(Word32.fromLargeInt (IntInf.pow (2, 32)) = 0wx0);


structure Ponyo_Int =
struct
    type t = int

    open Int

    (* http://burtleburtle.net/bob/hash/integer.html *)
    fun hash (i: int) : Word64.word =
        let
            val three = Word.fromInt (3)
            val four = Word.fromInt (4)
            val fifteen = Word.fromInt (15)
            val sixteen = Word.fromInt (16)
            val sixtyone = Word32.fromInt (61)
            val magic = Word32.fromInt (0x27d4eb2d)

            val iAsWord = Word32.fromInt (i)

            val a = Word32.xorb (Word32.xorb (iAsWord, sixtyone), Word32.~>> (iAsWord, sixteen))
            val a = Word32.+ (a, Word32.<< (a, three))
            val a = Word32.xorb (a, Word32.~>> (a, four))
            val a = Word32.* (a, magic)
            val a = Word32.xorb (a, Word32.~>> (a, fifteen))
        in
            Word32.toLargeWord (a)
        end

    val unitialized = 0
end

Revert back to simple int hash

structure Ponyo_Int =
struct
    type t = int

    open Int

    (* http://burtleburtle.net/bob/hash/integer.html *)
    fun hash2 (i: int) : Word64.word =
        let
            val three = Word.fromInt (3)
            val four = Word.fromInt (4)
            val fifteen = Word.fromInt (15)
            val sixteen = Word.fromInt (16)
            val sixtyone = Word32.fromInt (61)
            val magic = Word32.fromInt (0x27d4eb2d)

            val iAsWord = Word32.fromInt (i)

            val a = Word32.xorb (Word32.xorb (iAsWord, sixtyone), Word32.~>> (iAsWord, sixteen))
            val a = Word32.+ (a, Word32.<< (a, three))
            val a = Word32.xorb (a, Word32.~>> (a, four))
            val a = Word32.* (a, magic)
            val a = Word32.xorb (a, Word32.~>> (a, fifteen))
        in
            Word32.toLargeWord (a)
        end

    (* This is currently significantly faster in tests than the above hash2.
     * However, the distribution of keys in the hash table should be worse.
     * Worth more investigation.
     *)
    fun hash (i) = Word64.fromInt (i)
    val unitialized = 0
end


(*
    Copyright (c) 2007-17 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.7.1 Release"
   val versionNumber = 571
   val versionSuffix = Int.toString versionNumber
end;

Update the compiler version for testing.

(*
    Copyright (c) 2007-17 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.7.2 Testing"
   val versionNumber = 572
   val versionSuffix = Int.toString versionNumber
end;


structure Basis = struct
    structure String = String
    structure List = List
    structure Os = OS
    structure Posix = Posix
    structure Socket = Socket
end;

fun cleanPath (path: string, right: bool) : string =
    if right andalso Basis.String.isSuffix "/" path
        then cleanPath (Basis.String.substring (path, 0, String.size path - 1), true)
    else if not right andalso Basis.String.isPrefix "/" path
        then cleanPath (Basis.String.extract (path, 1, NONE), false)
    else path;

val PONYO_ROOT =
    case Basis.Os.Process.getEnv "PONYO_ROOT" of
        NONE => (print "PONYO_ROOT must be set. (Directory of source is a good default.)\n"; raise Fail "")
      | SOME root =>
    case Basis.String.isPrefix "~/" root of
        false => root
      | true =>
    case Basis.Os.Process.getEnv "HOME" of
        NONE => (print "Bad PONYO_ROOT: HOME undefined.\n"; raise Fail "")
      | SOME home =>
          cleanPath(home, true) ^ "/" ^ (cleanPath (Basis.String.extract (root, 2, NONE), false));

val ponyoLib = PONYO_ROOT ^ "/src";

PolyML.make (ponyoLib)

Add Int and Char structures to Basis

structure Basis = struct
    structure String = String
    structure List = List
    structure Os = OS
    structure Posix = Posix
    structure Socket = Socket
    structure Int = Int
    structure Char = Char
end;

fun cleanPath (path: string, right: bool) : string =
    if right andalso Basis.String.isSuffix "/" path
        then cleanPath (Basis.String.substring (path, 0, String.size path - 1), true)
    else if not right andalso Basis.String.isPrefix "/" path
        then cleanPath (Basis.String.extract (path, 1, NONE), false)
    else path;

val PONYO_ROOT =
    case Basis.Os.Process.getEnv "PONYO_ROOT" of
        NONE => (print "PONYO_ROOT must be set. (Directory of source is a good default.)\n"; raise Fail "")
      | SOME root =>
    case Basis.String.isPrefix "~/" root of
        false => root
      | true =>
    case Basis.Os.Process.getEnv "HOME" of
        NONE => (print "Bad PONYO_ROOT: HOME undefined.\n"; raise Fail "")
      | SOME home =>
          cleanPath(home, true) ^ "/" ^ (cleanPath (Basis.String.extract (root, 2, NONE), false));

val ponyoLib = PONYO_ROOT ^ "/src";

PolyML.make (ponyoLib)


[user]
	email = jakub.bortlik@gmail.com
	name = Jakub Bortlik
[color]
	ui = true
[core]
	editor = nvim
[diff "praat"]
	lextconv = base64
[alias]
	b = branch
	c = commit
	d = diff
	ca = commit -a
	cb = copy-branch-name
	co = checkout
	cm = checkout master
	d = diff
	l = log --graph --pretty=format:'%Cred%h%Creset %an: %s - %Creset %C(yellow)%d%Creset %Cgreen(%cr)%Creset' --abbrev-commit --date=relative
	ll = log --oneline --graph --all --decorate
	p = push origin HEAD
	pl = pull --prune
	s = status
	sb = status -sb
[credential]
	helper = store
	ctags = !.git/hooks/ctags
[init]
	templatedir = ~/.git_template
[push]
	default = simple

Change mail from gmail to protonmail

[user]
	email = jakub.bortlik@protonmail.com
	name = Jakub Bortlik
[color]
	ui = true
[core]
	editor = nvim
[diff "praat"]
	lextconv = base64
[alias]
	b = branch
	c = commit
	d = diff
	ca = commit -a
	cb = copy-branch-name
	co = checkout
	cm = checkout master
	d = diff
	l = log --graph --pretty=format:'%Cred%h%Creset %an: %s - %Creset %C(yellow)%d%Creset %Cgreen(%cr)%Creset' --abbrev-commit --date=relative
	ll = log --oneline --graph --all --decorate
	p = push origin HEAD
	pl = pull --prune
	s = status
	sb = status -sb
[credential]
	helper = store
	ctags = !.git/hooks/ctags
[init]
	templatedir = ~/.git_template
[push]
	default = simple


(*
    Copyright (c) 2007-13 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.5.1 Release"
   val versionNumber = 551
   val versionSuffix = Int.toString versionNumber
end;

Update version to 5.5.2 for all changes since the release of 5.5.1.

(*
    Copyright (c) 2007-13 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.5.2 Testing"
   val versionNumber = 552
   val versionSuffix = Int.toString versionNumber
end;


#ifndef ERTS_OSE_SIGNALS
#define ERTS_OSE_SIGNALS

#ifndef ERTS_OSE_SIGNAL_BASE
#define ERTS_OSE_SIGNAL_BASE 1000
#endif

#define ERTS_SIGNAL_INVALID        ERTS_OSE_SIGNAL_BASE
#define ERTS_SIGNAL_FD_DRV_CONFIG  ERTS_OSE_SIGNAL_BASE+1
#define ERTS_SIGNAL_FD_DRV_ASYNC   ERTS_OSE_SIGNAL_BASE+2
#define ERTS_SIGNAL_OSE_DRV_ATTACH ERTS_OSE_SIGNAL_BASE+3
#define ERTS_SIGNAL_OSE_DRV_HUNT   ERTS_OSE_SIGNAL_BASE+4

#endif

Change signal base to registered range

#ifndef ERTS_OSE_SIGNALS
#define ERTS_OSE_SIGNALS

#ifndef ERTS_OSE_SIGNAL_BASE
#define ERTS_OSE_SIGNAL_BASE 0x01900280
#endif

#define ERTS_SIGNAL_INVALID        ERTS_OSE_SIGNAL_BASE
#define ERTS_SIGNAL_FD_DRV_CONFIG  ERTS_OSE_SIGNAL_BASE+1
#define ERTS_SIGNAL_FD_DRV_ASYNC   ERTS_OSE_SIGNAL_BASE+2
#define ERTS_SIGNAL_OSE_DRV_ATTACH ERTS_OSE_SIGNAL_BASE+3
#define ERTS_SIGNAL_OSE_DRV_HUNT   ERTS_OSE_SIGNAL_BASE+4

#endif


(* Something that looks like it should be an integer or word constant
   but isn't should be lexically analysed as an integer constant
   followed by an identifier.  This is similar to the problem
   with real constants identified in Test026. *)

fun test 0 _ = () | test _ _ = raise Fail "wrong";

val () = let val xz = 1 in test 0xz end;
val () = let val wxz = 1 in test 0wxz end;
val () = let val xw9 = 1 in test 0xw9 end;
val () = let val x = 1 in test 0x; () end;

Add regression test for lexical fix for ~0w1.

(* Something that looks like it should be an integer or word constant
   but isn't should be lexically analysed as an integer constant
   followed by an identifier.  This is similar to the problem
   with real constants identified in Test026. *)

fun test 0 _ = () | test _ _ = raise Fail "wrong";

val () = let val xz = 1 in test 0xz end;
val () = let val wxz = 1 in test 0wxz end;
val () = let val xw9 = 1 in test 0xw9 end;
val () = let val x = 1 in test 0x; () end;

(* Another one identified. *)
val () = let val w1 = 1 in test ~0w1 end;
val () = let val xw1 = 1 in test ~0xw1 end;


(*
    Copyright (c) 2007-15 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.6 Testing"
   val versionNumber = 560
   val versionSuffix = Int.toString versionNumber
end;

Change version string from Testing to Release.

(*
    Copyright (c) 2007-16 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.6 Release"
   val versionNumber = 560
   val versionSuffix = Int.toString versionNumber
end;


"Global.input_data_test : "<input data=Global.input_data_test />
<br />
"Local.mouseX : "<input data=Local.mouseX />

Make the input example a bit more interesting

"Global.x : "<input data=Global.x style="width:30px;" />

"Local.mouseX : " Local.mouseX

"Who's biggest?"

	if (Global.x > Local.mouseX) {  "Global!"  }
	else {  "Local!"  }


(*
    Copyright (c) 2007-19 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.8 Release"
   val versionNumber = 580
   val versionSuffix = Int.toString versionNumber
end;

Update compiler version to 5.8.1.

(*
    Copyright (c) 2007-19 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.8.1 Testing"
   val versionNumber = 581
   val versionSuffix = Int.toString versionNumber
end;


import Local

let Mouse = {
	x: Local.__mouseX__,
	y: Local.__mouseY__,
	isDown: Local.__mouseIsDown__
}

Make a habit out of defining module-specific local attributes as Local.__<Module name>_<property name>__

import Local

let Mouse = {
	x: Local.__Mouse_x__,
	y: Local.__Mouse_y__,
	isDown: Local.__Mouse_isDown__
}


(* There was an issue in 32-in-64 where loading the Word8 value using a 32-bit value
   was then cached as though the whole 64-bits had been loaded. *)

if LargeWord.wordSize < 0w64 then raise NotApplicable else ();

fun largeWordToBytes(_, 0) = []
    |   largeWordToBytes(ival: LargeWord.word, n) =
            Word8.fromLargeWord ival :: largeWordToBytes(LargeWord.>>(ival, 0w8), n-1);

if largeWordToBytes(0wxffffffffffffffff, 8) = [0wxFF, 0wxFF, 0wxFF, 0wxFF, 0wxFF, 0wxFF, 0wxFF, 0wxFF]
then ()
else raise Fail "wrong";

Fix the test in the last commit.

(* There was an issue in 32-in-64 where loading the Word8 value using a 32-bit value
   was then cached as though the whole 64-bits had been loaded. *)

if LargeWord.wordSize < 64 then raise NotApplicable else ();

fun largeWordToBytes(_, 0) = []
    |   largeWordToBytes(ival: LargeWord.word, n) =
            Word8.fromLargeWord ival :: largeWordToBytes(LargeWord.>>(ival, 0w8), n-1);

if largeWordToBytes(0wxffffffffffffffff, 8) = [0wxFF, 0wxFF, 0wxFF, 0wxFF, 0wxFF, 0wxFF, 0wxFF, 0wxFF]
then ()
else raise Fail "wrong";


(*  Title:      Pure/NJ
    ID:         $Id$
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

Basis Library emulation

Needed for Poly/ML and Standard ML of New Jersey version 0.93

Full compatibility cannot be obtained using a file: what about char constants?
*)

structure Int =
  struct
  fun max (x, y) = if x < y then y else x : int;
  fun min (x, y) = if x < y then x else y : int;
  end;

structure TextIO =
  struct
  type instream = instream
  and  outstream = outstream
  exception Io of {name: string, function: string, cause: exn}
  val stdIn 	= std_in
  val stdOut 	= std_out
  val openIn 	= open_in
  val openAppend = open_append
  val openOut 	= open_out
  val closeIn 	= close_in
  val closeOut 	= close_out
  val inputN 	= input
  val inputAll  = fn is => inputN (is, 999999)
  val inputLine = input_line
  val endOfStream = end_of_stream
  val output 	= output
  val flushOut 	= flush_out
  end;

Structure Bool and value Int.toString needed to replace makestring calls

(*  Title:      Pure/NJ
    ID:         $Id$
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

Basis Library emulation

Needed for Poly/ML and Standard ML of New Jersey version 0.93

Full compatibility cannot be obtained using a file: what about char constants?
*)

structure Bool =
  struct
  fun toString true  = "true"
    | toString false = "false"
  end;

structure Int =
  struct
  fun toString (i: int) = makestring i;
  fun max (x, y) = if x < y then y else x : int;
  fun min (x, y) = if x < y then x else y : int;
  end;

structure TextIO =
  struct
  type instream = instream
  and  outstream = outstream
  exception Io of {name: string, function: string, cause: exn}
  val stdIn 	= std_in
  val stdOut 	= std_out
  val openIn 	= open_in
  val openAppend = open_append
  val openOut 	= open_out
  val closeIn 	= close_in
  val closeOut 	= close_out
  val inputN 	= input
  val inputAll  = fn is => inputN (is, 999999)
  val inputLine = input_line
  val endOfStream = end_of_stream
  val output 	= output
  val flushOut 	= flush_out
  end;


(*
    Copyright (c) 2007-21 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.9,1 Testing"
   val versionNumber = 591
   val versionSuffix = Int.toString versionNumber
end;

Fix typo in version string.

(*
    Copyright (c) 2007-21 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.9.1 Testing"
   val versionNumber = 591
   val versionSuffix = Int.toString versionNumber
end;


(*
    Copyright (c) 2007-20 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.8.1 Release"
   val versionNumber = 581
   val versionSuffix = Int.toString versionNumber
end;

Update compiler version to 5.8.2 so that we pick up the correct files on bootstap.

(*
    Copyright (c) 2007-20 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

structure CompilerVersion =
struct
   val compilerVersion = "5.8.2 Testing"
   val versionNumber = 582
   val versionSuffix = Int.toString versionNumber
end;


(* This could segfault if GMP was enabled due to a bug in neg_longc. *)

val x = ~ (LargeInt.fromInt(valOf FixedInt.maxInt)) - 1;
PolyML.IntInf.gcd(x, 0);

Modify test so that it works if int is IntInf.int.

(* This could segfault if GMP was enabled due to a bug in neg_longc. *)

val x = ~ (LargeInt.fromInt(FixedInt.toInt(valOf FixedInt.maxInt))) - 1;
PolyML.IntInf.gcd(x, 0);


structure JonprlLanguageDef :> LANGUAGE_DEF =
struct
  open ParserCombinators CharParser
  infixr 1 ||

  type scanner = char charParser
  val commentStart = SOME "(*"
  val commentEnd = SOME "*)"
  val commentLine = SOME "|||"
  val nestedComments = false

  val identLetter = letter || oneOf (String.explode "-'_ΑαΒβΓγΔδΕεΖζΗηΘθΙιΚκΛλΜμΝνΞξΟοΠπΡρΣσΤτΥυΦφΧχΨψΩω") || digit
  val identStart = identLetter
  val opStart = fail "Operators not supported" : scanner
  val opLetter = opStart
  val reservedNames = []
  val reservedOpNames = []
  val caseSensitive = true
end

structure JonprlTokenParser :> TOKEN_PARSER = TokenParser (JonprlLanguageDef)

Add some more allowed characters

structure JonprlLanguageDef :> LANGUAGE_DEF =
struct
  open ParserCombinators CharParser
  infixr 1 ||

  type scanner = char charParser
  val commentStart = SOME "(*"
  val commentEnd = SOME "*)"
  val commentLine = SOME "|||"
  val nestedComments = false

  val fancyChars =
      "-'_ΑαΒβΓγΔδΕεΖζΗηΘθΙιΚκΛλΜμΝνΞξΟοΠπΡρΣσΤτΥυΦφΧχΨψΩω¬⊗⊕∫+-!@#$%^&*⇓↓↼⇀↽⇁↿↾⇃⇂"

  val identLetter = letter || oneOf (String.explode fancyChars) || digit
  val identStart = identLetter
  val opStart = fail "Operators not supported" : scanner
  val opLetter = opStart
  val reservedNames = []
  val reservedOpNames = []
  val caseSensitive = true
end

structure JonprlTokenParser :> TOKEN_PARSER = TokenParser (JonprlLanguageDef)


Add Unix socket test. This was added in another branch.

(* Unix socket test - Test078 converted to Unix socket *)
case #lookupStruct (PolyML.globalNameSpace) "UnixSock" of
    SOME _ => ()
|   NONE => raise NotApplicable;

val x = UnixSock.Strm.socket(): Socket.passive UnixSock.stream_sock
and y = UnixSock.Strm.socket(): Socket.active UnixSock.stream_sock;

val name = OS.FileSys.tmpName();
OS.FileSys.remove name handle OS.SysErr _ => ();

Socket.bind(x, UnixSock.toAddr name);
Socket.listen(x, 5);

Socket.connect(y, UnixSock.toAddr name);

val (cnct, _) = Socket.accept x;

(* Send the data. Use a separate thread so there's no possibility of blocking. *)
let
    fun sendData() =
        (Socket.sendVec(y, Word8VectorSlice.full(Byte.stringToBytes "A test")); ())
in
    Thread.Thread.fork(sendData, [])
end;

if Byte.bytesToString(Socket.recvVec(cnct, 6)) <> "A test"
then raise Fail "failed"
else ();

Socket.close cnct;
Socket.close x;
Socket.close y;
OS.FileSys.remove name handle OS.SysErr _ => ();


(* BV language definition *)

datatype id = Ident of string

datatype unop = Not | Shl1 | Shr1 | Shr4 | Shr16

datatype binop = And | Or | Xor | Plus

datatype expr = Zero
              | One
              | Id of id
              (* if e0 == 0 then e1 else e2 *)
              | Ifz of expr * expr * expr
              (* fold e_vec e_init (\x_element x_accum -> e_step) *)
              | Fold of expr * expr * id * id * expr
              | Unop of unop * expr
              | Binop of binop * expr

datatype program = Lambda of id * expr

fun show_id (Ident s) = s

fun show_unop Not   = "not"
  | show_unop Shl1  = "shl1"
  | show_unop Shr1  = "shr1"
  | show_unop Shr4  = "shr4"
  | show_unop Shr16 = "shr16"

fun show_binop And  = "and"
  | show_binop Or   = "or"
  | show_binop Xor  = "xor"
  | show_binop Plus = "plus"

fun show_expr Zero = "0"
  | show_expr One = "1"
  | show_expr (Id x) = show_id x
  | show_expr (Ifz (e0,e1,e2)) =
        "(if0 " ^ show_expr e0 ^ " " ^ show_expr e1 ^ " " ^ show_expr e2 ^ ")"
  | show_expr (Fold (ev,e0,x,y,e)) =
        "(fold " ^ show_expr ev ^ " " ^ show_expr e0
        ^ " (lambda (" ^ show_id x ^ " " ^ show_id y ^ ") " ^ show_expr e ^ ")"
  | show_expr (Unop  (oper,e)) = "(" ^ show_unop  oper ^ " " ^ show_expr e ^ ")"
  | show_expr (Binop (oper,e)) = "(" ^ show_binop oper ^ " " ^ show_expr e ^ ")"

fun show_program (Lambda (x,e)) = "(lambda (" ^ show_id x ^ ") " ^ show_expr e ^ ")"


Fix bug in NetHostDB.scan. Single zeros weren't scanned properly. Included regression test.

(* Checks for bug in NetHostDB. *)
fun checkIt s =
    if NetHostDB.toString (valOf(NetHostDB.fromString s)) = s
    then ()
    else raise Fail "checkIt";

checkIt "127.0.0.1";
checkIt "10.0.0.34";
checkIt "10.1.1.34";


Test for creating type ID in signature from type abbreviation.

(* Test to construct polytype from type abbreviation by opaque matching. *)

structure S:> sig eqtype 'a t val mkT: 'a -> 'a t end =
struct type 'a t = 'a fun mkT x = x end;

PolyML.makestring(S.mkT 1); (* Check the pretty-printer. *)

if S.mkT 1 = S.mkT 1 then () else raise Fail "error";

if S.mkT 1 = S.mkT 2 then raise Fail "error" else ();

(* And from datatype.  *)
structure S:> sig eqtype 'a t val mkT: 'a -> 'a t end =
struct datatype 'a t = X of 'a val mkT = X end;

PolyML.makestring(S.mkT 1);

if S.mkT 1 = S.mkT 1 then () else raise Fail "error";

if S.mkT 1 = S.mkT 2 then raise Fail "error" else ();


(*  Title:      Pure/ProofGeneral/pgip.ML
    ID:         $Id$
    Author:     David Aspinall

   This file allows a standalone build of the PGIP abstraction module.

   This should be useful for building other tools, or as an aid to porting.

   A lot of Isabelle library code is pulled in, but only a few
   functions are actually used, and the libraries indicated "used
   directly" below could be replaced with other implementations.

   NB: This is *not* part of the Isabelle build.  As such, it's
   liable to breakage as library functions are changed or moved around.
*)

val cd = OS.FileSys.chDir;
cd "..";

(* First you have to setup for your ML compiler.
   This even requires extracting a function from the bash scripts!
   See lib/scripts/run-XXX.  This is for polyML 4.2.0.
*)
fun exit 0 = (OS.Process.exit OS.Process.success): unit
  | exit _ = OS.Process.exit OS.Process.failure;
use "ML-Systems/polyml-4.2.0.ML";

(* Now the required parts of Isabelle libraries *)

use "General/basics.ML";
use "library.ML";
use "General/position.ML";
use "General/path.ML";     (* used directly *)
use "General/table.ML";
use "General/alist.ML";
use "General/output.ML";
use "General/scan.ML";
use "General/source.ML";
use "General/file.ML";     (* used directly *)
use "General/buffer.ML";
use "General/symbol.ML";
use "General/xml.ML";      (* used directly *)
use "General/url.ML";      (* used directly *)

cd "ProofGeneral/";

use "syntax_standalone.ML";

(* Finally, our code *)

use "pgip_types.ML";
use "pgip_markup.ML";
use "pgip_input.ML";
use "pgip_output.ML";
use "pgip.ML";


(*  Title:      Pure/ML-Systems/polyml-4.1.4-patch.ML
    ID:         $Id$
    Author:     Makarius

Patch for PolyML 4.1.4 to make it work with Isabelle2005.  We commit
this into ML_dbase!
*)

structure Posix =
struct
  open Posix;
  structure IO =
  struct
    open IO;
    val mkReader = mkTextReader;
    val mkWriter = mkTextWriter;
  end;
end;

structure TextIO =
struct
  open TextIO;
  fun inputLine is = Option.getOpt (TextIO.inputLine is, "");
end;


Add the test for Real.fromInt that used to raise an exception.

(* These raised Size exceptions *)
fun test1 (r:real) =   Real.toLargeInt IEEEReal.TO_NEAREST r;
fun test2 (r:real) =   Real.toLargeInt IEEEReal.TO_ZERO r;
test1 2.23E34;
test1 2.23E35;
test2 2.23E34;
test2 2.23E35;


Add a test to check that OS.Path.joinDirFile correctly checks file-name

(* OS.Path.joinDirFile should raise InvalidArc if the file name does not correspond to an arc *)
(OS.Path.joinDirFile {dir="abc/def", file="ghi/jkl"}; raise Fail "incorrect") handle OS.Path.InvalidArc => ();


Add regression test for negative sized arrays or those larger than the maximum.

(* Creating a negative sized array should raise Size. *)

(let
   val v = Array.array(~12, 4)
in
    raise Fail "failed"
end) handle Size => ();

(let
   val v = Array.array(Array.maxLen+1, 4)
in
    raise Fail "failed"
end) handle Size => ();

(let
   val v = Array.tabulate(~12, fn i => i)
in
    raise Fail "failed"
end) handle Size => ();

(let
   val v = Array.tabulate(Array.maxLen+1, fn i => i)
in
    raise Fail "failed"
end) handle Size => ();


(* for testing: canonicalize an XML file using xmlwf tool from expat *)
structure XMLWF = struct
  local
    fun readAll fileName =
          let
            val ins = TextIO.openIn fileName
          in
            TextIO.inputAll ins
            before TextIO.closeIn ins
            handle e => (TextIO.closeIn ins; raise e)
          end
  in
    fun canonicalizeFile tmpDir fileName =
          let
            val basename = OS.Path.file fileName
            val tmpFile = OS.Path.joinDirFile {dir=tmpDir, file=basename}
            val cmd = "xmlwf -d " ^ tmpDir ^ " " ^ fileName
          in
            case OS.Process.isSuccess (OS.Process.system cmd) of
                 false => raise Fail "xmlwf failed"
               | true => readAll tmpFile
            before OS.FileSys.remove tmpFile
            handle e => (OS.FileSys.remove tmpFile handle _ => (); raise e)
          end
  end
end


Add a regression test for the special cases.

(* A few of these are specially handled in the code-generator. *)

fun check true = () | check false = raise Fail "Incorrect";

PolyML.Compiler.maxInlineSize := 1;
fun f x = if x then 1 else 0;
check(f true = 1);
check(f false = 0);

fun f x = if x then 2 else 0;
check(f true = 2);
check(f false = 0);

fun f x = if x then 3 else 0;
check(f true = 3);
check(f false = 0);

fun f x = if x then 4 else 0;
check(f true = 4);
check(f false = 0);

fun f x = if x then 5 else 0;
check(f true = 5);
check(f false = 0);

fun f x = if x then 6 else 0;
check(f true = 6);
check(f false = 0);

fun f x = if x then 7 else 0;
check(f true = 7);
check(f false = 0);

fun f x = if x then 8 else 0;
check(f true = 8);
check(f false = 0);


(* Some tests on C memory operations. *)

fun check f a b =
    if f a = b then () else raise Fail "Mismatch";
(* 64-bit operations are not implemented in 32-bit mode. *)
fun checkEx f a b =
    (if f a = b then () else raise Fail "Mismatch") handle Foreign.Foreign _ => ();

open Foreign.Memory;
val m = malloc 0w32;
val r = ref 0w0;
set32(m, 0w0, 0wx12343421);
set32(m, 0w1, 0w0);
set32(m, 0w2, 0w0);
set32(m, 0w3, 0w0);
set32(m, 0w4, 0w0);
set32(m, 0w5, 0w0);
set32(m, 0w6, 0wxabccccab);
set32(m, 0w7, 0wx12211221);

(* These are often handled differently depending on whether the offset is
   a compile-time constant. *)
check get32 (m, 0w0) 0wx12343421;
check get32 (m, !r) 0wx12343421;

check get16 (m, 0w14) 0wx1221;
r := 0w14;
check get16 (m, !r) 0wx1221;

checkEx get64 (m, 0w1) 0w0;
r := 0w1;
checkEx get64 (m, !r) 0w0;

check get8 (m, 0w24) 0wxab;
r := 0w24;
check get8 (m, !r) 0wxab;

set8(m, !r, 0wx88);
check get8 (m, 0w24) 0wx88;

set64(m, 0w1, 0wx123456) handle Foreign.Foreign _ => ();
checkEx get64 (m, 0w1) 0wx123456;

set16(m, 0w4, 0wxffee);
check get16 (m, 0w4) 0wxffee;

setFloat(m, 0w2, 1.0);
if Real.==(getFloat(m, 0w2), 1.0) then () else raise Fail "Mismatch";
r := 0w2;
if Real.==(getFloat(m, !r), 1.0) then () else raise Fail "Mismatch";

setDouble(m, 0w2, 2.0);
if Real.==(getDouble(m, 0w2), 2.0) then () else raise Fail "Mismatch";
if Real.==(getDouble(m, !r), 2.0) then () else raise Fail "Mismatch";

free m;


Add regression test for X87 caching bug.

(* Regression test for bug with caching X87 values. *)
fun f x = let val res = x+ 1.0  in if Real.isFinite res then res else raise Fail "bad" end;

f 3.0;


Add the loca_and_global.fun example code

"Let's mix Local.mouseX and Global.x!"
"Local.mouseX:" Local.mouseX
"Global.x:" Global.x

if (Local.mouseX >= Global.x) {
	"Local.mouseX >= Global.x"
} else {
	"Local.mouseX < Global.x"
}


(*  Title:      Provers/project_rule.ML
    ID:         $Id$
    Author:     Makarius

Transform mutual rule:
  HH ==> (x1:A1 --> P1 x1) & ... & (xn:An --> Pn xn)
into projection:
  xi:Ai ==> HH ==> Pi xi
*)

signature PROJECT_RULE_DATA =
sig
  val conjunct1: thm
  val conjunct2: thm
  val mp: thm
end;

signature PROJECT_RULE =
sig
  val project: thm -> int -> thm
  val projections: thm -> thm list
end;

functor ProjectRuleFun(Data: PROJECT_RULE_DATA): PROJECT_RULE =
struct

fun conj1 th = th RS Data.conjunct1;
fun conj2 th = th RS Data.conjunct2;
fun imp th = th RS Data.mp;

val freeze = Drule.zero_var_indexes #> Drule.freeze_all;

fun project rule i =
  let
    fun proj 1 th = the_default th (try conj1 th)
      | proj k th = proj (k - 1) (conj2 th);
    fun prems k th =
      (case try imp th of
        NONE => (k, th)
      | SOME th' => prems (k + 1) th');
  in
    rule
    |> freeze
    |> proj i
    |> prems 0 |-> (fn k =>
      Thm.permute_prems 0 (~ k)
      #> Drule.standard'
      #> RuleCases.save rule
      #> RuleCases.add_consumes k)
  end;

fun projections rule =
  let
    fun projs k th =
      (case try conj2 th of
        NONE => k
      | SOME th' => projs (k + 1) th');
    val n = projs 1 (freeze rule);
  in map (project rule) (1 upto n) end;

end;


Add GPG signature to gem signing public key.


Add some code - a way of learning which semantically versioned git packages are made available by a repository

(* Manipulating packages with git *)

structure GetGit = struct

(*[ val poll: string -> (string * (int * int * int * string)) list ]*)
(* List of X.Y.Z versions provided by a repository *)
fun poll (gitAddr: string) =
   let
      fun eq c1 c2 = c1 = c2

      val tmpName = OS.FileSys.tmpName ()
      val _ = OS.Process.system ("git ls-remote " ^ gitAddr ^ " > " ^ tmpName)
      val tmp = TextIO.openIn tmpName
      val input =
         String.tokens (eq #"\n")
            (TextIO.inputAll tmp before TextIO.closeIn tmp)
         handle exn => (TextIO.closeIn tmp handle _ => (); raise exn)

      exception NotSemVar
      fun process str =
         let val (hash, remote) =
                case String.tokens Char.isSpace str of
                   [ hash, remote ] =>
                       if size hash <> 40
                       then raise Fail "Bad hash returned from git ls-remote"
                       else (hash, String.tokens (eq #"/") remote)
                 | _ => raise Fail "Unexpected output from `git ls-remote`"

            val tag =
               case remote of
                  [ "refs", "tags", tag ] =>
                  if String.sub (tag, 0) = #"v"
                  then String.extract (tag, 1, NONE)
                  else raise NotSemVar (* Not a version tag *)
                | _ => raise NotSemVar (* Not a tag at all *)

            fun numAndMore str =
               case Int.fromString str of
                  NONE => NONE
                | SOME i =>
                  SOME (i, String.extract (str, size (Int.toString i), NONE))

            val (major, minor, patch, ps) =
               case map numAndMore (String.tokens (eq #".") tag) of
                  [ SOME (major, ""), SOME (minor, ""), SOME (patch, ps) ] =>
                  (major, minor, patch, ps)
                | _ => raise NotSemVar

            (* XXX check that ps is [A-Za-z][0-9A-Za-z-]* *)
         in
            SOME (hash, (major, minor, patch, ps))
         end handle NotSemVar => NONE
   in
      List.mapPartial process input
   end handle _ => raise Fail "I/O error trying to access temporary file"

end


PMunkR?6>S``ċj2Yb
*%Zʱ%v(u5GU )1_\O((,>,	;0I:tE_HU@%if{MS]fvA=L>J|J*H`8Fu,;LYWJA韓YZx}?^/(VIP.l!SD5b
hƤbo`/S⟗|!SX
kx/oRp5xvr¡f1WP-ؑ1A]ea~z[>CU(rD;Cr"E߁k96zk2&to)S0()㐌$o,ˏO{+y!?jj|TK"
HMQ0ʛmQďV鯹\g*f	z>cTϤmRǫb@


Add some near-future examples of fun code

	<input data=Local.compose />
	<button onClick=sendMessage>Send</button>

let sendMessage = handler() {
	Global.messages.push({ user: Session.User, text: Local.compose })
}

	for (message in Global.messages) {

			message.user.name " says:"
			 message.text

	}


subroutine sayhello(comm)
  use mpi
  implicit none
  integer :: comm
  integer :: rank, size, nlen, ierr
  character (len=MPI_MAX_PROCESSOR_NAME) :: pname
  if (comm == MPI_COMM_NULL) then
     print *, 'You passed MPI_COMM_NULL !!!'
     return
  end if
  call MPI_Comm_rank(comm, rank, ierr)
  call MPI_Comm_size(comm, size, ierr)
  call MPI_Get_processor_name(pname, nlen, ierr)
  print *, 'Hello, World!', &
       ' I am process ', rank, &
       ' of ', size, &
       ' on ', pname(1:nlen), '.'
end subroutine sayhello

! program main
!   use mpi
!   implicit none
!   integer ierr
!   call MPI_Init(ierr)
!   call sayhello(MPI_COMM_WORLD)
!   call MPI_Finalize(ierr)
! end program main

Add comment in f90 source about how to build with F2Py

!
! $ f2py --f90exec=mpif90 -m helloworld -c helloworld.f90
!

subroutine sayhello(comm)
  use mpi
  implicit none
  integer :: comm
  integer :: rank, size, nlen, ierr
  character (len=MPI_MAX_PROCESSOR_NAME) :: pname
  if (comm == MPI_COMM_NULL) then
     print *, 'You passed MPI_COMM_NULL !!!'
     return
  end if
  call MPI_Comm_rank(comm, rank, ierr)
  call MPI_Comm_size(comm, size, ierr)
  call MPI_Get_processor_name(pname, nlen, ierr)
  print *, 'Hello, World!', &
       ' I am process ', rank, &
       ' of ', size, &
       ' on ', pname(1:nlen), '.'
end subroutine sayhello

! program main
!   use mpi
!   implicit none
!   integer ierr
!   call MPI_Init(ierr)
!   call sayhello(MPI_COMM_WORLD)
!   call MPI_Finalize(ierr)
! end program main


****************************************************************************************
**  UMAT, FOR ABAQUS/STANDARD INCORPORATING ISOTROPIC ELASTICITY                      **
****************************************************************************************
****************************************************************************************
**
**
**
      SUBROUTINE UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,
     1     RPL,DDSDDT,DRPLDE,DRPLDT,
     2     STRAN,DSTRAN,TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,CMNAME,
     3     NDI,NSHR,NTENS,NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT,
     4     CELENT,DFGRD0,DFGRD1,NOEL,NPT,LAYER,KSPT,KSTEP,KINC)

C
C      INCLUDE 'ABA_PARAM.INC'
C
C      CHARACTER*8 CMNAME
C
      DIMENSION STRESS(NTENS),STATEV(NSTATV),DDSDDE(NTENS, NTENS),
     1     DDSDDT(6),DRPLDE(6),STRAN(6),DSTRAN(NTENS),
     2     PREDEF(1),DPRED(1),PROPS(NPROPS),COORDS(3),DROT(3,3),
     3     DFGRD0(3,3), DFGRD1(3,3), TIME(2)

      PARAMETER(ZERO=0.D0, ONE=1.D0, TWO=2.D0, THREE=3.D0)

C ----------------------------------------------------------------
C
C     UMAT FOR ISOTROPIC ELASTICITY
C
C     CANNOT BE USED FOR PLANE STRESS
C ----------------------------------------------------------------
C
C      PROPS(1) - E
C
C      PROPS(2) - NU
C ----------------------------------------------------------------
C
C      IF (NDI.NE.3) THEN
C         WRITE (7, *) ’THIS UMAT MAY ONLY BE USED FOR ELEMENTS
C    1        WITH THREE DIRECT STRESS COMPONENTS’
C         CALL XIT
C      ENDIF
C
C     ELASTIC PROPERTIES
      EMOD=PROPS(1)
      ENU=PROPS(2)
      EBULK3=EMOD/(ONE-TWO*ENU)
      EG2=EMOD/(ONE+ENU)
      EG=EG2/TWO
      EG3=THREE*EG
      ELAM=(EBULK3-EG2)/THREE
C
C     ELASTIC STIFFNESS
C
      DO K1=1, NDI
         DO K2=1, NDI
            DDSDDE(K2, K1)=ELAM
         END DO
         DDSDDE(K1, K1)=EG2+ELAM
      END DO
      DO K1=NDI+1, NTENS
         DDSDDE(K1 ,K1)=EG
      END DO
C
C     CALCULATE STRESS
C
      DO K1=1, NTENS
         DO K2=1, NTENS
            STRESS(K1)=STRESS(K1)+DDSDDE(K2, K1)*DSTRAN(K2)
         END DO
      END DO
C
      RETURN
      END


Add mapping that tusesthe disk connectivity (with 5 blocks) to map to a square in [-1.1]x[-1,1] and then applies the pillow disk

subroutine mapc2m_pillowdisk5(blockno,xc1,yc1,
     &      xp,yp,zp,alpha)
      implicit none

      integer blockno
      double precision xc1, yc1
      double precision xc,yc,zc,xp,yp,zp,alpha

      call mapc2m_fivepatch(blockno,xc1,yc1,xc,yc,zc,alpha)

c     # Map from [-1,1]x[-1,1] back to [0,1]x[0,1]
      xc = (xc + 1)/2.d0
      yc = (yc + 1)/2.d0

      call mapc2m_pillowdisk(blockno,xc,yc,xp,yp,zp)

      end


subroutine setaux_nomap(mbc,mx,my,xlower,ylower,dx,dy,
     &      maux,aux)
      implicit none

      integer mbc, mx,my, meqn, maux
      double precision dx,dy, xlower, ylower
      double precision  aux(1-mbc:mx+mbc,1-mbc:my+mbc, maux)

      double precision t

      t = 0
      call compute_velocity_psi_nomap(mx,my,mbc,dx,dy,
     &      xlower,ylower,t,aux,maux)

      end

      subroutine compute_velocity_psi_nomap(mx,my,mbc,
     &      dx,dy,xlower,ylower,t,aux,maux)
      implicit none

      integer mx,my,mbc,maux
      double precision dx,dy, t, xlower,ylower

      double precision xd1(3),xd2(3)
      double precision aux(1-mbc:mx+mbc,1-mbc:my+mbc,maux)

      integer i,j
      double precision vn

      do i = 1-mbc,mx+mbc
         do j = 1-mbc,my+mbc
c           # x-faces
            xd1(1) = xlower + (i-1)*dx
            xd1(2) = ylower + (j)*dy
            xd1(3) = 0

            xd2(1) = xlower + (i-1)*dx
            xd2(2) = ylower + (j-1)*dy
            xd2(3) = 0

            call get_vel_psi(xd1,xd2,dy,vn,t)
            aux(i,j,2) = vn
         enddo
      enddo

      do j = 1-mbc,my+mbc
         do i = 1-mbc,mx+mbc
c           # y-faces
            xd1(1) = xlower + i*dx
            xd1(2) = ylower + (j-1)*dy
            xd1(3) = 0

            xd2(1) = xlower + (i-1)*dx
            xd2(2) = ylower + (j-1)*dy
            xd2(3) = 0

            call get_vel_psi(xd1,xd2,dx,vn,t)

            aux(i,j,3) = -vn
         enddo
      enddo

      end


program teams_subset
  !! author: Nathan Weeks
  !!
  !! Regression test for prior potential deadlock in change team/end team
  use iso_fortran_env, only : team_type
  use assertions_interface, only : assert
  implicit none

  type(team_type) team

  associate( initial_team_image => this_image())
  associate( myteam => merge(1,2,any(initial_team_image==[1,num_images()])) )

    form team (myteam, team)

    if (myteam == 1) then
      block
        integer max_image(2), min_image(2)
        change team(team)
          max_image = [initial_team_image, this_image()]
          call co_max(max_image)
          min_image = [initial_team_image, this_image()]
          call co_min(min_image)
        end team
        call assert( all(min_image==1), "minimum image number in team is 1" )
        call assert( all(max_image==[num_images(), 2]), "team maximum images numbers is num_images() or 2")
      end block
    end if

    sync all

    if (initial_team_image == 1) print *,"Test passed."

  end associate; end associate

end program

Clarify comments in new teams unit test

program teams_subset
  !! author: Nathan Weeks
  !!
  !! Regression test for prior potential deadlock in change team/end team
  use iso_fortran_env, only : team_type
  use assertions_interface, only : assert
  implicit none

  type(team_type) team

  associate( initial_team_image => this_image())
  associate( myteam => merge(1,2,any(initial_team_image==[1,num_images()])) )

    form team (myteam, team)

    if (myteam == 1) then
      block
        integer max_image(2), min_image(2)
        change team(team)
          max_image = [initial_team_image, this_image()]
          call co_max(max_image)
          min_image = [initial_team_image, this_image()]
          call co_min(min_image)
        end team
        call assert( all(min_image==1), "minimum image number in team 1 is 1" )
        call assert( all(max_image==[num_images(), 2]), "maximum image numbers on team 1 is num_images() or 2")
      end block
    end if

    sync all

    if (initial_team_image == 1) print *,"Test passed."

  end associate; end associate

end program


module bmi_heat

  use bmi_params
  use heat
  implicit none

  character (len=BMI_MAXCOMPNAMESTR), target :: &
       component_name = "The 2D Heat Equation"

contains

  function get_component_name(self, name) result(status)
    type (heat_model), intent (in) :: self
    character (len=*), pointer, intent (out) :: name
    integer :: status

    name => component_name
    status = BMI_SUCCESS
  end function get_component_name

end module bmi_heat

Add initialize and finalize BMI methods

module bmi_heat

  use bmi_params
  use heat
  implicit none

  character (len=BMI_MAXCOMPNAMESTR), target :: &
       component_name = "The 2D Heat Equation"

contains

  ! Perform startup tasks for the model.
  function initialize(self, config_file) result(status)
    type (heat_model), intent (out) :: self
    character (len=*), intent (in) :: config_file
    integer :: status

    if (len (config_file) > 0) then
       call initialize_from_file(self, config_file)
    else
       call initialize_from_defaults(self)
    end if

    status = BMI_SUCCESS
  end function initialize

  ! Perform tear-down tasks for the model.
  function finalize(self) result(status)
    type (heat_model), intent (inout) :: self
    integer :: status

    call cleanup(self)

    status = BMI_SUCCESS
  end function finalize

  ! Get the name of the model.
  function get_component_name(self, name) result(status)
    type (heat_model), intent (in) :: self
    character (len=*), pointer, intent (out) :: name
    integer :: status

    name => component_name
    status = BMI_SUCCESS
  end function get_component_name

end module bmi_heat


#! /bin/bash

source $STACI_HOME/functions/tools.f
node_prefix=$(getProperty "clusterNodePrefix")
cluster=$(getProperty "createCluster")
provider_type=$(getProperty "provider_type")

function exec_mysql_sql(){
   local sqlcmd=$1
   local appdb=$2
   mysql_pwd=$(getProperty "mysql_root_pass")

   # Point to cluster, if used
   if [ "$cluster" == "1" ]; then
      eval $(docker-machine env "$node_prefix-mysql")
   elif [ ! "$provider_type" == "none" ]; then
      eval $(docker-machine env "$node_prefix-Atlassian")
   fi

   local sql='mysql --user=root --password='"$mysql_pwd"' --database '"$appdb"' -e "'"$sqlcmd"'"'

   docker exec atlassiandb /bin/bash -c "$sql" &>> $STACI_HOME/logs/mysql.log
}

Fix shell syntax error on Mac

#! /bin/bash

source $STACI_HOME/functions/tools.f
node_prefix=$(getProperty "clusterNodePrefix")
cluster=$(getProperty "createCluster")
provider_type=$(getProperty "provider_type")

function exec_mysql_sql(){
   local sqlcmd=$1
   local appdb=$2
   mysql_pwd=$(getProperty "mysql_root_pass")

   # Point to cluster, if used
   if [ "$cluster" == "1" ]; then
      eval $(docker-machine env "$node_prefix-mysql")
   elif [ ! "$provider_type" == "none" ]; then
      eval $(docker-machine env "$node_prefix-Atlassian")
   fi

   local sql='mysql --user=root --password='"$mysql_pwd"' --database '"$appdb"' -e "'"$sqlcmd"'"'

   docker exec atlassiandb /bin/bash -c "$sql" & >> $STACI_HOME/logs/mysql.log
}


Add service program to decide a subscript (unsafe).

! Segment.f90
! Operations about segments.

module segment
contains
elemental function whichSegment(x, xLower,xUpper, iLower,iUpper) result (i)
  implicit none
  double presicion, intent (in) :: x - xLower, xUpper
  integer, intent (in) :: iLower, iUpper

  integer :: i

  i = iLower + floor(0.5 + (x-xLower) / (xUpper-xLower) * (iUpper-iLower))
end function whichSegment

end module segment


program main
  use lib

  implicit none
  include "mpif.h"

  call mpi_init(mpi_err)

  do i = 1, 42
     Iriguchi%U(i) = i*(i+1)
  end do

  call mpi_irecv(Deguchi , sizeof(Deguchi), MPI_BYTE, 0, 0, mpi_comm_world, req_recv ,mpi_err)
  call mpi_isend(Iriguchi, sizeof(Iriguchi), MPI_BYTE, 0, 0, mpi_comm_world, req_send ,mpi_err)
  call mpi_wait(req_recv, mpi_status_ignore,mpi_err)

  do i = 1, 42
     print *, Deguchi%U(i)
  end do

  call mpi_finalize(mpi_err)

end program main

Solve the secret of sizeof

program main
  use lib

  implicit none
  include "mpif.h"

  integer :: size_var

  call mpi_init(mpi_err)

  do i = 1, 42
     Iriguchi%U(i) = i*(i+1)
  end do

  print *, "sizeof deguchi = ", sizeof(Deguchi)
  size_var = sizeof(Deguchi)
  call mpi_irecv(Deguchi , size_var, MPI_BYTE, 0, 0, mpi_comm_world, req_recv ,mpi_err)
  call mpi_isend(Iriguchi, size_var, MPI_BYTE, 0, 0, mpi_comm_world, req_send ,mpi_err)
  call mpi_wait(req_recv, mpi_status_ignore,mpi_err)

  do i = 1, 42
     print *, Deguchi%U(i)
  end do

  call mpi_finalize(mpi_err)

end program main


SUBROUTINE calc_fits(images, model, parvals, n_vals, n_wlens, x, y, n_pars, results)

IMPLICIT NONE
INTEGER, INTENT(IN) :: n_vals, n_wlens, x, y, n_pars
REAL, DIMENSION(n_vals, n_pars), INTENT(IN) :: parvals
REAL, DIMENSION(n_vals, n_wlens), INTENT(IN) :: model
REAL, DIMENSION(n_wlens, x, y), INTENT(IN) :: images
REAL, DIMENSION(x, y, n_pars+1), INTENT(OUT) :: results
INTEGER :: i, j, t, w
REAL :: error, total_error, this_fit, best_fit

DO j = 1, y
  DO i = 1, x
    best_fit = 1000000.0
    DO t = 1, n_vals
      total_error = 0.0
      DO w = 1, n_wlens
        error = ABS(images(w,i,j) - model(t, w))
        total_error = total_error + error
      END DO
      this_fit = total_error / REAL(n_wlens)
      IF (this_fit < best_fit) THEN
        best_fit = this_fit
        results(i, j, 1:n_pars) = parvals(t, :)
        results(i, j, n_pars+1) = this_fit
      END IF
    END DO
  END DO
END DO

END SUBROUTINE calc_fits

Adjust how best fit value is dealt with

SUBROUTINE calc_fits(images, model, parvals, n_vals, n_wlens, x, y, n_pars, results)

IMPLICIT NONE
INTEGER, INTENT(IN) :: n_vals, n_wlens, x, y, n_pars
REAL, DIMENSION(n_vals, n_pars), INTENT(IN) :: parvals
REAL, DIMENSION(n_vals, n_wlens), INTENT(IN) :: model
REAL, DIMENSION(n_wlens, x, y), INTENT(IN) :: images
REAL, DIMENSION(x, y, n_pars+1), INTENT(OUT) :: results
INTEGER :: i, j, t, w
REAL :: error, total_error, this_fit, best_fit

DO j = 1, y
  DO i = 1, x
    best_fit = 0
    DO t = 1, n_vals
      total_error = 0.0
      DO w = 1, n_wlens
        error = ABS(images(w,i,j) - model(t, w))
        total_error = total_error + error
      END DO
      this_fit = total_error / REAL(n_wlens)
      IF (this_fit < best_fit .OR. t == 1) THEN
        best_fit = this_fit
        results(i, j, 1:n_pars) = parvals(t, :)
        results(i, j, n_pars+1) = this_fit
      END IF
    END DO
  END DO
END DO

END SUBROUTINE calc_fits


subroutine setprob()
      implicit none

      double precision kappa,tfinal
      double precision rot_angle(2), scale

      double precision pi
      common /compi/ pi

      pi = 4.d0*atan(1.d0)

c     # read in data to see whether we should run with fixed rotation or not.
      open(7,file='setprob.data')
      read(7,*) kappa
      read(7,*) Tfinal
      close(7)

c     # These are the values that work well with the hemisphere.  Other
c     # values don't work so well, since we don't have any inflow
c     # conditions set.

      kappa = 0
      tfinal = 5.0
      call set_wind_parms(kappa,tfinal);

c     # -------------------------------------------------
c     # Mapping routines
c     # -------------------------------------------------

c     # Set mapping scaling
      scale = 1
      rot_angle(1) = 0
      rot_angle(2) = 0
      call setup_mappedgrid(rot_angle,scale)
      end

Include rotation in the mapping

subroutine setprob()
      implicit none

      double precision kappa,tfinal
      double precision rot_angle(2), scale

      double precision pi
      common /compi/ pi

      pi = 4.d0*atan(1.d0)

c     # read in data to see whether we should run with fixed rotation or not.
      open(7,file='setprob.data')
      read(7,*) kappa
      read(7,*) Tfinal
      close(7)

c     # These are the values that work well with the hemisphere.  Other
c     # values don't work so well, since we don't have any inflow
c     # conditions set.

      kappa = 0
      tfinal = 5.0
      call set_wind_parms(kappa,tfinal);

c     # -------------------------------------------------
c     # Mapping routines
c     # -------------------------------------------------

c     # Set mapping scaling
      scale = 1
      rot_angle(1) = 1.34
      rot_angle(2) = 2.1
      call setup_mappedgrid(rot_angle,scale)
      end


MODULE mo_column

CONTAINS
 SUBROUTINE compute_column ( nz , q , t , nx , ny )
  INTEGER , INTENT(IN) :: nz
  REAL , INTENT(INOUT) :: t ( : , : , : )
  REAL , INTENT(INOUT) :: q ( : , : , : )
  INTEGER :: k
  REAL :: c
  INTEGER , INTENT(IN) :: nx
  INTEGER :: i
  INTEGER , INTENT(IN) :: ny
  INTEGER :: j

  c = 5.345
  DO k = 2 , nz , 1
   DO i = 1 , nx , 1
    DO j = 1 , ny , 1
     t ( i , j , k ) = c * k
    END DO
   END DO
   DO i = 1 , nx , 1
    DO j = 1 , ny , 1
     q ( i , j , k ) = q ( i , j , k - 1 ) + t ( i , j , k ) * c
    END DO
   END DO
  END DO
  DO i = 1 , nx , 1
   DO j = 1 , ny , 1
    q ( i , j , nz ) = q ( i , j , nz ) * c
   END DO
  END DO
 END SUBROUTINE compute_column

END MODULE mo_column

Update reference with inner most + intermediate

MODULE mo_column

CONTAINS
 SUBROUTINE compute_column ( nz , q , t , nx , ny )
  INTEGER , INTENT(IN) :: nz
  REAL , INTENT(INOUT) :: t ( : , : , : )
  REAL , INTENT(INOUT) :: q ( : , : , : )
  INTEGER :: k
  REAL :: c
  REAL :: d ( 1 : nx , 1 : ny )
  INTEGER , INTENT(IN) :: nx
  INTEGER :: i
  INTEGER , INTENT(IN) :: ny
  INTEGER :: j

  c = 5.345
  DO k = 2 , nz , 1
   DO j = 1 , ny , 1
    DO i = 1 , nx , 1
     t ( i , j , k ) = c * k
    END DO
   END DO
   DO j = 1 , ny , 1
    DO i = 1 , nx , 1
     d( i , j ) = t ( i , j , k ) + c
    END DO
   END DO
   DO j = 1 , ny , 1
    DO i = 1 , nx , 1
     q ( i , j , k ) = q ( i , j , k - 1 ) + t ( i , j , k ) * c + d ( i , j )
    END DO
   END DO
  END DO
  DO i = 1 , nx , 1
   DO j = 1 , ny , 1
    q ( i , j , nz ) = q ( i , j , nz ) * c
   END DO
  END DO
 END SUBROUTINE compute_column

END MODULE mo_column


! vim : tw=72 ts=2 sw=2
! sphericalcalculus.f90
! Implements for 3D vector calculus in spherical coordinates.
! Coded by jungerstein.
! Except for the licence, it is kind to contact me
! if the codes are involved in your original research.

module sphericalcalculus
  use sphericalvec3d
  interface operator (.div.)
    module procedure :: sphericalVectorDiv
  end interface

  contains

  ! Use central differentation.
  ! FIXME Check values at zero and polars.
  elemental function sphericalVectorDiv &
      (theVec, atRPrev, atRNext, atThPrev, atThNext, atPhPrev, atPhNext) &
      result (div)
    implicit none

    type (sphvec3), intent (in) :: theVec, atRPrev, atRNext, &
      atThPrev, atThNext, atPhPrev, atPhNext
    double precision :: div

    double precision :: rContrib, thContrib, phContrib

    ! FIXME Mind catastrophic cancellation.

    ! $\frac{1}{r^2} \left(r^2 A_r\right)_{,r}$
    rContrib = 1/(theVec%rPos**2) &
      * (atRNext%rPos ** 2 * atRNext%r - atRPrev%rPos ** 2 * atRPrev%r) &
      / (atRNext%rPos - atRPrev%rPos)

    ! $\frac{1}{\sin \theta} \left(B_\theta \sin\theta \right)_{,\theta}$
    thContrib = 1/(theVec%rPos * sin(theVec%thPos)) &
      * (atThNext%th * sin(atThNext%thPos) - atThPrev%th * sin(atThPrev%thPos)) &
      / (atThNext%thPos - atThPrev%thPos)

    ! $\frac{1}{\sin \theta} B_\phi_{,phi}$
    phContrib = 1/(theVec%rPos * sin(theVec%thPos)) &
      * (atPhNext%ph - atPhNext%th) &
      / (atPhNext%phPos - atPhPrev%phPos)

    div = rContrib + thContrib + phContrib
  end function sphericalVectorDiv
end module sphericalvec3d


subroutine rk4stepks(in_matrix, out_vector, n,m,p, in_out_vec)
!   Do one step of the classical 4th order Runge Kutta method,
!   starting from y at x with time step h and derivatives given by derivs
  implicit none
  integer :: n,m,p
  real(8) :: in_matrix(n,m)
  real(8) :: out_vector(n+m-1)
  real(8) :: in_out_vec(p)

!f2py real(8), intent(out), dimension(n+m-1) :: out_matix
!f2py real(8), intent(in), dimension(n,m) :: in_matrix
!f2py real(8), intent(inout), dimension(p) :: in_out_vec
!f2py integer, intent(in) :: n,m, p

  out_vector = (/ in_matrix(:,1), in_matrix(:,2) /)
  in_out_vec = in_out_vec*5
    return
    end subroutine

Change name of in_matrix to y.

subroutine rk4stepks(y, out_vector, n,m,p, in_out_vec)
!   Do one step of the classical 4th order Runge Kutta method,
!   starting from y at x with time step h and derivatives given by derivs
  implicit none
  integer :: n,m,p
  real(8) :: y(n,m)
  real(8) :: out_vector(n+m-1)
  real(8) :: in_out_vec(p)

!f2py real(8), intent(out), dimension(n+m-1) :: out_matix
!f2py real(8), intent(in), dimension(n,m) :: y
!f2py real(8), intent(inout), dimension(p) :: in_out_vec
!f2py integer, intent(in) :: n,m, p

  out_vector = (/ y(:,1), y(:,2) /)
  in_out_vec = in_out_vec*5
    return
    end subroutine


MODULE mo_column
  IMPLICIT NONE
CONTAINS
  ! Compute only one column
  SUBROUTINE compute_column(nz, q, t)
    IMPLICIT NONE

    INTEGER, INTENT(IN)   :: nz   ! Size of the array field
    REAL, INTENT(INOUT)   :: t(:) ! Field declared as one column only
    REAL, INTENT(INOUT)   :: q(:) ! Field declared as one column only
    INTEGER :: k                  ! Loop index
    REAL :: c                     ! Coefficient

    ! CLAW definition

    ! Define one dimension that will be added to the variables defined in the
    ! data clause.
    ! Apply the parallelization transformation on this subroutine.

    !$claw define dimension proma(1,nproma) &
    !$claw parallelize data(q,t) over (proma,:)

    c = 5.345
    DO k = 2, nz
      t(k) = c * k
      q(k) = q(k - 1)  + t(k) * c
    END DO
    q(nz) = q(nz) * c
  END SUBROUTINE compute_column
END MODULE mo_column

Remove the optional data/over clause

MODULE mo_column
  IMPLICIT NONE
CONTAINS
  ! Compute only one column
  SUBROUTINE compute_column(nz, q, t)
    IMPLICIT NONE

    INTEGER, INTENT(IN)   :: nz   ! Size of the array field
    REAL, INTENT(INOUT)   :: t(:) ! Field declared as one column only
    REAL, INTENT(INOUT)   :: q(:) ! Field declared as one column only
    INTEGER :: k                  ! Loop index
    REAL :: c                     ! Coefficient

    ! CLAW definition

    ! Define one dimension that will be added to the variables defined in the
    ! data clause.
    ! Apply the parallelization transformation on this subroutine.

    !$claw define dimension proma(1,nproma) &
    !$claw parallelize

    c = 5.345
    DO k = 2, nz
      t(k) = c * k
      q(k) = q(k - 1)  + t(k) * c
    END DO
    q(nz) = q(nz) * c
  END SUBROUTINE compute_column
END MODULE mo_column


Add a small example for get command line argument

program command_line
  implicit none
  character(len=:), allocatable :: arg
  integer long, i

  do i=0, COMMAND_ARGUMENT_COUNT()
    call GET_COMMAND_ARGUMENT( NUMBER=i, LENGTH=long )
    allocate( character(len=long) :: arg )
    call GET_COMMAND_ARGUMENT( NUMBER=i, VALUE=arg )
	! argument 0 is the name of the program
	! user argument starts from 1
    print *,"Argument number ", i, ": ", arg
    deallocate( arg )
  end do
end program command_line


module containers

  ! This module creates the type 'Container' which contains
  ! information about a container and the items that are packed inside
  ! it. It also provides some utility subroutines for printing, saving
  ! and working with containers.

  use items

  implicit none

  type Container

     ! Type of the container
     integer :: type

     ! Dimensions of the container
     real(8) :: length, width

     ! Number of packed items
     integer :: nItems

     ! List of packed items
     type(Item), allocatable :: pItems(:)

  end type Container

contains

  ! ***********************************************************
  ! ***********************************************************

  subroutine drawSol(c, output)

    ! This subroutine creates a .ASY file in order to draw the
    ! solution contained in a Container 'c'.

    implicit none

    ! SCALAR ARGUMENTS
    logical :: strip

    ! ARRAY ARGUMENTS
    character(80) :: output
    type(Container) :: c

    intent(in) :: c, output

    ! LOCAL SCALARS
    integer :: i
    real(8) :: scale
    type(Item) :: it

    ! Try to find a reasonable scale for drawing

    scale = max(1.0D-4, min(1.0D0, 30.0D0 / max(c%length, c%width)))

    ! Draws the solution in ASY format

    open(99, file=output)

    write(99, FMT=0001) scale

    ! Draw items

    do i = 1, c%nItems

       it = c%pItems(i)

       write(99, FMT=0003) it%x, it%y, it%length, it%width, &
            it%type, it%number

    end do

    ! Draw containers

    write(99, FMT=0002) c%length, c%width

    close(99)

0001 FORMAT('import packlib;',/,/,'settings.outformat = "pdf";',/, &
          'unitsize(',F10.5,'cm);')
0002 FORMAT('draw(box((0,0), (',F10.5,',',F10.5,')), currentpen + dashed + 2);')
0004 FORMAT('draw(box((0,0), (',F10.5,',',F10.5,')), currentpen + 2);')
0003 FORMAT('drawBox((',F10.5,',',F10.5,'), ',F10.5,', ',F10.5, &
            ', cor(',I2,'), currentpen, "', I4, '");')

  end subroutine drawSol

end module containers


! Chemharp, an efficient IO library for chemistry file formats
! Copyright (C) 2015 Guillaume Fraux
!
! This Source Code Form is subject to the terms of the Mozilla Public
! License, v. 2.0. If a copy of the MPL was not distributed with this
! file, You can obtain one at http://mozilla.org/MPL/2.0/
!
!
! This is the main module file for the Fortran interface to Chemharp.
!

module chemharp
    use iso_c_binding
    use strings
    implicit none

    include "generated/cenums.f90"
    include "generated/cdef.f90"
    include "generated/ftypes.f90"
contains
    include "generated/interface.f90"
end module chemharp

Set visibility of functions in fortran interface

! Chemharp, an efficient IO library for chemistry file formats
! Copyright (C) 2015 Guillaume Fraux
!
! This Source Code Form is subject to the terms of the Mozilla Public
! License, v. 2.0. If a copy of the MPL was not distributed with this
! file, You can obtain one at http://mozilla.org/MPL/2.0/
!
!
! This is the main module file for the Fortran interface to Chemharp.
!

module chemharp
    use iso_c_binding
    use strings
    implicit none
    private
    ! Export types
    public :: chrp_trajectory, chrp_frame, chrp_cell, chrp_topology, chrp_atom
    ! Export enums
    public:: CHRP_LOG_LEVEL, CHRP_LOG_NONE, CHRP_LOG_ERROR, CHRP_LOG_WARNING, CHRP_LOG_INFO, CHRP_LOG_DEBUG
    public:: CHRP_CELL_TYPES, CHRP_CELL_ORTHOROMBIC, CHRP_CELL_TRICLINIC, CHRP_CELL_INFINITE
    ! Export free functions
    public :: chrp_log_stderr, chrp_logfile, chrp_loglevel, chrp_last_error, chrp_strerror

    include "generated/cenums.f90"
    include "generated/cdef.f90"
    include "generated/ftypes.f90"
contains
    include "generated/interface.f90"
end module chemharp


! An example of converting the indices of a 9-element rank 1 array
! into the indices of a 3-by-3 rank 2 array. Column major ordering!
program convert_array_indices

  implicit none

  integer, dimension(9) :: a, j, i
  integer :: n, k, ny = 3

  n = size(a)

  do k = 1, n
     a(k) = k
  end do
  write(*, "(a, 9(i3))") "a =", a

  do k = 1, n
     j(k) = mod((k-1), ny) + 1
     i(k) = (k-1)/ny + 1
  end do
  write(*, "(a, 9(i3))") "j =", j
  write(*, "(a, 9(i3))") "i =", i

end program convert_array_indices


Add third program to read with perturbation

PROGRAM main_consumer_perturb
  USE m_ser
  IMPLICIT NONE
  REAL(KIND=8), DIMENSION(5,5,5) :: a

  a = 0.0
  PRINT*,'Before read from serializer: sum(a)=', sum(a)
  CALL deserialize_with_perturb(a)
  PRINT*,'After read from serializer: sum(a)=', sum(a)
END PROGRAM main_consumer_perturb


subroutine rk4stepks(x, y, h, yout, n, m, derivs)
!   Do one step of the classical 4th order Runge Kutta method,
!   starting from y at x with time step h and derivatives given by derivs
  implicit none
  integer :: n,m
  real(8) :: x, h
  real(8) :: y(0:n-1,0:m-1)
  real(8) :: yout(0:n-1,0:m-1)
  real(8), external :: derivs

!f2py real(8), intent(in) :: x, h
!f2py real(8), intent(out), dimension(0:n-1,0:m-1) :: yout
!f2py real(8), intent(in), dimension(0:n-1,0:m-1) :: y
!f2py integer, intent(in) :: n,m
!f2py real(8), external :: derivs

  yout = derivs(y, x)
    return
    end subroutine

Move external statement to another line.

subroutine rk4stepks(x, y, h, yout, n, m, derivs)
!   Do one step of the classical 4th order Runge Kutta method,
!   starting from y at x with time step h and derivatives given by derivs
  implicit none
  integer :: n,m
  real(8) :: x, h
  real(8) :: y(0:n-1,0:m-1)
  real(8) :: yout(0:n-1,0:m-1)
  real(8) :: derivs
  external derivs

!f2py real(8), intent(in) :: x, h
!f2py real(8), intent(out), dimension(0:n-1,0:m-1) :: yout
!f2py real(8), intent(in), dimension(0:n-1,0:m-1) :: y
!f2py integer, intent(in) :: n,m
!f2py real(8) :: derivs

  yout = derivs(y, x)
    return
    end subroutine


subroutine rk4stepks(x, y, h, yout, n, m)
!   Do one step of the classical 4th order Runge Kutta method,
!   starting from y at x with time step h and derivatives given by derivs
  implicit none
  integer :: n,m
  real(8) :: x, h
  real(8) :: y(0:n-1,0:m-1)
  real(8) :: yout(0:n-1,0:m-1)
!  real(8) :: derivs
!  external derivs

!f2py real(8), intent(in) :: x, h
!f2py real(8), intent(out), dimension(0:n-1,0:m-1) :: yout
!f2py real(8), intent(in), dimension(0:n-1,0:m-1) :: y
!f2py integer, intent(in) :: n,m

  yout = y
    return
    end subroutine

Add derivs back in slowly.

subroutine rk4stepks(x, y, h, yout, n, m, derivs)
!   Do one step of the classical 4th order Runge Kutta method,
!   starting from y at x with time step h and derivatives given by derivs
  implicit none
  integer :: n,m
  real(8) :: x, h
  real(8) :: y(0:n-1,0:m-1)
  real(8) :: yout(0:n-1,0:m-1)
  real(8) :: derivs
  external derivs

!f2py real(8), intent(in) :: x, h
!f2py real(8), intent(out), dimension(0:n-1,0:m-1) :: yout
!f2py real(8), intent(in), dimension(0:n-1,0:m-1) :: y
!f2py integer, intent(in) :: n,m

  x = derivs(n,m)
  yout = y
    return
    end subroutine


Add HT frame speed analysis, Step 1: Inv a 3x3 symm matrix.

! vim : tw=72 ts=2 sw=2
! velocityHT.f90
! Finds the velocity of deHoffman-Teller frame.
! Coded by jungerstein.
! Except for the licence, it is kind and proper to contact me
! if the codes are involved in your original research.
!
! EXTERNAL LIBRARY
! * mkl
! OTHERWISE
! 1. Can be slightly modified to use general lapack.

module vht
  use vec3d
  implicit none

  contains

  ! Encapsuled function to find the inverse of a 3x3 matrix.
  ! But the matrix must be symmetric.
  subroutine invSymMat(inv, mat, isSingularExpected)
    use mkl95_precision, only: wp=>dp
    use mkl95_lapack, only:
    implicit none

    double precision, dimension (3, 3), intent (out) :: inv
    double precision, dimension (3, 3), intent (in) :: mat
    logical, intent (in), optional :: isSingularExpected

    double precision, dimension (3, 3) :: working
    double precision, dimension (3) :: ipiv
    logical :: isNotComplainAboutSingular

    integer :: info

    working = mat
    isNotComplainAboutSingular = .false.
    if (present(isSingularExpected)) then
      isNotComplainAboutSingular = isSingularExpected
    end if

    call getrf(working, ipiv, info)

    if ((info .ne. 0) .and. (.not. isSingularExpected)) then
      print *, 'Singular matrix. '
      stop
    end if

    call getri(working, ipiv)
    inv = working
  end subroutine invMat
end module vht


subroutine rk4stepks(x, y, h, yout, n, m, derivs)
!   Do one step of the classical 4th order Runge Kutta method,
!   starting from y at x with time step h and derivatives given by derivs
  implicit none
  integer :: n,m
  real(8) :: x, h
  real(8) :: y(0:n-1,0:m-1)
  real(8) :: yout(0:n-1,0:m-1)
  real(8) :: derivs
  external derivs

!f2py real(8), intent(in) :: x, h
!f2py real(8), intent(out), dimension(0:n-1,0:m-1) :: yout
!f2py real(8), intent(in), dimension(0:n-1,0:m-1) :: y
!f2py integer, intent(in) :: n,m

  yout = derivs(y, x)
    return
    end subroutine

Comment out derivs to test where error is coming from.

subroutine rk4stepks(x, y, h, yout, n, m)
!   Do one step of the classical 4th order Runge Kutta method,
!   starting from y at x with time step h and derivatives given by derivs
  implicit none
  integer :: n,m
  real(8) :: x, h
  real(8) :: y(0:n-1,0:m-1)
  real(8) :: yout(0:n-1,0:m-1)
!  real(8) :: derivs
!  external derivs

!f2py real(8), intent(in) :: x, h
!f2py real(8), intent(out), dimension(0:n-1,0:m-1) :: yout
!f2py real(8), intent(in), dimension(0:n-1,0:m-1) :: y
!f2py integer, intent(in) :: n,m

  yout = y
    return
    end subroutine


subroutine rk4stepks(x, y, h, out_vector, n,m)
!   Do one step of the classical 4th order Runge Kutta method,
!   starting from y at x with time step h and derivatives given by derivs
  implicit none
  integer :: n,m
  real(8) :: x, h
  real(8) :: y(n,m)
  real(8) :: out_vector(n+m-1)

!f2py real(8), intent(in) :: x, h
!f2py real(8), intent(out), dimension(n+m-1) :: out_matix
!f2py real(8), intent(in), dimension(n,m) :: y
!f2py integer, intent(in) :: n,m

  out_vector = (/ y(:,1), y(:,2) /)
    return
    end subroutine

Change to zero indexing for y.

subroutine rk4stepks(x, y, h, out_vector, n,m)
!   Do one step of the classical 4th order Runge Kutta method,
!   starting from y at x with time step h and derivatives given by derivs
  implicit none
  integer :: n,m
  real(8) :: x, h
  real(8) :: y(0:n-1,0:m-1)
  real(8) :: out_vector(n+m-1)

!f2py real(8), intent(in) :: x, h
!f2py real(8), intent(out), dimension(n+m-1) :: out_matix
!f2py real(8), intent(in), dimension(0:n-1,0:m-1) :: y
!f2py integer, intent(in) :: n,m

  out_vector = (/ y(:,1), y(:,2) /)
    return
    end subroutine


Add query functions that can be easily called from fortran

logical function ispillowsphere()
      implicit none

      integer id, fclaw2d_map_is_pillowsphere
      integer*8 cont, get_context

      cont = get_context()

      id = fclaw2d_map_is_pillowsphere(cont)
      ispillowsphere = id .ne. 0

      end

      logical function iscubedsphere()
      implicit none

      integer id, fclaw2d_map_is_cubedsphere
      integer*8 cont, get_context

      cont = get_context()

      id = fclaw2d_map_is_cubedsphere(cont)
      iscubedsphere = id .ne. 0

      end

      logical function isflat()
      implicit none

      integer id, fclaw2d_map_is_flat
      integer*8 cont, get_context

      cont = get_context()

      id = fclaw2d_map_is_flat(cont)
      isflat = id .ne. 0

      end

      logical function issphere()
      implicit none

      integer id, fclaw2d_map_is_sphere
      integer*8 cont, get_context

      cont = get_context()

      id = fclaw2d_map_is_sphere(cont)
      issphere = id .ne. 0

      end

      logical function iscart()
      implicit none

      integer id, fclaw2d_map_is_cart
      integer*8 cont, get_context

      cont = get_context()

      id = fclaw2d_map_is_cart(cont)
      iscart = id .ne. 0

      end

      logical function isdisk()
      implicit none

      integer id, fclaw2d_map_is_disk
      integer*8 cont, get_context

      cont = get_context()

      id = fclaw2d_map_is_disk(cont)
      isdisk = id .ne. 0

      end


subroutine mapc2m_torus(blockno,xc,yc,xp,yp,zp,alpha)
      implicit none

      integer blockno
      double precision xc,yc,xp,yp,zp
      double precision alpha, r

      double precision pi

      common /compi/ pi

      r = 1 + alpha*cos(2*pi*(yc + xc))

      xp = r*cos(2*pi*xc)
      yp = r*sin(2*pi*xc)
      zp = alpha*sin(2*pi*(yc + xc))

      end


program async_comp_alloc_2
  !! Author: Izaak Beekman, Andre Vehreschild
  !! Category: Regression
  !! Regression test for issue [#399](https://github.com/sourceryinstitute/OpenCoarrays/issues/399)
  implicit none
  type :: nonsymmetric
     real, dimension(:), allocatable :: arr
  end type

  type(nonsymmetric), codimension[*] :: parent_obj

  sync all

  associate(me => this_image())
    if (me == 2) then
      allocate(parent_obj%arr(3))
      print *, 'Image 2: memory allocated.'
    end if

    sync all

    if (me == 1) then
      print *, 'Alloc status on [2]: ', allocated(parent_obj[2]%arr)
      print *, 'Image 2 has size ', size(parent_obj[2]%arr), ' asymmetric allocation'
      if (size(parent_obj[2]%arr) /= 3) error stop 'Test failed.'
      sync all
      print *, 'Test passed.'
    else
      sync all
    end if
  end associate
end program

Add assertion to async_com_alloc_2 for minimum img

program async_comp_alloc_2
  !! Author: Izaak Beekman, Andre Vehreschild
  !! Category: Regression
  !! Regression test for issue [#399](https://github.com/sourceryinstitute/OpenCoarrays/issues/399)
  implicit none
  type :: nonsymmetric
     real, dimension(:), allocatable :: arr
  end type

  type(nonsymmetric), codimension[*] :: parent_obj

  sync all

  if ( num_images() < 2 ) error stop "Test async_comp_alloc_2 requires at least 2 images to run"

  associate(me => this_image())
    if (me == 2) then
      allocate(parent_obj%arr(3))
      print *, 'Image 2: memory allocated.'
    end if

    sync all

    if (me == 1) then
      print *, 'Alloc status on [2]: ', allocated(parent_obj[2]%arr)
      print *, 'Image 2 has size ', size(parent_obj[2]%arr), ' asymmetric allocation'
      if (size(parent_obj[2]%arr) /= 3) error stop 'Test failed.'
      sync all
      print *, 'Test passed.'
    else
      sync all
    end if
  end associate
end program


! Simple program to test the to-loop directive

PROGRAM VECTOR_LOOP
  CALL claw
END

! Before the transformation
SUBROUTINE claw
  INTEGER :: j
  INTEGER :: i = 10
  INTEGER, DIMENSION(0:10) :: vec1

  DO j = 0, i
    vec1(j) = j
  END DO

  !$claw array-transform
  vec1(0:i) = vec1(0:i) + 10

  PRINT*,vec1
END SUBROUTINE claw

! Example of the transformation for development purpose
SUBROUTINE claw_transformed
  INTEGER :: i = 10
  INTEGER, DIMENSION(0:10) :: vec1
  INTEGER :: claw_induc1 ! induction variable is declared

  DO j = 0, i
    vec1(j) = j
  END DO

  ! Do stmt is inserted
  DO claw_induc1=0,i
    ! index range are replaced with arrayIndex
    vec1(claw_induc1) = vec1(claw_induc1) + 10
  END DO

  PRINT*,vec1
  PRINT*,vec2
END SUBROUTINE claw_transformed

Use array notation without lower and upper bounds

! Simple program to test the to-loop directive

PROGRAM VECTOR_LOOP
  CALL claw
  CALL claw_transformed
END

! Before the transformation
SUBROUTINE claw
  INTEGER :: j
  INTEGER, DIMENSION(0:10) :: vec1

  DO j = 0, 10
    vec1(j) = j
  END DO

  !$claw array-transform
  vec1(:) = vec1(:) + 10

  PRINT*,vec1
END SUBROUTINE claw

! Example of the transformation for development purpose
SUBROUTINE claw_transformed
  INTEGER :: i = 10
  INTEGER, DIMENSION(0:10) :: vec1
  INTEGER :: claw_induc1 ! induction variable is declared

  DO j = 0, i
    vec1(j) = j
  END DO

  ! Do stmt is inserted
  DO claw_induc1=0,i
    ! index range are replaced with arrayIndex
    vec1(claw_induc1) = vec1(claw_induc1) + 10
  END DO

  PRINT*,vec1
END SUBROUTINE claw_transformed