intrinsic.c (add_functions): Add SELECTED_CHAR_KIND intrinsic.
* intrinsic.c (add_functions): Add SELECTED_CHAR_KIND intrinsic. * intrinsic.h (gfc_check_selected_char_kind, gfc_simplify_selected_char_kind): New prototypes. * gfortran.h (gfc_isym_id): Add GFC_ISYM_SC_KIND. * trans.h (gfor_fndecl_sc_kind): New function decl. * trans-decl.c (gfor_fndecl_sc_kind): Build new decl. * arith.c (gfc_compare_with_Cstring): New function. * arith.h (gfc_compare_with_Cstring): New prototype. * check.c (gfc_check_selected_char_kind): New function. * primary.c (match_string_constant, match_kind_param): Mark symbols used as literal constant kind param as referenced. * trans-intrinsic.c (gfc_conv_intrinsic_sc_kind): New function. (gfc_conv_intrinsic_function): Call gfc_conv_intrinsic_sc_kind. * intrinsic.texi (SELECTED_CHAR_KIND): Document new intrinsic. * simplify.c (gfc_simplify_selected_char_kind): New function. * intrinsics/selected_char_kind.c: New file. * Makefile.am: Add intrinsics/selected_char_kind.c. * Makefile.in: Regenerate. * gfortran.dg/selected_char_kind_1.f90: New test. * gfortran.dg/selected_char_kind_2.f90: New test. * gfortran.dg/selected_char_kind_3.f90: New test. From-SVN: r134839
This commit is contained in:
François-Xavier Coudert
parent
a91ded4bb8
commit
a39faface6
@ -1,8 +1,26 @@
|
||||
2008-04-30 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
* intrinsic.c (add_functions): Add SELECTED_CHAR_KIND intrinsic.
|
||||
* intrinsic.h (gfc_check_selected_char_kind,
|
||||
gfc_simplify_selected_char_kind): New prototypes.
|
||||
* gfortran.h (gfc_isym_id): Add GFC_ISYM_SC_KIND.
|
||||
* trans.h (gfor_fndecl_sc_kind): New function decl.
|
||||
* trans-decl.c (gfor_fndecl_sc_kind): Build new decl.
|
||||
* arith.c (gfc_compare_with_Cstring): New function.
|
||||
* arith.h (gfc_compare_with_Cstring): New prototype.
|
||||
* check.c (gfc_check_selected_char_kind): New function.
|
||||
* primary.c (match_string_constant, match_kind_param): Mark
|
||||
symbols used as literal constant kind param as referenced.
|
||||
* trans-intrinsic.c (gfc_conv_intrinsic_sc_kind): New function.
|
||||
(gfc_conv_intrinsic_function): Call gfc_conv_intrinsic_sc_kind.
|
||||
* intrinsic.texi (SELECTED_CHAR_KIND): Document new intrinsic.
|
||||
* simplify.c (gfc_simplify_selected_char_kind): New function.
|
||||
|
||||
2008-04-28 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/35997
|
||||
* module.c (find_symbol): Do not return a result for a symbol
|
||||
that has been renamed in another module.
|
||||
PR fortran/35997
|
||||
* module.c (find_symbol): Do not return a result for a symbol
|
||||
that has been renamed in another module.
|
||||
|
||||
2008-04-26 George Helffrich <george@gcc.gnu.org>
|
||||
|
||||
|
||||
@ -1208,7 +1208,7 @@ gfc_compare_string (gfc_expr *a, gfc_expr *b)
|
||||
alen = a->value.character.length;
|
||||
blen = b->value.character.length;
|
||||
|
||||
len = (alen > blen) ? alen : blen;
|
||||
len = MAX(alen, blen);
|
||||
|
||||
for (i = 0; i < len; i++)
|
||||
{
|
||||
@ -1224,7 +1224,40 @@ gfc_compare_string (gfc_expr *a, gfc_expr *b)
|
||||
}
|
||||
|
||||
/* Strings are equal */
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
|
||||
{
|
||||
int len, alen, blen, i, ac, bc;
|
||||
|
||||
alen = a->value.character.length;
|
||||
blen = strlen (b);
|
||||
|
||||
len = MAX(alen, blen);
|
||||
|
||||
for (i = 0; i < len; i++)
|
||||
{
|
||||
/* We cast to unsigned char because default char, if it is signed,
|
||||
would lead to ac < 0 for string[i] > 127. */
|
||||
ac = (unsigned char) ((i < alen) ? a->value.character.string[i] : ' ');
|
||||
bc = (unsigned char) ((i < blen) ? b[i] : ' ');
|
||||
|
||||
if (!case_sensitive)
|
||||
{
|
||||
ac = TOLOWER (ac);
|
||||
bc = TOLOWER (bc);
|
||||
}
|
||||
|
||||
if (ac < bc)
|
||||
return -1;
|
||||
if (ac > bc)
|
||||
return 1;
|
||||
}
|
||||
|
||||
/* Strings are equal */
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
@ -40,6 +40,8 @@ arith gfc_range_check (gfc_expr *);
|
||||
|
||||
int gfc_compare_expr (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
|
||||
int gfc_compare_string (gfc_expr *, gfc_expr *);
|
||||
int gfc_compare_with_Cstring (gfc_expr *, const char *, bool);
|
||||
|
||||
|
||||
/* Constant folding for gfc_expr trees. */
|
||||
gfc_expr *gfc_parentheses (gfc_expr * op);
|
||||
|
||||
@ -2349,6 +2349,22 @@ gfc_check_secnds (gfc_expr *r)
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_selected_char_kind (gfc_expr *name)
|
||||
{
|
||||
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (name, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_selected_int_kind (gfc_expr *r)
|
||||
{
|
||||
|
||||
@ -465,6 +465,7 @@ enum gfc_isym_id
|
||||
GFC_ISYM_RESHAPE,
|
||||
GFC_ISYM_RRSPACING,
|
||||
GFC_ISYM_RSHIFT,
|
||||
GFC_ISYM_SC_KIND,
|
||||
GFC_ISYM_SCALE,
|
||||
GFC_ISYM_SCAN,
|
||||
GFC_ISYM_SECNDS,
|
||||
|
||||
@ -2141,6 +2141,13 @@ add_functions (void)
|
||||
|
||||
make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU);
|
||||
|
||||
add_sym_1 ("selected_char_kind", GFC_ISYM_SC_KIND, CLASS_TRANSFORMATIONAL,
|
||||
ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003,
|
||||
gfc_check_selected_char_kind, gfc_simplify_selected_char_kind,
|
||||
NULL, nm, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
make_generic ("selected_char_kind", GFC_ISYM_SC_KIND, GFC_STD_F2003);
|
||||
|
||||
add_sym_1 ("selected_int_kind", GFC_ISYM_SI_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
|
||||
GFC_STD_F95, gfc_check_selected_int_kind,
|
||||
gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED);
|
||||
|
||||
@ -120,6 +120,7 @@ try gfc_check_scale (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_second_sub (gfc_expr *);
|
||||
try gfc_check_secnds (gfc_expr *);
|
||||
try gfc_check_selected_char_kind (gfc_expr *);
|
||||
try gfc_check_selected_int_kind (gfc_expr *);
|
||||
try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_set_exponent (gfc_expr *, gfc_expr *);
|
||||
@ -287,6 +288,7 @@ gfc_expr *gfc_simplify_reshape (gfc_expr *, gfc_expr *, gfc_expr *,
|
||||
gfc_expr *gfc_simplify_rrspacing (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_scale (gfc_expr *, gfc_expr *);
|
||||
gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
gfc_expr *gfc_simplify_selected_char_kind (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_selected_int_kind (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *);
|
||||
gfc_expr *gfc_simplify_set_exponent (gfc_expr *, gfc_expr *);
|
||||
|
||||
@ -225,6 +225,7 @@ Some basic guidelines for editing this document:
|
||||
* @code{SCAN}: SCAN, Scan a string for the presence of a set of characters
|
||||
* @code{SECNDS}: SECNDS, Time function
|
||||
* @code{SECOND}: SECOND, CPU time function
|
||||
* @code{SELECTED_CHAR_KIND}: SELECTED_CHAR_KIND, Choose character kind
|
||||
* @code{SELECTED_INT_KIND}: SELECTED_INT_KIND, Choose integer kind
|
||||
* @code{SELECTED_REAL_KIND}: SELECTED_REAL_KIND, Choose real kind
|
||||
* @code{SET_EXPONENT}: SET_EXPONENT, Set the exponent of the model
|
||||
@ -9256,6 +9257,48 @@ seconds.
|
||||
|
||||
|
||||
|
||||
@node SELECTED_CHAR_KIND
|
||||
@section @code{SELECTED_CHAR_KIND} --- Choose character kind
|
||||
@fnindex SELECTED_CHAR_KIND
|
||||
@cindex character kind
|
||||
@cindex kind, character
|
||||
|
||||
@table @asis
|
||||
@item @emph{Description}:
|
||||
|
||||
@code{SELECTED_CHAR_KIND(NAME)} returns the kind value for the character
|
||||
set named @var{NAME}, if a character set with such a name is supported,
|
||||
or @math{-1} otherwise. Currently, supported character sets include
|
||||
``ASCII'' and ``DEFAULT'', which are equivalent.
|
||||
|
||||
@item @emph{Standard}:
|
||||
Fortran 2003 and later
|
||||
|
||||
@item @emph{Class}:
|
||||
Transformational function
|
||||
|
||||
@item @emph{Syntax}:
|
||||
@code{RESULT = SELECTED_CHAR_KIND(NAME)}
|
||||
|
||||
@item @emph{Arguments}:
|
||||
@multitable @columnfractions .15 .70
|
||||
@item @var{NAME} @tab Shall be a scalar and of the default character type.
|
||||
@end multitable
|
||||
|
||||
@item @emph{Example}:
|
||||
@smallexample
|
||||
program ascii_kind
|
||||
integer,parameter :: ascii = selected_char_kind("ascii")
|
||||
character(kind=ascii, len=26) :: s
|
||||
|
||||
s = ascii_"abcdefghijklmnopqrstuvwxyz"
|
||||
print *, s
|
||||
end program ascii_kind
|
||||
@end smallexample
|
||||
@end table
|
||||
|
||||
|
||||
|
||||
@node SELECTED_INT_KIND
|
||||
@section @code{SELECTED_INT_KIND} --- Choose integer kind
|
||||
@fnindex SELECTED_INT_KIND
|
||||
|
||||
@ -60,6 +60,8 @@ match_kind_param (int *kind)
|
||||
if (p != NULL)
|
||||
return MATCH_NO;
|
||||
|
||||
gfc_set_sym_referenced (sym);
|
||||
|
||||
if (*kind < 0)
|
||||
return MATCH_NO;
|
||||
|
||||
@ -907,6 +909,7 @@ match_string_constant (gfc_expr **result)
|
||||
gfc_error (q);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
gfc_set_sym_referenced (sym);
|
||||
}
|
||||
|
||||
if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
|
||||
|
||||
@ -3628,6 +3628,28 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
|
||||
}
|
||||
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_selected_char_kind (gfc_expr *e)
|
||||
{
|
||||
int kind;
|
||||
gfc_expr *result;
|
||||
|
||||
if (e->expr_type != EXPR_CONSTANT)
|
||||
return NULL;
|
||||
|
||||
if (gfc_compare_with_Cstring (e, "ascii", false) == 0
|
||||
|| gfc_compare_with_Cstring (e, "default", false) == 0)
|
||||
kind = 1;
|
||||
else
|
||||
kind = -1;
|
||||
|
||||
result = gfc_int_expr (kind);
|
||||
result->where = e->where;
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_selected_int_kind (gfc_expr *e)
|
||||
{
|
||||
|
||||
@ -124,7 +124,8 @@ tree gfor_fndecl_size0;
|
||||
tree gfor_fndecl_size1;
|
||||
tree gfor_fndecl_iargc;
|
||||
|
||||
/* Intrinsic functions implemented in FORTRAN. */
|
||||
/* Intrinsic functions implemented in Fortran. */
|
||||
tree gfor_fndecl_sc_kind;
|
||||
tree gfor_fndecl_si_kind;
|
||||
tree gfor_fndecl_sr_kind;
|
||||
|
||||
@ -2099,19 +2100,22 @@ gfc_build_intrinsic_function_decls (void)
|
||||
pchar_type_node,
|
||||
gfc_charlen_type_node, pchar_type_node);
|
||||
|
||||
gfor_fndecl_sc_kind =
|
||||
gfc_build_library_function_decl (get_identifier
|
||||
(PREFIX("selected_char_kind")),
|
||||
gfc_int4_type_node, 2,
|
||||
gfc_charlen_type_node, pchar_type_node);
|
||||
|
||||
gfor_fndecl_si_kind =
|
||||
gfc_build_library_function_decl (get_identifier
|
||||
(PREFIX("selected_int_kind")),
|
||||
gfc_int4_type_node,
|
||||
1,
|
||||
pvoid_type_node);
|
||||
gfc_int4_type_node, 1, pvoid_type_node);
|
||||
|
||||
gfor_fndecl_sr_kind =
|
||||
gfc_build_library_function_decl (get_identifier
|
||||
(PREFIX("selected_real_kind")),
|
||||
gfc_int4_type_node,
|
||||
2, pvoid_type_node,
|
||||
pvoid_type_node);
|
||||
gfc_int4_type_node, 2,
|
||||
pvoid_type_node, pvoid_type_node);
|
||||
|
||||
/* Power functions. */
|
||||
{
|
||||
|
||||
@ -3736,6 +3736,19 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
|
||||
}
|
||||
|
||||
|
||||
/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
|
||||
|
||||
static void
|
||||
gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
|
||||
{
|
||||
tree args[2];
|
||||
|
||||
gfc_conv_intrinsic_function_args (se, expr, args, 2);
|
||||
se->expr = build_call_expr (gfor_fndecl_sc_kind, 2, args[0], args[1]);
|
||||
se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
|
||||
}
|
||||
|
||||
|
||||
/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
|
||||
|
||||
static void
|
||||
@ -4049,6 +4062,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
||||
gfc_conv_intrinsic_trim (se, expr);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_SC_KIND:
|
||||
gfc_conv_intrinsic_sc_kind (se, expr);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_SI_KIND:
|
||||
gfc_conv_intrinsic_si_kind (se, expr);
|
||||
break;
|
||||
|
||||
@ -556,7 +556,8 @@ extern GTY(()) tree gfor_fndecl_size0;
|
||||
extern GTY(()) tree gfor_fndecl_size1;
|
||||
extern GTY(()) tree gfor_fndecl_iargc;
|
||||
|
||||
/* Implemented in FORTRAN. */
|
||||
/* Implemented in Fortran. */
|
||||
extern GTY(()) tree gfor_fndecl_sc_kind;
|
||||
extern GTY(()) tree gfor_fndecl_si_kind;
|
||||
extern GTY(()) tree gfor_fndecl_sr_kind;
|
||||
|
||||
|
||||
@ -1,7 +1,13 @@
|
||||
2008-04-30 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
* gfortran.dg/selected_char_kind_1.f90: New test.
|
||||
* gfortran.dg/selected_char_kind_2.f90: New test.
|
||||
* gfortran.dg/selected_char_kind_3.f90: New test.
|
||||
|
||||
2008-04-28 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/35997
|
||||
* gfortran.dg/use_rename_3.f90
|
||||
PR fortran/35997
|
||||
* gfortran.dg/use_rename_3.f90
|
||||
|
||||
2008-04-30 Richard Guenther <rguenther@suse.de>
|
||||
|
||||
|
||||
65
gcc/testsuite/gfortran.dg/selected_char_kind_1.f90
Normal file
65
gcc/testsuite/gfortran.dg/selected_char_kind_1.f90
Normal file
@ -0,0 +1,65 @@
|
||||
! { dg-do run }
|
||||
!
|
||||
! Checks for the SELECTED_CHAR_KIND intrinsic
|
||||
!
|
||||
integer, parameter :: ascii = selected_char_kind ("ascii")
|
||||
integer, parameter :: default = selected_char_kind ("default")
|
||||
|
||||
character(kind=ascii) :: s1
|
||||
character(kind=default) :: s2
|
||||
character(kind=selected_char_kind ("ascii")) :: s3
|
||||
character(kind=selected_char_kind ("default")) :: s4
|
||||
|
||||
if (kind (s1) /= selected_char_kind ("ascii")) call abort
|
||||
if (kind (s2) /= selected_char_kind ("default")) call abort
|
||||
if (kind (s3) /= ascii) call abort
|
||||
if (kind (s4) /= default) call abort
|
||||
|
||||
if (selected_char_kind("ascii") /= 1) call abort
|
||||
if (selected_char_kind("default") /= 1) call abort
|
||||
if (selected_char_kind("defauLt") /= 1) call abort
|
||||
if (selected_char_kind("foo") /= -1) call abort
|
||||
if (selected_char_kind("asciiiii") /= -1) call abort
|
||||
if (selected_char_kind("default ") /= 1) call abort
|
||||
|
||||
call test("ascii", 1)
|
||||
call test("default", 1)
|
||||
call test("defauLt", 1)
|
||||
call test("asciiiiii", -1)
|
||||
call test("foo", -1)
|
||||
call test("default ", 1)
|
||||
call test("default x", -1)
|
||||
|
||||
call test(ascii_"ascii", 1)
|
||||
call test(ascii_"default", 1)
|
||||
call test(ascii_"defauLt", 1)
|
||||
call test(ascii_"asciiiiii", -1)
|
||||
call test(ascii_"foo", -1)
|
||||
call test(ascii_"default ", 1)
|
||||
call test(ascii_"default x", -1)
|
||||
|
||||
call test(default_"ascii", 1)
|
||||
call test(default_"default", 1)
|
||||
call test(default_"defauLt", 1)
|
||||
call test(default_"asciiiiii", -1)
|
||||
call test(default_"foo", -1)
|
||||
call test(default_"default ", 1)
|
||||
call test(default_"default x", -1)
|
||||
|
||||
if (kind (selected_char_kind ("")) /= kind(0)) call abort
|
||||
end
|
||||
|
||||
subroutine test(s,i)
|
||||
character(len=*,kind=selected_char_kind("ascii")) s
|
||||
integer i
|
||||
|
||||
call test2(s,i)
|
||||
if (selected_char_kind (s) /= i) call abort
|
||||
end subroutine test
|
||||
|
||||
subroutine test2(s,i)
|
||||
character(len=*,kind=selected_char_kind("default")) s
|
||||
integer i
|
||||
|
||||
if (selected_char_kind (s) /= i) call abort
|
||||
end subroutine test2
|
||||
14
gcc/testsuite/gfortran.dg/selected_char_kind_2.f90
Normal file
14
gcc/testsuite/gfortran.dg/selected_char_kind_2.f90
Normal file
@ -0,0 +1,14 @@
|
||||
! { dg-do compile }
|
||||
!
|
||||
! Check that nonexisting character kinds are not rejected by the compiler
|
||||
!
|
||||
character(kind=selected_char_kind("")) :: s1 ! { dg-error "is not supported for CHARACTER" }
|
||||
character(kind=selected_char_kind(" ")) :: s2 ! { dg-error "is not supported for CHARACTER" }
|
||||
character(kind=selected_char_kind("asciii")) :: s3 ! { dg-error "is not supported for CHARACTER" }
|
||||
character(kind=selected_char_kind("I don't exist")) :: s4 ! { dg-error "is not supported for CHARACTER" }
|
||||
|
||||
print *, selected_char_kind() ! { dg-error "Missing actual argument" }
|
||||
print *, selected_char_kind(12) ! { dg-error "must be CHARACTER" }
|
||||
print *, selected_char_kind(["foo", "bar"]) ! { dg-error "must be a scalar" }
|
||||
|
||||
end
|
||||
10
gcc/testsuite/gfortran.dg/selected_char_kind_3.f90
Normal file
10
gcc/testsuite/gfortran.dg/selected_char_kind_3.f90
Normal file
@ -0,0 +1,10 @@
|
||||
! { dg-do compile }
|
||||
! { dg-options "-std=f95 -pedantic -Wall" }
|
||||
!
|
||||
! Check that SELECTED_CHAR_KIND is rejected with -std=f95
|
||||
!
|
||||
implicit none
|
||||
character(kind=selected_char_kind("ascii")) :: s ! { dg-error "is not included in the selected standard" }
|
||||
s = "" ! { dg-error "has no IMPLICIT type" }
|
||||
print *, s
|
||||
end
|
||||
@ -1,3 +1,10 @@
|
||||
2008-04-30 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
* intrinsics/selected_char_kind.c: New file.
|
||||
* gfortran.map (GFORTRAN_1.1): Add _gfortran_selected_char_kind.
|
||||
* Makefile.am: Add intrinsics/selected_char_kind.c.
|
||||
* Makefile.in: Regenerate.
|
||||
|
||||
2008-04-30 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
PR libfortran/35993
|
||||
|
||||
@ -87,6 +87,7 @@ intrinsics/mvbits.c \
|
||||
intrinsics/move_alloc.c \
|
||||
intrinsics/pack_generic.c \
|
||||
intrinsics/perror.c \
|
||||
intrinsics/selected_char_kind.c \
|
||||
intrinsics/signal.c \
|
||||
intrinsics/size.c \
|
||||
intrinsics/sleep.c \
|
||||
|
||||
@ -416,7 +416,8 @@ am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c \
|
||||
intrinsics/kill.c intrinsics/link.c intrinsics/malloc.c \
|
||||
intrinsics/mvbits.c intrinsics/move_alloc.c \
|
||||
intrinsics/pack_generic.c intrinsics/perror.c \
|
||||
intrinsics/signal.c intrinsics/size.c intrinsics/sleep.c \
|
||||
intrinsics/selected_char_kind.c intrinsics/signal.c \
|
||||
intrinsics/size.c intrinsics/sleep.c \
|
||||
intrinsics/spread_generic.c intrinsics/string_intrinsics.c \
|
||||
intrinsics/system.c intrinsics/rand.c intrinsics/random.c \
|
||||
intrinsics/rename.c intrinsics/reshape_generic.c \
|
||||
@ -698,12 +699,12 @@ am__objects_35 = associated.lo abort.lo access.lo args.lo \
|
||||
fnum.lo gerror.lo getcwd.lo getlog.lo getXid.lo hostnm.lo \
|
||||
ierrno.lo ishftc.lo iso_c_generated_procs.lo iso_c_binding.lo \
|
||||
kill.lo link.lo malloc.lo mvbits.lo move_alloc.lo \
|
||||
pack_generic.lo perror.lo signal.lo size.lo sleep.lo \
|
||||
spread_generic.lo string_intrinsics.lo system.lo rand.lo \
|
||||
random.lo rename.lo reshape_generic.lo reshape_packed.lo \
|
||||
selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
|
||||
system_clock.lo time.lo transpose_generic.lo umask.lo \
|
||||
unlink.lo unpack_generic.lo in_pack_generic.lo \
|
||||
pack_generic.lo perror.lo selected_char_kind.lo signal.lo \
|
||||
size.lo sleep.lo spread_generic.lo string_intrinsics.lo \
|
||||
system.lo rand.lo random.lo rename.lo reshape_generic.lo \
|
||||
reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
|
||||
stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
|
||||
umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
|
||||
in_unpack_generic.lo
|
||||
am__objects_36 =
|
||||
am__objects_37 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
|
||||
@ -986,6 +987,7 @@ intrinsics/mvbits.c \
|
||||
intrinsics/move_alloc.c \
|
||||
intrinsics/pack_generic.c \
|
||||
intrinsics/perror.c \
|
||||
intrinsics/selected_char_kind.c \
|
||||
intrinsics/signal.c \
|
||||
intrinsics/size.c \
|
||||
intrinsics/sleep.c \
|
||||
@ -2073,6 +2075,7 @@ distclean-compile:
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/rrspacing_r4.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/rrspacing_r8.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/select.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/selected_char_kind.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/set_exponent_r10.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/set_exponent_r16.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/set_exponent_r4.Plo@am__quote@
|
||||
@ -5372,6 +5375,13 @@ perror.lo: intrinsics/perror.c
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o perror.lo `test -f 'intrinsics/perror.c' || echo '$(srcdir)/'`intrinsics/perror.c
|
||||
|
||||
selected_char_kind.lo: intrinsics/selected_char_kind.c
|
||||
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT selected_char_kind.lo -MD -MP -MF "$(DEPDIR)/selected_char_kind.Tpo" -c -o selected_char_kind.lo `test -f 'intrinsics/selected_char_kind.c' || echo '$(srcdir)/'`intrinsics/selected_char_kind.c; \
|
||||
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/selected_char_kind.Tpo" "$(DEPDIR)/selected_char_kind.Plo"; else rm -f "$(DEPDIR)/selected_char_kind.Tpo"; exit 1; fi
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='intrinsics/selected_char_kind.c' object='selected_char_kind.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o selected_char_kind.lo `test -f 'intrinsics/selected_char_kind.c' || echo '$(srcdir)/'`intrinsics/selected_char_kind.c
|
||||
|
||||
signal.lo: intrinsics/signal.c
|
||||
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT signal.lo -MD -MP -MF "$(DEPDIR)/signal.Tpo" -c -o signal.lo `test -f 'intrinsics/signal.c' || echo '$(srcdir)/'`intrinsics/signal.c; \
|
||||
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/signal.Tpo" "$(DEPDIR)/signal.Plo"; else rm -f "$(DEPDIR)/signal.Tpo"; exit 1; fi
|
||||
|
||||
@ -1037,6 +1037,7 @@ GFORTRAN_1.1 {
|
||||
_gfortran_erfc_scaled_r8;
|
||||
_gfortran_erfc_scaled_r10;
|
||||
_gfortran_erfc_scaled_r16;
|
||||
_gfortran_selected_char_kind;
|
||||
_gfortran_st_wait;
|
||||
} GFORTRAN_1.0;
|
||||
|
||||
|
||||
49
libgfortran/intrinsics/selected_char_kind.c
Normal file
49
libgfortran/intrinsics/selected_char_kind.c
Normal file
@ -0,0 +1,49 @@
|
||||
/* Copyright 2008 Free Software Foundation, Inc.
|
||||
Contributed by Paul Brook <paul@nowt.org>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran 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 General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
Boston, MA 02110-1301, USA. */
|
||||
|
||||
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <string.h>
|
||||
|
||||
|
||||
extern GFC_INTEGER_4 selected_char_kind (gfc_charlen_type, char *);
|
||||
export_proto(selected_char_kind);
|
||||
|
||||
GFC_INTEGER_4
|
||||
selected_char_kind (gfc_charlen_type name_len, char *name)
|
||||
{
|
||||
gfc_charlen_type len = fstrlen (name, name_len);
|
||||
|
||||
if ((len == 5 && strncasecmp (name, "ascii", 5) == 0)
|
||||
|| (len == 7 && strncasecmp (name, "default", 7) == 0))
|
||||
return 1;
|
||||
else
|
||||
return -1;
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user