lfortran · certik · Sep 12, 2024 · Sep 12, 2024 · Sep 14, 2024 · Sep 14, 2024
diff --git a/.github/workflows/CI.yml b/.github/workflows/CI.yml
@@ -1468,3 +1468,32 @@ jobs:
         env:
           SSH_PRIVATE_KEY_DOCS: ${{ secrets.SSH_PRIVATE_KEY_DOCS }}
 
+
+  # build-and-push-image:
+  #   runs-on: ubuntu-latest
+  #   permissions:
+  #     contents: read
+  #     packages: write
+  #   env:
+  #     REGISTRY: ghcr.io
+  #     USER: lfortran
+  #     PROJECT: lfortran
+  #   steps:
+  #     - uses: actions/checkout@v4
+  #       with:
+  #         fetch-depth: 0
+
+  #     - name: Log in to the Container registry
+  #       if: ${{ github.event_name == 'push' }}
+  #       uses: docker/login-action@v3
+  #       with:
+  #         registry: ${{ env.REGISTRY }}
+  #         username: ${{ env.USER }}
+  #         password: ${{ secrets.GITHUB_TOKEN }}
+
+  #     - name: Build and push
+  #       uses: docker/build-push-action@v6
+  #       with:
+  #         context: .
+  #         push: ${{ github.event_name == 'push' }}
+  #         tags: ${{ env.REGISTRY }}/${{ env.USER }}/${{ env.PROJECT }}:latest
diff --git a/.github/workflows/upload_docker_build.yml b/.github/workflows/upload_docker_build.yml
diff --git a/integration_tests/CMakeLists.txt b/integration_tests/CMakeLists.txt
@@ -909,6 +909,10 @@ RUN(NAME intrinsics_315 LABELS llvm llvm_wasm llvm_wasm_emcc) # out_of_range
 RUN(NAME intrinsics_316 LABELS gfortran llvm llvm_wasm llvm_wasm_emcc fortran) # max, min
 RUN(NAME intrinsics_317 LABELS gfortran llvm llvm_wasm llvm_wasm_emcc fortran) # get_command_argument
 RUN(NAME intrinsics_318 LABELS gfortran llvm llvm_wasm llvm_wasm_emcc) # cpu_time
+RUN(NAME intrinsics_319 LABELS gfortran llvm llvm_wasm llvm_wasm_emcc) # system_clock
+RUN(NAME intrinsics_320 LABELS gfortran llvm llvm_wasm llvm_wasm_emcc fortran) # len_trim
+RUN(NAME intrinsics_321 LABELS gfortran llvm llvm_wasm llvm_wasm_emcc fortran) # trim
+RUN(NAME intrinsics_322 LABELS gfortran llvm llvm_wasm llvm_wasm_emcc fortran) # index
 
 RUN(NAME la_constants LABELS gfortran llvm llvm_wasm llvm_wasm_emcc NOFAST) # LAPACK constants
 
@@ -1810,3 +1814,9 @@ RUN(NAME func_parameter_type_02 LABELS gfortran) # function passed in other argu
 RUN(NAME logical_not_01 LABELS gfortran llvm llvm_wasm llvm_wasm_emcc)
 # TODO: we should eventually save the below program's ASR as well
 RUN(NAME elemental_function_scalar_array_arg LABELS gfortran llvm llvm_wasm llvm_wasm_emcc)
+# TOD: below is an MRE extracted from stdlib, it currently fails
+# we need to fix it
+# RUN(NAME generic_interface_function_call_of_function_call LABELS gfortran llvm llvm_wasm llvm_wasm_emcc
+#     EXTRA_ARGS --realloc-lhs)
+RUN(NAME elemental_function_overloaded_compare LABELS gfortran llvm llvm_wasm llvm_wasm_emcc
+    EXTRA_ARGS --realloc-lhs)
diff --git a/integration_tests/elemental_function_overloaded_compare.f90 b/integration_tests/elemental_function_overloaded_compare.f90
@@ -0,0 +1,55 @@
+! program extracted as MRE from https://github.com/fortran-lang/stdlib
+! there is missing implementation of functions/subroutines like
+! check_logical, eq_string_char, new_string_from_integer_int32 etc.
+! but as that's not need to be able to compile and run the MRE,
+! that's being skipped for now, actually we tried having their implementation
+! as well, but the program failed to run (take that as a TODO)
+module mod_elemental_function_overloaded_compare
+    use iso_fortran_env, only: int32
+    implicit none
+    !> String type holding an arbitrary sequence of characters.
+
+    interface operator(==)
+        module procedure :: eq_string_char
+    end interface operator(==)
+
+    type :: string_type
+        sequence
+        private
+        character(len=:), allocatable :: raw
+    end type string_type
+
+    contains
+
+    subroutine check_logical(expression)
+        logical, intent(in) :: expression
+        if (.not. expression) then
+            print *, "Condition not fulfilled"
+        end if
+    end subroutine check_logical
+
+    elemental function eq_string_char(lhs, rhs) result(is_eq)
+        type(string_type), intent(in) :: lhs
+        character(len=*), intent(in) :: rhs
+        logical :: is_eq
+    end function eq_string_char
+
+    elemental module function new_string_from_integer_int32(val) result(new)
+        integer(int32), intent(in) :: val
+        type(string_type) :: new
+    end function new_string_from_integer_int32
+
+    subroutine test_constructor()
+        character(len=128) :: flc
+
+        write(flc, '(i0)') -1026191
+        call check_logical(new_string_from_integer_int32(-1026191) == trim(flc))
+    end subroutine test_constructor
+
+end module mod_elemental_function_overloaded_compare
+
+program test_elemental_function_overloaded_compare
+    use mod_elemental_function_overloaded_compare
+    implicit none
+    call test_constructor()
+end program
diff --git a/integration_tests/generic_interface_function_call_of_function_call.f90 b/integration_tests/generic_interface_function_call_of_function_call.f90
@@ -0,0 +1,85 @@
+module stdlib_linalg
+    implicit none
+
+    ! Define the generic interface 'diag'
+    interface diag
+        procedure :: diag_iint16_mat  ! Handles matrix to vector
+        procedure :: diag_iint16_vec  ! Handles vector to matrix
+    end interface
+
+contains
+
+    ! Function to extract the diagonal of a matrix
+    module function diag_iint16_mat(A) result(res)
+        integer(4), intent(in) :: A(:,:)
+        integer(4) :: res(minval(shape(A)))
+        integer :: i
+
+        do i = 1, minval(shape(A))
+            res(i) = A(i, i)
+        end do
+    end function diag_iint16_mat
+
+    ! Function to create a diagonal matrix from a vector
+    module function diag_iint16_vec(v) result(res)
+        integer(4), intent(in) :: v(:)
+        integer(4) :: res(size(v), size(v))
+        integer :: i, j
+
+        ! Initialize the result matrix to zero
+        res = 0
+
+        ! Assign the vector elements to the diagonal of the matrix
+        do i = 1, size(v)
+            res(i, i) = v(i)
+        end do
+    end function diag_iint16_vec
+
+    ! Test subroutine to demonstrate diag(diag(a))
+    subroutine test_diag_int16()
+        integer, parameter :: n = 4
+        integer(4) :: a(n, n), d(n**2)
+        integer(4) :: e(n, n)
+        integer :: j
+
+        ! Initialize the array 'd' with values from 1 to n^2
+        do j = 1, n**2
+            d(j) = j
+        end do
+
+        ! Reshape 'd' into an n x n matrix 'a'
+        a = reshape(d, [n, n])
+
+        ! Apply diag twice: first to extract the diagonal vector,
+        ! then to create a diagonal matrix
+        e = diag(diag(a))
+
+        ! Optional: Print the results for verification
+        print *, "Matrix a:"
+        do j = 1, n
+            print *, a(j, :)
+        end do
+
+        print *, "Diagonal of a:"
+        print *, diag(a)
+        if (any(diag(a) /= [1, 6, 11, 16])) error stop
+
+        print *, "diag(diag(a)):"
+        print *, e(1, :)
+        if (any(e(1, :) /= [1, 0, 0, 0])) error stop
+        print *, e(2, :)
+        if (any(e(2, :) /= [0, 6, 0, 0])) error stop
+        print *, e(3, :)
+        if (any(e(3, :) /= [0, 0, 11, 0])) error stop
+        print *, e(4, :)
+        if (any(e(4, :) /= [0, 0, 0, 16])) error stop
+    end subroutine test_diag_int16
+
+end module stdlib_linalg
+
+program main
+    use stdlib_linalg
+    implicit none
+
+    call test_diag_int16()
+end program main
diff --git a/integration_tests/intrinsics_233.f90 b/integration_tests/intrinsics_233.f90
@@ -1,6 +1,7 @@
 program intrinsics_233
     implicit none
     real :: x
+    real :: z = -1.0
     real :: y(3)
     x = -1.0
     x = sqrt(x)
@@ -18,4 +19,11 @@ program intrinsics_233
     print*, y(3)
     print *, isnan(y(3))
     if (isnan(y(3)) .neqv. .true.) error stop
+
+    !tests for compile time argument
+    print *, isnan(1.0)
+    if (isnan(1.0) .neqv. .false.) error stop
+    print *, isnan(sqrt(z))
+    if (isnan(sqrt(z)) .neqv. .true.) error stop
+
 end program
diff --git a/integration_tests/intrinsics_275.f90 b/integration_tests/intrinsics_275.f90
@@ -8,8 +8,9 @@ program intrinsics_275
     integer, parameter :: i2 = and(-1, 5)
     integer, parameter :: i3 = and(-4_8, 2_8)
     integer(8), parameter :: i4 = and(-2_8, 5_8)
-    ! logical, parameter :: l1 = and(.true., .false.) ! Does not work yet! #4380
-    ! logical :: true = .true., false = .false.
+    logical, parameter :: l1 = and(.true., .false.) 
+    logical, parameter :: l2 = and(.true., .true.) 
+    logical :: true = .true., false = .false.
 
     print *, i1
     if (i1 /= 0) error stop
@@ -19,11 +20,17 @@ program intrinsics_275
     if (i3 /= 0) error stop
     print *, i4
     if (i4 /= 4) error stop
-    ! print *, l1
-    ! if (l1 .neqv. .false.) error stop
 
-    ! print *, and(true, false)
-    ! if (and(true, false) .neqv. .false.) error stop
+    ! logical argument testing
+    print *, l1
+    if (l1 .neqv. .false.) error stop
+    print *, l2
+    if (l2 .neqv. .true.) error stop
+    print *, and(true, false)
+    if (and(true, false) .neqv. .false.) error stop 
+    print *, and(true, true)
+    if (and(true, true) .neqv. .true.) error stop 
+
     print*, and(5, 8)
     if (and(5, 8) /= 0) error stop
     print*, and(-1, 5)

diff --git a/integration_tests/intrinsics_288.f90 b/integration_tests/intrinsics_288.f90
@@ -12,6 +12,15 @@ program intrinsics_288
 	real, dimension(3, 2) :: result2
 	logical, dimension(2, 3) :: result3
 	complex, dimension(3, 2) :: result4
+	integer :: a = 1
+    integer, dimension(2) :: result5
+	character :: ch = 'b'
+    character, dimension(2) :: result6
+	logical :: lo = .true.
+    logical, dimension(2) :: result7
+	real :: rl = 1.0
+    real, dimension(2) :: result8
+
     result = spread(source, dim=2, ncopies=2)
     print *, result
     if (result(1, 1) /= 1 .or. result(1, 2) /= 1 .or. result(2, 1) /= 2 .or. &
@@ -50,4 +59,22 @@ program intrinsics_288
 	if (result4(1, 1) /= (1, 2) .or. result4(1, 2) /= (1, 2) .or. result4(2, 1) /= (2, 3) .or. &
 		result4(2, 2) /= (2, 3) .or. result4(3, 1) /= (3, 4) .or. result4(3, 2) /= (3, 4)) error stop
 	print *, spread(source5, 1, 3) ! Wrong output with LFortran
+
+	! tests for Scalar Sources
+	result5 = SPREAD(a, 1, 2)
+    print *, result5
+    if (result5(1) /= 1 .or. result5(2) /= 1 ) error stop
+
+	result6 = SPREAD(ch, 1, 2)
+    print *, result6
+    if (result6(1) /= 'b' .or. result6(2) /= 'b' ) error stop
+
+	result7 = SPREAD(lo, 1, 2)
+    print *, result7
+    if ( (result7(1) .neqv. .true.) .or. (result7(2) .neqv. .true.) )  error stop
+
+	result8 = SPREAD(rl, 1, 2)
+    print *, result8
+    if ( abs(result8(1) - 1.0) > 1e-6 .or. abs(result8(2) - 1.0) > 1e-6 ) error stop
+
 end program
diff --git a/integration_tests/intrinsics_322.f90 b/integration_tests/intrinsics_322.f90
@@ -0,0 +1,7 @@
+program intrinsics_322
+    character(3) :: cx(2)
+    cx(1) = "woo"
+    cx(2) = "oba"
+    print *, index(cx, "a")
+    if (any(index(cx, "a") /= [0, 3])) error stop
+end program
diff --git a/src/lfortran/semantics/ast_common_visitor.h b/src/lfortran/semantics/ast_common_visitor.h
@@ -798,6 +798,7 @@ class CommonVisitor : public AST::BaseVisitor<Derived> {
         {"lge", {IntrinsicSignature({"string_A", "string_B"}, 2, 2)}},
         {"lle", {IntrinsicSignature({"string_A", "string_B"}, 2, 2)}},
         {"iand", {IntrinsicSignature({"i", "j"}, 2, 2)}},
+        {"and", {IntrinsicSignature({"i", "j"}, 2, 2)}},
         {"ior", {IntrinsicSignature({"i", "j"}, 2, 2)}},
         {"ieor", {IntrinsicSignature({"i", "j"}, 2, 2)}},
         {"ibclr", {IntrinsicSignature({"i", "pos"}, 2, 2)}},
@@ -924,7 +925,6 @@ class CommonVisitor : public AST::BaseVisitor<Derived> {
         {"ddim", {"dim", {"real8", "real8"}}},
         {"amod", {"mod", {"real4", "real4"}}},
         {"dmod", {"mod", {"real8", "real8"}}},
-        {"and", {"iand", {"any", "any"}}},
         {"or", {"ior", {"any", "any"}}},
         {"xor", {"ieor", {"any", "any"}}},
     };
@@ -5758,12 +5758,12 @@ class CommonVisitor : public AST::BaseVisitor<Derived> {
     }
 
     void scalar_kind_arg(std::string &name, Vec<ASR::expr_t*> &args) {
-        std::vector<std::string> optional_kind_arg = {"logical", "storage_size", "anint", "nint", "aint", "floor",
-            "ceiling", "aimag", "maskl", "maskr", "ichar", "char", "achar", "real"};
+        std::vector<std::string> optional_kind_arg = {"logical", "storage_size", "anint", "nint", "aint", "floor", 
+            "ceiling", "aimag", "maskl", "maskr", "ichar", "char", "achar", "real", "int"};
         if (std::find(optional_kind_arg.begin(), optional_kind_arg.end(), name) != optional_kind_arg.end()) {
             if (args[1]) {
                 if (ASRUtils::is_array(ASRUtils::expr_type(args[1]))) {
-                    throw SemanticError("Expected scalar argument for " + name + " intrinsic", args[1]->base.loc);
+                    throw SemanticError("kind argument of `" + name + "` intrinsic must be a scalar", args[1]->base.loc);
                 }
             }
         }

diff --git a/src/lfortran/semantics/comptime_eval.h b/src/lfortran/semantics/comptime_eval.h
@@ -69,7 +69,6 @@ struct IntrinsicProcedures {
             // in intrinsic_function_transformation()
             // So we shouldn't even encounter them here
             {"newunit", {m_custom, &not_implemented, false}},
-            {"present", {m_builtin, &not_implemented, false}},
 
             // IEEE Arithmetic
             {"ieee_value", {m_ieee_arithmetic, &not_implemented, false}},